[cig-commits] r21224 - in seismo/3D/SPECFEM3D/trunk: . DATA doc examples/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/DATA examples/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/DATA examples/Mount_StHelens/DATA examples/homogeneous_halfspace_HEX27/DATA examples/homogeneous_halfspace_HEX8/DATA examples/homogeneous_poroelastic/DATA examples/layered_halfspace/DATA examples/meshfem3D_examples/many_interfaces/DATA examples/meshfem3D_examples/simple_model/DATA examples/meshfem3D_examples/socal1D/DATA examples/splay_faults/DATA examples/tomographic_model/DATA examples/tpv102/DATA examples/tpv103/DATA examples/tpv15/DATA examples/tpv16/DATA examples/tpv5/DATA examples/waterlayered_halfspace/DATA src/cuda src/decompose_mesh src/generate_databases src/meshfem3D src/shared src/specfem3D
joseph.charles at geodynamics.org
joseph.charles at geodynamics.org
Sat Jan 12 13:24:24 PST 2013
Author: joseph.charles
Date: 2013-01-12 13:24:23 -0800 (Sat, 12 Jan 2013)
New Revision: 21224
Added:
seismo/3D/SPECFEM3D/trunk/src/generate_databases/pml_set_local_dampingcoeff.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_allocate_arrays.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_output_VTKs.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_par.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_set_accel_contribution.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_set_memory_variables.f90
Removed:
seismo/3D/SPECFEM3D/trunk/src/specfem3D/PML_init.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic_PML.f90
Modified:
seismo/3D/SPECFEM3D/trunk/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/doc/convention_to_label_the_seven_different_3D_CPML_regions.txt
seismo/3D/SPECFEM3D/trunk/examples/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/Mount_StHelens/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/homogeneous_halfspace_HEX27/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/homogeneous_halfspace_HEX8/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/homogeneous_poroelastic/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/layered_halfspace/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/many_interfaces/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/simple_model/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/socal1D/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/splay_faults/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/tomographic_model/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/tpv102/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/tpv103/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/tpv15/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/tpv16/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/tpv5/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/examples/waterlayered_halfspace/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/src/cuda/compute_forces_elastic_cuda.cu
seismo/3D/SPECFEM3D/trunk/src/cuda/mesh_constants_cuda.h
seismo/3D/SPECFEM3D/trunk/src/cuda/prepare_mesh_constants_cuda.cu
seismo/3D/SPECFEM3D/trunk/src/cuda/transfer_fields_cuda.cu
seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/decompose_mesh.F90
seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/part_decompose_mesh.f90
seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/program_decompose_mesh.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/Makefile.in
seismo/3D/SPECFEM3D/trunk/src/generate_databases/create_mass_matrices.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/create_regions_mesh.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/generate_databases.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/generate_databases_par.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/get_absorbing_boundary.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/get_model.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/memory_eval.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/model_default.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/read_partition_files.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/save_arrays_solver.f90
seismo/3D/SPECFEM3D/trunk/src/generate_databases/setup_mesh.f90
seismo/3D/SPECFEM3D/trunk/src/meshfem3D/check_mesh_quality.f90
seismo/3D/SPECFEM3D/trunk/src/meshfem3D/meshfem3D.f90
seismo/3D/SPECFEM3D/trunk/src/meshfem3D/save_databases.f90
seismo/3D/SPECFEM3D/trunk/src/shared/check_mesh_resolution.f90
seismo/3D/SPECFEM3D/trunk/src/shared/combine_vol_data.f90
seismo/3D/SPECFEM3D/trunk/src/shared/constants.h.in
seismo/3D/SPECFEM3D/trunk/src/shared/create_movie_shakemap_AVS_DX_GMT.f90
seismo/3D/SPECFEM3D/trunk/src/shared/get_force.f90
seismo/3D/SPECFEM3D/trunk/src/shared/read_parameter_file.f90
seismo/3D/SPECFEM3D/trunk/src/shared/smooth_vol_data.f90
seismo/3D/SPECFEM3D/trunk/src/shared/sum_kernels.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/Makefile.in
seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic_pot.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_elastic.F90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_elastic_noDev.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/finalize_simulation.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/initialize_simulation.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/iterate_time.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/prepare_timerun.F90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/read_mesh_databases.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/setup_sources_receivers.f90
seismo/3D/SPECFEM3D/trunk/src/specfem3D/specfem3D_par.f90
seismo/3D/SPECFEM3D/trunk/todo_list_please_dont_remove.txt
Log:
adds C-PML boundary conditions in CPU code for elastic and acoustic domains. BEWARE!!! runs ok but no fully tested -> desactivated by default in all examples.
Modified: seismo/3D/SPECFEM3D/trunk/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -82,8 +99,7 @@
# 0 = read the whole adjoint sources at the same time
NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/doc/convention_to_label_the_seven_different_3D_CPML_regions.txt
===================================================================
--- seismo/3D/SPECFEM3D/trunk/doc/convention_to_label_the_seven_different_3D_CPML_regions.txt 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/doc/convention_to_label_the_seven_different_3D_CPML_regions.txt 2013-01-12 21:24:23 UTC (rev 21224)
@@ -1,4 +1,4 @@
-Convention for the C-PML flags:
+Convention for C-PML flags:
cpml_x (flag 1) X_surface C-PML
cpml_y (flag 2) Y_surface C-PML
Modified: seismo/3D/SPECFEM3D/trunk/examples/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/BENCHMARK_CLAERBOUT_ADJOINT/ACOUSTIC/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -70,7 +87,7 @@
SAVE_MESH_FILES = .true.
# path to store the local database file on each node
-LOCAL_PATH = ../OUTPUT_FILES/DATABASES_MPI/
+LOCAL_PATH = ../OUTPUT_FILES/DATABASES_MPI
# interval at which we output time step info and max of norm of displacement
NTSTEP_BETWEEN_OUTPUT_INFO = 100
@@ -79,10 +96,10 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS = 10000
# interval in time steps for reading adjoint traces
-NTSTEP_BETWEEN_READ_ADJSRC = 0 # 0 = read the whole adjoint sources at the same time
+# 0 = read the whole adjoint sources at the same time
+NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/BENCHMARK_CLAERBOUT_ADJOINT/ELASTIC/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -70,7 +87,7 @@
SAVE_MESH_FILES = .true.
# path to store the local database file on each node
-LOCAL_PATH = ../OUTPUT_FILES/DATABASES_MPI/
+LOCAL_PATH = ../OUTPUT_FILES/DATABASES_MPI
# interval at which we output time step info and max of norm of displacement
NTSTEP_BETWEEN_OUTPUT_INFO = 100
@@ -79,10 +96,10 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS = 10000
# interval in time steps for reading adjoint traces
-NTSTEP_BETWEEN_READ_ADJSRC = 0 # 0 = read the whole adjoint sources at the same time
+# 0 = read the whole adjoint sources at the same time
+NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/Mount_StHelens/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/Mount_StHelens/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/Mount_StHelens/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -79,10 +96,10 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS = 10000
# interval in time steps for reading adjoint traces
-NTSTEP_BETWEEN_READ_ADJSRC = 0 # 0 = read the whole adjoint sources at the same time
+# 0 = read the whole adjoint sources at the same time
+NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/homogeneous_halfspace_HEX27/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/homogeneous_halfspace_HEX27/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/homogeneous_halfspace_HEX27/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -82,8 +99,7 @@
# 0 = read the whole adjoint sources at the same time
NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/homogeneous_halfspace_HEX8/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/homogeneous_halfspace_HEX8/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/homogeneous_halfspace_HEX8/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -82,8 +99,7 @@
# 0 = read the whole adjoint sources at the same time
NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/homogeneous_poroelastic/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/homogeneous_poroelastic/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/homogeneous_poroelastic/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -1,4 +1,4 @@
-*# simulation input parameters
+# simulation input parameters
#
# forward or adjoint simulation
# 1 = forward, 2 = adjoint, 3 = both simultaneously
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -79,11 +96,10 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS = 10000
# interval in time steps for reading adjoint traces
-# # 0 = read the whole adjoint sources at the same time
+# 0 = read the whole adjoint sources at the same time
NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/layered_halfspace/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/layered_halfspace/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/layered_halfspace/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -79,10 +96,10 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS = 10000
# interval in time steps for reading adjoint traces
-NTSTEP_BETWEEN_READ_ADJSRC = 0 # 0 = read the whole adjoint sources at the same time
+# 0 = read the whole adjoint sources at the same time
+NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/many_interfaces/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/many_interfaces/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/many_interfaces/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -79,10 +96,10 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS = 10000
# interval in time steps for reading adjoint traces
-NTSTEP_BETWEEN_READ_ADJSRC = 0 # 0 = read the whole adjoint sources at the same time
+# 0 = read the whole adjoint sources at the same time
+NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/simple_model/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/simple_model/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/simple_model/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -79,10 +96,10 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS = 10000
# interval in time steps for reading adjoint traces
-NTSTEP_BETWEEN_READ_ADJSRC = 0 # 0 = read the whole adjoint sources at the same time
+# 0 = read the whole adjoint sources at the same time
+NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/socal1D/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/socal1D/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/meshfem3D_examples/socal1D/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -79,10 +96,10 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS = 10000
# interval in time steps for reading adjoint traces
-NTSTEP_BETWEEN_READ_ADJSRC = 0 # 0 = read the whole adjoint sources at the same time
+# 0 = read the whole adjoint sources at the same time
+NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/splay_faults/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/splay_faults/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/splay_faults/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -82,8 +99,7 @@
# 0 = read the whole adjoint sources at the same time
NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/tomographic_model/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/tomographic_model/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/tomographic_model/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -79,10 +96,10 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS = 10000
# interval in time steps for reading adjoint traces
-NTSTEP_BETWEEN_READ_ADJSRC = 0 # 0 = read the whole adjoint sources at the same time
+# 0 = read the whole adjoint sources at the same time
+NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/tpv102/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/tpv102/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/tpv102/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -82,8 +99,7 @@
# 0 = read the whole adjoint sources at the same time
NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/tpv103/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/tpv103/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/tpv103/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -82,8 +99,7 @@
# 0 = read the whole adjoint sources at the same time
NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/tpv15/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/tpv15/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/tpv15/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -82,8 +99,7 @@
# 0 = read the whole adjoint sources at the same time
NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/tpv16/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/tpv16/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/tpv16/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.d0
+PML_WIDTH_MAX = 25000.d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -82,8 +99,7 @@
# 0 = read the whole adjoint sources at the same time
NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/tpv5/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/tpv5/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/tpv5/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -82,8 +99,7 @@
# 0 = read the whole adjoint sources at the same time
NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/examples/waterlayered_halfspace/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/examples/waterlayered_halfspace/DATA/Par_file 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/examples/waterlayered_halfspace/DATA/Par_file 2013-01-12 21:24:23 UTC (rev 21224)
@@ -54,6 +54,23 @@
# absorbing top surface (defined in mesh as 'free_surface_file')
ABSORB_INSTEAD_OF_FREE_SURFACE = .false.
+# C-PML boundary conditions for a regional simulation
+PML_CONDITIONS = .false.
+
+# C-PML top surface
+PML_INSTEAD_OF_FREE_SURFACE = .false.
+
+# C-PML thickness min/max
+PML_WIDTH_MIN = 10000.0d0
+PML_WIDTH_MAX = 25000.0d0
+
+# C-PML dominant frequency
+f0_FOR_PML = 12.7
+
+# parameters used to rotate C-PML boundary conditions by a given angle (not completed yet)
+# ROTATE_PML_ACTIVATE = .false.
+# ROTATE_PML_ANGLE = 0.
+
# save AVS or OpenDX movies
# MOVIE_TYPE = 1 to show the top surface
# MOVIE_TYPE = 2 to show all the external faces of the mesh
@@ -79,10 +96,10 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS = 10000
# interval in time steps for reading adjoint traces
-NTSTEP_BETWEEN_READ_ADJSRC = 0 # 0 = read the whole adjoint sources at the same time
+# 0 = read the whole adjoint sources at the same time
+NTSTEP_BETWEEN_READ_ADJSRC = 0
-# use a (tilted) FORCESOLUTION force point source (or several) located exactly at a grid point
-# instead of a CMTSOLUTION moment-tensor source.
+# use a (tilted) FORCESOLUTION force point source (or several) instead of a CMTSOLUTION moment-tensor source.
# This can be useful e.g. for oil industry foothills simulations or asteroid simulations
# in which the source is a vertical force, normal force, inclined force, impact etc.
# If this flag is turned on, the FORCESOLUTION file must be edited by precising:
Modified: seismo/3D/SPECFEM3D/trunk/src/cuda/compute_forces_elastic_cuda.cu
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/cuda/compute_forces_elastic_cuda.cu 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/cuda/compute_forces_elastic_cuda.cu 2013-01-12 21:24:23 UTC (rev 21224)
@@ -799,6 +799,7 @@
#endif
}
+ // JC JC here we will need to add GPU support for the new C-PML routines
if(ATTENUATION){
// use first order Taylor expansion of displacement for local storage of stresses
// at this current time step, to fix attenuation in a consistent way
@@ -864,6 +865,7 @@
}
+ // JC JC here we will need to add GPU support for the new C-PML routines
if( ATTENUATION){
// temporary variables used for fixing attenuation in a consistent way
@@ -957,6 +959,7 @@
+ s_dummyz_loc[3*NGLL2+J*NGLLX+I]*d_hprime_xx[3*NGLLX+K]
+ s_dummyz_loc[4*NGLL2+J*NGLLX+I]*d_hprime_xx[4*NGLLX+K];
+ // JC JC here we will need to add GPU support for the new C-PML routines
if( ATTENUATION){
// temporary variables used for fixing attenuation in a consistent way
@@ -1042,6 +1045,8 @@
duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l;
duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l;
+ // JC JC here we will need to add GPU support for the new C-PML routines
+
// precompute some sums to save CPU time
duxdxl_plus_duydyl = duxdxl + duydyl;
duxdxl_plus_duzdzl = duxdxl + duzdzl;
@@ -1050,6 +1055,7 @@
duzdxl_plus_duxdzl = duzdxl + duxdzl;
duzdyl_plus_duydzl = duzdyl + duydzl;
+ // JC JC here we will need to add GPU support for the new C-PML routines
if( ATTENUATION){
// temporary variables used for fixing attenuation in a consistent way
@@ -1084,6 +1090,8 @@
if(SIMULATION_TYPE == 3) {
epsilon_trace_over_3[tx + working_element*NGLL3] = templ;
}
+
+ // JC JC here we will need to add GPU support for the new C-PML routines
}
}else{
// computes deviatoric strain attenuation and/or for kernel calculations
@@ -1217,6 +1225,8 @@
// to be able to compute the matrix products along cut planes of the 3D element below
__syncthreads();
+ // JC JC here we will need to add GPU support for the new C-PML routines
+
if (active) {
#ifndef MANUALLY_UNROLLED_LOOPS
@@ -1342,6 +1352,8 @@
d_accel[iglob*3 + 2] += sum_terms3;
#endif // USE_TEXTURES_FIELDS
+ // JC JC here we will need to add GPU support for the new C-PML routines
+
#else // MESH_COLORING
//mesh coloring
@@ -1399,6 +1411,8 @@
} // if(active)
+ // JC JC here we will need to add GPU support for the new C-PML routines
+
} // kernel_2_impl()
/* ----------------------------------------------------------------------------------------------- */
Modified: seismo/3D/SPECFEM3D/trunk/src/cuda/mesh_constants_cuda.h
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/cuda/mesh_constants_cuda.h 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/cuda/mesh_constants_cuda.h 2013-01-12 21:24:23 UTC (rev 21224)
@@ -441,6 +441,8 @@
realw* d_free_surface_normal;
int* d_updated_dof_ocean_load;
+ // JC JC here we will need to add GPU support for the new C-PML routines
+
// ------------------------------------------------------------------ //
// acoustic wavefield
// ------------------------------------------------------------------ //
Modified: seismo/3D/SPECFEM3D/trunk/src/cuda/prepare_mesh_constants_cuda.cu
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/cuda/prepare_mesh_constants_cuda.cu 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/cuda/prepare_mesh_constants_cuda.cu 2013-01-12 21:24:23 UTC (rev 21224)
@@ -399,6 +399,8 @@
// gravity flag initialization
mp->gravity = 0;
+ // JC JC here we will need to add GPU support for the new C-PML routines
+
#ifdef ENABLE_VERY_SLOW_ERROR_CHECKING
exit_on_cuda_error("prepare_constants_device");
#endif
@@ -1078,6 +1080,8 @@
mp->h_num_elem_colors_elastic = (int*) num_elem_colors_elastic;
}
+ // JC JC here we will need to add GPU support for the new C-PML routines
+
#ifdef ENABLE_VERY_SLOW_ERROR_CHECKING
exit_on_cuda_error("prepare_fields_elastic_device");
#endif
Modified: seismo/3D/SPECFEM3D/trunk/src/cuda/transfer_fields_cuda.cu
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/cuda/transfer_fields_cuda.cu 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/cuda/transfer_fields_cuda.cu 2013-01-12 21:24:23 UTC (rev 21224)
@@ -344,6 +344,7 @@
#endif
}
+// JC JC here we will need to add GPU support for the new C-PML routines
/* ----------------------------------------------------------------------------------------------- */
Modified: seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/decompose_mesh.F90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/decompose_mesh.F90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/decompose_mesh.F90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -75,26 +75,33 @@
integer, dimension(:), pointer :: tab_size_interfaces, tab_interfaces
integer, dimension(:), allocatable :: my_interfaces
integer, dimension(:), allocatable :: my_nb_interfaces
- integer :: ninterfaces
- integer :: my_ninterface
+ integer :: ninterfaces
+ integer :: my_ninterface
integer :: nsize ! max number of elements that contain the same node
- integer :: nb_edges
+ integer :: nb_edges
- integer :: ispec, inode
- integer :: max_neighbour ! real maximum number of neighbours per element
- integer :: sup_neighbour ! majoration (overestimate) of the maximum number of neighbours per element
+ integer :: ispec, inode
+ integer :: max_neighbour ! real maximum number of neighbours per element
+ integer :: sup_neighbour ! majoration (overestimate) of the maximum number of neighbours per element
- integer :: ipart, nnodes_loc, nspec_local,ncommonnodes
- integer :: num_elmnt, num_node, num_mat
+ integer :: ipart, nnodes_loc, nspec_local,ncommonnodes
+ integer :: num_elmnt, num_node, num_mat
! boundaries
- integer :: ispec2D
- integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, nspec2D_bottom, nspec2D_top
+ integer :: ispec2D
+ integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, nspec2D_bottom, nspec2D_top
integer, dimension(:), allocatable :: ibelm_xmin, ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top
integer, dimension(:,:), allocatable :: nodes_ibelm_xmin, nodes_ibelm_xmax, nodes_ibelm_ymin
integer, dimension(:,:), allocatable :: nodes_ibelm_ymax, nodes_ibelm_bottom, nodes_ibelm_top
+ ! C-PML absorbing boundary conditions
+ integer :: ispec_CPML
+ integer :: nspec_cpml
+ integer, dimension(:), allocatable :: CPML_to_spec, CPML_regions
+ logical, dimension(:), allocatable :: CPML_mask_ibool
+ real(kind=CUSTOM_REAL) :: CPML_width
+
! moho surface (optional)
integer :: nspec2D_moho
integer, dimension(:), allocatable :: ibelm_moho
@@ -134,14 +141,14 @@
! for read_parameter_files
double precision :: DT
- double precision :: HDUR_MOVIE,OLSEN_ATTENUATION_RATIO
+ double precision :: HDUR_MOVIE,OLSEN_ATTENUATION_RATIO,f0_FOR_PML,PML_WIDTH_MIN,PML_WIDTH_MAX
integer :: NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP, &
UTM_PROJECTION_ZONE,SIMULATION_TYPE,NGNOD,NGNOD2D
integer :: NSOURCES,NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY
integer :: NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO,MOVIE_TYPE
logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
- logical :: ATTENUATION,USE_OLSEN_ATTENUATION, &
+ logical :: ATTENUATION,USE_OLSEN_ATTENUATION,PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE, &
OCEANS,TOPOGRAPHY,USE_FORCE_POINT_SOURCE
logical :: ABSORBING_CONDITIONS,SAVE_FORWARD,ABSORB_INSTEAD_OF_FREE_SURFACE
logical :: ANISOTROPY,SAVE_MESH_FILES,USE_RICKER_TIME_FUNCTION,PRINT_SOURCE_TIME_FUNCTION
@@ -237,7 +244,7 @@
if( ier /= 0 ) stop 'error allocating array mat'
mat(:,:) = 0
do ispec = 1, nspec
- ! format: # id_element #flag
+ ! format: #id_element #flag
! note: be aware that elements may not be sorted in materials_file
read(98,*) num_mat,mat(1,num_mat)
if((num_mat > nspec) .or. (num_mat < 1) ) stop "ERROR : Invalid mat file."
@@ -393,12 +400,16 @@
! undefined materials: have to be listed in decreasing order of material_id (start with -1, -2, etc...)
! format:
! - for interfaces
- ! #material_domain_id #material_id(<0) #type_name (="interface")
- ! #material_id_for_material_below #material_id_for_material_above
- ! example: 2 -1 interface 1 2
+ ! #(6) material_domain_id #(1) material_id(<0) #(2) type_name (="interface")
+ ! #(3) material_id_for_material_below #(4) material_id_for_material_above
+ ! example: 2 -1 interface 1 2
! - for tomography models
- ! #material_domain_id #material_id(<0) #type_name (="tomography") #block_name (="elastic") #file_name
- ! example: 2 -1 tomography elastic tomography_model.xyz
+ ! #(6) material_domain_id #(1) material_id(<0) #(2) type_name (="tomography")
+ ! #(3) block_name (="elastic") #(4) file_name
+ ! example: 2 -1 tomography elastic tomography_model.xyz
+ ! - for C-PML absorbing boundaries
+ ! #(6) material_domain_id #(1) material_id(<= -2000) #(2) rho #(3) vp #(4) vs
+ ! example: 2 -2001 2300.0 2800.0 1500.0
! reads lines until it reaches a defined material
num_mat = 1
do while( num_mat >= 0 .and. ier == 0 )
@@ -407,28 +418,38 @@
enddo
if( ier /= 0 ) stop 'error reading in undefined materials in nummaterial_velocity_file'
- ! checks if interface or tomography definition
+ ! checks if interface, tomography or C-PML definition
read(line,*) undef_mat_prop(6,imat),undef_mat_prop(1,imat),undef_mat_prop(2,imat)
+ read(undef_mat_prop(1,imat),*) num_mat
if( trim(undef_mat_prop(2,imat)) == 'interface' ) then
- ! line will have 5 arguments, e.g.: 2 -1 interface 1 2
+ ! line will have 5 arguments, e.g.: 2 -1 interface 1 2
read(line,*) undef_mat_prop(6,imat),undef_mat_prop(1,imat),undef_mat_prop(2,imat),&
undef_mat_prop(3,imat),undef_mat_prop(4,imat)
undef_mat_prop(5,imat) = "0" ! dummy value
- else if( trim(undef_mat_prop(2,imat)) == 'tomography' ) then
- ! line will have 6 arguments, e.g.: 2 -1 tomography elastic tomography_model.xyz 1
+ elseif( trim(undef_mat_prop(2,imat)) == 'tomography' ) then
+ ! line will have 6 arguments, e.g.: 2 -1 tomography elastic tomography_model.xyz 1
read(line,*) undef_mat_prop(6,imat),undef_mat_prop(1,imat),undef_mat_prop(2,imat),&
undef_mat_prop(3,imat),undef_mat_prop(4,imat)
undef_mat_prop(5,imat) = "0" ! dummy value
+ elseif( num_mat <= -2001 .and. num_mat >= -2007 ) then
+ ! line will have 5 arguments, e.g.: 2 -2001 2300.0 2800.0 1500.0
+ read(line,*) undef_mat_prop(6,imat),undef_mat_prop(1,imat),undef_mat_prop(2,imat),&
+ undef_mat_prop(3,imat),undef_mat_prop(4,imat)
+ undef_mat_prop(5,imat) = "0" ! dummy value
else
stop "ERROR: invalid line in nummaterial_velocity_file for undefined material"
endif
! checks material_id
- read(undef_mat_prop(1,imat),*) num_mat
- if(num_mat > 0 .or. -num_mat > count_undef_mat) &
- stop "ERROR : Invalid nummaterial_velocity_file for undefined materials."
- if(num_mat /= -imat) &
- stop "ERROR : Invalid material_id in nummaterial_velocity_file for undefined materials."
+ if( trim(undef_mat_prop(2,imat)) == 'interface' .or. trim(undef_mat_prop(2,imat)) == 'tomography' ) then
+ if(num_mat > 0 .or. -num_mat > count_undef_mat) &
+ stop "ERROR : Invalid nummaterial_velocity_file for undefined materials."
+ if(num_mat /= -imat) &
+ stop "ERROR : Invalid material_id in nummaterial_velocity_file for undefined materials."
+ else
+ if(num_mat > -2001 .or. num_mat < -2007) &
+ stop "ERROR : Invalid nummaterial_velocity_file for undefined materials."
+ endif
! checks interface: flag_down/flag_up
if( trim(undef_mat_prop(2,imat)) == 'interface' ) then
@@ -605,6 +626,48 @@
close(98)
print*, ' nspec2D_top = ', nspec2D_top
+ ! reads in absorbing_cpml boundary file
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/absorbing_cpml_file', &
+ status='old', form='formatted',iostat=ier)
+ if( ier /= 0 ) then
+ nspec_cpml = 0
+ else
+ read(98,*) nspec_cpml, CPML_width
+ endif
+
+ ! C-PML spectral elements global indexing
+ allocate(CPML_to_spec(nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array CPML_to_spec'
+ ! C-PML regions (see below)
+ allocate(CPML_regions(nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array CPML_regions'
+ do ispec_CPML=1,nspec_cpml
+ ! elements are stored with #id_cpml_regions increasing order:
+ !
+ ! #id_cpml_regions = 1 : X_surface C-PML
+ ! #id_cpml_regions = 2 : Y_surface C-PML
+ ! #id_cpml_regions = 3 : Z_surface C-PML
+ ! #id_cpml_regions = 4 : XY_edge C-PML
+ ! #id_cpml_regions = 5 : XZ_edge C-PML
+ ! #id_cpml_regions = 6 : YZ_edge C-PML
+ ! #id_cpml_regions = 7 : XYZ_corner C-PML
+ !
+ ! format: #id_cpml_element #id_cpml_regions
+ read(98,*) CPML_to_spec(ispec_CPML), CPML_regions(ispec_CPML)
+ enddo
+ close(98)
+ if( nspec_cpml > 0 ) print*, ' nspec_cpml = ', nspec_cpml
+
+ ! sets mask of C-PML elements for all elements in this partition
+ allocate(CPML_mask_ibool(nspec),stat=ier)
+ if(ier /= 0) stop 'error allocating array CPML_mask_ibool'
+ CPML_mask_ibool(:) = .false.
+ do ispec_CPML=1,nspec_cpml
+ if( (CPML_regions(ispec_CPML).ge.1) .and. (CPML_regions(ispec_CPML).le.7) ) then
+ CPML_mask_ibool(CPML_to_spec(ispec_CPML)) = .true.
+ endif
+ enddo
+
! reads in moho_surface boundary files (optional)
open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/moho_surface_file', &
status='old', form='formatted',iostat=ier)
@@ -929,8 +992,9 @@
subroutine write_mesh_databases
implicit none
- !local parameters
+ integer :: ier
+
allocate(my_interfaces(0:ninterfaces-1),stat=ier)
if( ier /= 0 ) stop 'error allocating array my_interfaces'
allocate(my_nb_interfaces(0:ninterfaces-1),stat=ier)
@@ -951,7 +1015,6 @@
endif
! gets number of nodes
-
call write_glob2loc_nodes_database(IIN_database, ipart, nnodes_loc, nodes_coords, &
glob2loc_nodes_nparts, glob2loc_nodes_parts, &
glob2loc_nodes, nnodes, 1)
@@ -966,7 +1029,6 @@
! writes out node coordinate locations
write(IIN_database) nnodes_loc
-
call write_glob2loc_nodes_database(IIN_database, ipart, nnodes_loc, nodes_coords,&
glob2loc_nodes_nparts, glob2loc_nodes_parts, &
glob2loc_nodes, nnodes, 2)
@@ -980,7 +1042,7 @@
glob2loc_elmnts, glob2loc_nodes_nparts, &
glob2loc_nodes_parts, glob2loc_nodes, part, mat, NGNOD, 2)
- ! writes out absorbing/free-surface boundaries
+ ! writes out absorbing/free-surface boundaries
call write_boundaries_database(IIN_database, ipart, nspec, nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, &
nspec2D_ymax, nspec2D_bottom, nspec2D_top, &
ibelm_xmin, ibelm_xmax, ibelm_ymin, &
@@ -990,6 +1052,10 @@
glob2loc_elmnts, glob2loc_nodes_nparts, &
glob2loc_nodes_parts, glob2loc_nodes, part, NGNOD2D)
+ ! writes out C-PML elements indices, CPML-regions and thickness of C-PML layer
+ call write_cpml_database(IIN_database, ipart, nspec, nspec_cpml, CPML_width, CPML_to_spec, &
+ CPML_regions, CPML_mask_ibool, glob2loc_elmnts, part)
+
! gets number of MPI interfaces
call Write_interfaces_database(IIN_database, tab_interfaces, tab_size_interfaces, ipart, ninterfaces, &
my_ninterface, my_interfaces, my_nb_interfaces, &
@@ -1042,6 +1108,12 @@
enddo
+
+ ! cleanup
+ deallocate(CPML_to_spec,stat=ier); if( ier /= 0 ) stop 'error deallocating array CPML_to_spec'
+ deallocate(CPML_regions,stat=ier); if( ier /= 0 ) stop 'error deallocating array CPML_regions'
+ deallocate(CPML_mask_ibool,stat=ier); if( ier /= 0 ) stop 'error deallocating array CPML_mask_ibool'
+
print*, 'partitions: '
print*, ' num = ',nparts
print*
Modified: seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/part_decompose_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/part_decompose_mesh.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/part_decompose_mesh.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -72,7 +72,7 @@
! local parameters
integer :: i, j, k, l, m, nb_edges
- logical :: is_neighbour
+ logical :: is_neighbour
integer :: num_node, n
integer :: elem_base, elem_target
integer :: connectivity
@@ -657,6 +657,7 @@
integer, intent(in) :: NGNOD2D
integer, intent(in) :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, &
nspec2D_ymax, nspec2D_bottom, nspec2D_top
+
integer, dimension(nspec2D_xmin), intent(in) :: ibelm_xmin
integer, dimension(nspec2D_xmax), intent(in) :: ibelm_xmax
integer, dimension(nspec2D_ymin), intent(in) :: ibelm_ymin
@@ -671,9 +672,9 @@
integer, dimension(NGNOD2D,nspec2D_bottom), intent(in) :: nodes_ibelm_bottom
integer, dimension(NGNOD2D,nspec2D_top), intent(in) :: nodes_ibelm_top
integer, dimension(:), pointer :: glob2loc_elmnts
- integer, dimension(:), pointer :: glob2loc_nodes_nparts
- integer, dimension(:), pointer :: glob2loc_nodes_parts
- integer, dimension(:), pointer :: glob2loc_nodes
+ integer, dimension(:), pointer :: glob2loc_nodes_nparts
+ integer, dimension(:), pointer :: glob2loc_nodes_parts
+ integer, dimension(:), pointer :: glob2loc_nodes
integer, dimension(1:nspec) :: part
! local parameters
@@ -683,6 +684,7 @@
integer :: loc_nspec2D_xmin,loc_nspec2D_xmax,loc_nspec2D_ymin, &
loc_nspec2D_ymax,loc_nspec2D_bottom,loc_nspec2D_top
+
! counts number of elements for boundary at xmin, xmax, ymin, ymax, bottom, top in this partition
loc_nspec2D_xmin = 0
do i=1,nspec2D_xmin
@@ -731,7 +733,7 @@
endif
enddo
write(IIN_database) 6, loc_nspec2D_top
-
+
! outputs element index and element node indices
! note: assumes that element indices in ibelm_* arrays are in the range from 1 to nspec
! (this is assigned by CUBIT, if this changes the following indexing must be changed as well)
@@ -965,12 +967,80 @@
enddo
write(IIN_database) glob2loc_elmnts(ibelm_top(i)-1)+1, (loc_node(inode), inode = 1,NGNOD2D)
endif
-
enddo
end subroutine write_boundaries_database
+ !--------------------------------------------------
+ ! Write C-PML elements indices, CPML-regions and thickness of C-PML layer
+ ! pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+ subroutine write_cpml_database(IIN_database, iproc, nspec, nspec_cpml, CPML_width, CPML_to_spec, &
+ CPML_regions, CPML_mask_ibool, glob2loc_elmnts, part)
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc
+ integer, intent(in) :: nspec
+ integer, intent(in) :: nspec_cpml
+
+ integer, dimension(nspec_cpml), intent(in) :: CPML_to_spec
+ integer, dimension(nspec_cpml), intent(in) :: CPML_regions
+
+ logical, dimension(nspec), intent(in) :: CPML_mask_ibool
+
+ real(kind=CUSTOM_REAL), intent(in) :: CPML_width
+
+ integer, dimension(:), pointer :: glob2loc_elmnts
+
+ integer, dimension(1:nspec), intent(in) :: part
+
+ ! local parameters
+ integer :: i,nspec_cpml_local
+
+ ! writes number of C-PML elements in the global mesh
+ write(IIN_database) nspec_cpml
+
+ if( nspec_cpml > 0 ) then
+ ! writes number of C-PML elements in this partition
+ nspec_cpml_local = 0
+ do i=1,nspec_cpml
+ if( part(CPML_to_spec(i)) == iproc ) then
+ nspec_cpml_local = nspec_cpml_local + 1
+ endif
+ enddo
+
+ write(IIN_database) nspec_cpml_local
+
+ ! writes thickness of C-PML layers for the global mesh
+ write(IIN_database) CPML_width
+
+ ! writes C-PML regions and C-PML spectral elements global indexing
+ do i=1,nspec_cpml
+ ! #id_cpml_regions = 1 : X_surface C-PML
+ ! #id_cpml_regions = 2 : Y_surface C-PML
+ ! #id_cpml_regions = 3 : Z_surface C-PML
+ ! #id_cpml_regions = 4 : XY_edge C-PML
+ ! #id_cpml_regions = 5 : XZ_edge C-PML
+ ! #id_cpml_regions = 6 : YZ_edge C-PML
+ ! #id_cpml_regions = 7 : XYZ_corner C-PML
+ !
+ ! format: #id_cpml_element #id_cpml_regions
+ if( part(CPML_to_spec(i)) == iproc ) then
+ write(IIN_database) glob2loc_elmnts(CPML_to_spec(i)-1)+1, CPML_regions(i)
+ endif
+ enddo
+
+ ! writes mask of C-PML elements for all elements in this partition
+ do i=1,nspec
+ if( part(i) == iproc ) then
+ write(IIN_database) CPML_mask_ibool(i)
+ endif
+ enddo
+ endif
+
+ end subroutine write_cpml_database
+
+
!--------------------------------------------------
! Write elements (their nodes) pertaining to iproc partition in the corresponding Database
!--------------------------------------------------
@@ -996,7 +1066,7 @@
integer, dimension(0:NGNOD-1) :: loc_nodes
if ( num_phase == 1 ) then
- ! counts number of spectral elements in this partition
+ ! counts number of spectral elements in this partition
nspec_local = 0
do i = 0, nspec-1
if ( part(i) == iproc ) then
@@ -1005,7 +1075,7 @@
enddo
else
- ! writes out element corner indices
+ ! writes out element corner indices
do i = 0, nspec-1
if ( part(i) == iproc ) then
@@ -1360,7 +1430,7 @@
endif
! poroelastic element (very expensive)
if (is_poroelastic(num_material(el+1))) elmnts_load(el+1) = POROELASTIC_LOAD
- else
+ else ! JC JC: beware! To modify to take into account the -200? flags used in C-PML boundary conditions
! tomographic materials count as elastic
if(ATTENUATION) then
elmnts_load(el+1) = VISCOELASTIC_LOAD
Modified: seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/program_decompose_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/program_decompose_mesh.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/decompose_mesh/program_decompose_mesh.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -26,7 +26,7 @@
program pre_meshfem3D
- use decompose_mesh,only: nparts,localpath_name, outputpath_name,&
+ use decompose_mesh,only: nparts,localpath_name, outputpath_name, &
read_mesh_files, &
check_valence, &
scotch_partitioning, &
@@ -42,11 +42,14 @@
OCEANS,TOPOGRAPHY,USE_FORCE_POINT_SOURCE, &
ABSORBING_CONDITIONS,SAVE_FORWARD,ABSORB_INSTEAD_OF_FREE_SURFACE, &
ANISOTROPY,SAVE_MESH_FILES,USE_RICKER_TIME_FUNCTION,PRINT_SOURCE_TIME_FUNCTION, &
- LOCAL_PATH,TOMOGRAPHY_PATH,IMODEL
+ LOCAL_PATH,TOMOGRAPHY_PATH,PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE, &
+ PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL
! daniel: ifort
! USE IFPORT,only: getarg
+
implicit none
+
integer :: i
character(len=256) :: arg(3)
@@ -80,7 +83,8 @@
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD, &
NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY, &
USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,IMODEL)
+ USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,PML_CONDITIONS, &
+ PML_INSTEAD_OF_FREE_SURFACE,PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL)
! reads in (CUBIT) mesh files: mesh_file,nodes_coord_file, ...
call read_mesh_files()
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/Makefile.in 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/Makefile.in 2013-01-12 21:24:23 UTC (rev 21224)
@@ -110,6 +110,7 @@
$O/model_tomography.o \
$O/netlib_specfun_erf.shared.o \
$O/param_reader.cc.o \
+ $O/pml_set_local_dampingcoeff.o \
$O/prepare_assemble_MPI.shared.o \
$O/read_topo_bathy_file.shared.o \
$O/read_parameter_file.shared.o \
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/create_mass_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/create_mass_matrices.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/create_mass_matrices.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -24,11 +24,12 @@
!
!=====================================================================
- subroutine create_mass_matrices(nglob,nspec,ibool)
+ subroutine create_mass_matrices(nglob,nspec,ibool,PML_CONDITIONS)
! returns precomputed mass matrix in rmass array
use create_regions_mesh_ext_par
+
implicit none
! number of spectral elements in each block
@@ -38,6 +39,9 @@
! arrays with the mesh global indices
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+! C-PML flag
+ logical :: PML_CONDITIONS
+
! local parameters
double precision :: weight
real(kind=CUSTOM_REAL) :: jacobianl
@@ -46,72 +50,80 @@
! elastic domains
if( ELASTIC_SIMULATION ) then
- ! allocates memory
- allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate rmass'
- rmass(:) = 0._CUSTOM_REAL
+ ! allocates memory
+ allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error allocating array rmass'
+ rmass(:) = 0._CUSTOM_REAL
- ! elastic mass matrix
- do ispec=1,nspec
- if( ispec_is_elastic(ispec) ) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
+ ! returns elastic mass matrix
+ if( PML_CONDITIONS ) then
+ call create_mass_matrices_pml(nspec,ibool)
+ else
+ do ispec=1,nspec
+ if( ispec_is_elastic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
- weight = wxgll(i)*wygll(j)*wzgll(k)
- jacobianl = jacobianstore(i,j,k,ispec)
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglob) = rmass(iglob) + &
- sngl( dble(jacobianl) * weight * dble(rhostore(i,j,k,ispec)) )
- else
- rmass(iglob) = rmass(iglob) + &
- jacobianl * weight * rhostore(i,j,k,ispec)
- endif
- enddo
- enddo
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(rhostore(i,j,k,ispec)) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * rhostore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+ endif
enddo
- endif
- enddo ! nspec
+ endif
endif
! acoustic domains
if( ACOUSTIC_SIMULATION) then
- ! allocates memory
- allocate(rmass_acoustic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate rmass_acoustic'
- rmass_acoustic(:) = 0._CUSTOM_REAL
+ ! allocates memory
+ allocate(rmass_acoustic(nglob),stat=ier); if(ier /= 0) stop 'error allocating array rmass_acoustic'
+ rmass_acoustic(:) = 0._CUSTOM_REAL
- ! acoustic mass matrix
- do ispec=1,nspec
- if( ispec_is_acoustic(ispec) ) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
-
- weight = wxgll(i)*wygll(j)*wzgll(k)
- jacobianl = jacobianstore(i,j,k,ispec)
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass_acoustic(iglob) = rmass_acoustic(iglob) + &
- sngl( dble(jacobianl) * weight / dble(kappastore(i,j,k,ispec)) )
- else
- rmass_acoustic(iglob) = rmass_acoustic(iglob) + &
- jacobianl * weight / kappastore(i,j,k,ispec)
- endif
- enddo
- enddo
+ ! returns acoustic mass matrix
+ if( PML_CONDITIONS ) then
+ call create_mass_matrices_pml(nspec,ibool)
+ else
+ do ispec=1,nspec
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass_acoustic(iglob) = rmass_acoustic(iglob) + &
+ sngl( dble(jacobianl) * weight / dble(kappastore(i,j,k,ispec)) )
+ else
+ rmass_acoustic(iglob) = rmass_acoustic(iglob) + &
+ jacobianl * weight / kappastore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+ endif
enddo
- endif
- enddo ! nspec
+ endif
endif
! poroelastic domains
if( POROELASTIC_SIMULATION) then
! allocates memory
- allocate(rmass_solid_poroelastic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(rmass_fluid_poroelastic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(rmass_solid_poroelastic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate rmass_solid_poroelastic'
+ allocate(rmass_fluid_poroelastic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate rmass_fluid_poroelastic'
rmass_solid_poroelastic(:) = 0._CUSTOM_REAL
rmass_fluid_poroelastic(:) = 0._CUSTOM_REAL
@@ -156,14 +168,12 @@
enddo ! nspec
endif
- ! extra C*deltat/2 contribution to the mass matrices on Stacey edges
- ! for absorbing condition
+ ! Stacey absorbing conditions (adds C*deltat/2 contribution to the mass matrices on Stacey edges)
call create_mass_matrices_Stacey(nglob,nspec,ibool)
- ! creates ocean load mass matrix
+ ! ocean load mass matrix
call create_mass_matrices_ocean_load(nglob,nspec,ibool)
-
end subroutine create_mass_matrices
!
@@ -174,7 +184,7 @@
! returns precomputed mass matrix in rmass array
- use generate_databases_par,only: &
+ use generate_databases_par, only: &
OCEANS,TOPOGRAPHY,UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
NX_TOPO,NY_TOPO,itopo_bathy,myrank
@@ -286,27 +296,24 @@
end subroutine create_mass_matrices_ocean_load
-
!
!-------------------------------------------------------------------------------------------------
!
subroutine create_mass_matrices_Stacey(nglob,nspec,ibool)
-! in the case of stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
+! in the case of Stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
! on Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
- use generate_databases_par,only: &
- DT
-
+ use generate_databases_par, only: DT
use create_regions_mesh_ext_par
implicit none
integer :: nglob
integer :: nspec
- integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
! local parameters
real(kind=CUSTOM_REAL) :: jacobianw
@@ -347,7 +354,7 @@
deltatover2 = 0.5d0*deltat
endif
- ! adds contributions to mass matrix to stabilize stacey conditions
+ ! adds contributions to mass matrix to stabilize Stacey conditions
do iface=1,num_abs_boundary_faces
ispec = abs_boundary_ispec(iface)
@@ -412,3 +419,304 @@
end subroutine create_mass_matrices_Stacey
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine create_mass_matrices_pml(nspec,ibool)
+
+ use generate_databases_par, only: CPML_mask_ibool,CPML_regions,d_store_x,d_store_y,d_store_z, &
+ K_store_x,K_store_y,K_store_z,nspec_cpml,CPML_to_spec,DT
+
+ use create_regions_mesh_ext_par
+
+ implicit none
+
+ integer, intent(in) :: nspec
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec), intent(in) :: ibool
+
+ ! local parameters
+ double precision :: weight
+ real(kind=CUSTOM_REAL) :: jacobianl,deltat,mat_coef
+ integer :: ispec,iglob,i,j,k,ispec_CPML
+
+ ! use the non-dimensional time step to make the mass matrix correction
+ if(CUSTOM_REAL == SIZE_REAL) then
+ deltat = sngl(DT)
+ else
+ deltat = DT
+ endif
+
+ ! loops over physical mesh elements
+ do ispec=1,nspec
+ if( .not. CPML_mask_ibool(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! defines the material coefficient associated to the domain
+ if( ispec_is_elastic(ispec) ) then
+ mat_coef = rhostore(i,j,k,ispec)
+ elseif( ispec_is_acoustic(ispec) ) then
+ mat_coef = 1.d0 / kappastore(i,j,k,ispec)
+ endif
+
+ iglob = ibool(i,j,k,ispec)
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(mat_coef) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * mat_coef
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+ ! loops over C-PML elements
+ do ispec_CPML=1,nspec_cpml
+ ispec = CPML_to_spec(ispec_CPML)
+
+ if( CPML_mask_ibool(ispec) ) then
+ ! X_surface C-PML
+ if( CPML_regions(ispec_CPML) == 1 ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! defines the material coefficient associated to the domain
+ if( ispec_is_elastic(ispec) ) then
+ mat_coef = rhostore(i,j,k,ispec)
+ elseif( ispec_is_acoustic(ispec) ) then
+ mat_coef = 1.d0 / kappastore(i,j,k,ispec)
+ endif
+
+ iglob = ibool(i,j,k,ispec)
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(mat_coef) * &
+ (dble(K_store_x(i,j,k,ispec_CPML)) + dble(d_store_x(i,j,k,ispec_CPML)) * deltat / 2.d0) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * mat_coef * &
+ (K_store_x(i,j,k,ispec_CPML) + d_store_x(i,j,k,ispec_CPML) * deltat / 2.d0)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! Y_surface C-PML
+ elseif( CPML_regions(ispec_CPML) == 2 ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! defines the material coefficient associated to the domain
+ if( ispec_is_elastic(ispec) ) then
+ mat_coef = rhostore(i,j,k,ispec)
+ elseif( ispec_is_acoustic(ispec) ) then
+ mat_coef = 1.d0 / kappastore(i,j,k,ispec)
+ endif
+
+ iglob = ibool(i,j,k,ispec)
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(mat_coef) * &
+ (dble(K_store_y(i,j,k,ispec_CPML)) + dble(d_store_y(i,j,k,ispec_CPML)) * deltat / 2.d0) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * mat_coef * &
+ (K_store_y(i,j,k,ispec_CPML) + d_store_y(i,j,k,ispec_CPML) * deltat / 2.d0)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! Z_surface C-PML
+ elseif( CPML_regions(ispec_CPML) == 3 ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! defines the material coefficient associated to the domain
+ if( ispec_is_elastic(ispec) ) then
+ mat_coef = rhostore(i,j,k,ispec)
+ elseif( ispec_is_acoustic(ispec) ) then
+ mat_coef = 1.d0 / kappastore(i,j,k,ispec)
+ endif
+
+ iglob = ibool(i,j,k,ispec)
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(mat_coef) * &
+ (dble(K_store_z(i,j,k,ispec_CPML)) + dble(d_store_z(i,j,k,ispec_CPML)) * deltat / 2.d0) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * mat_coef * &
+ (K_store_z(i,j,k,ispec_CPML) + d_store_z(i,j,k,ispec_CPML) * deltat / 2.d0)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! XY_edge C-PML
+ elseif( CPML_regions(ispec_CPML) == 4 ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! defines the material coefficient associated to the domain
+ if( ispec_is_elastic(ispec) ) then
+ mat_coef = rhostore(i,j,k,ispec)
+ elseif( ispec_is_acoustic(ispec) ) then
+ mat_coef = 1.d0 / kappastore(i,j,k,ispec)
+ endif
+
+ iglob = ibool(i,j,k,ispec)
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(mat_coef) * &
+ (dble(K_store_x(i,j,k,ispec_CPML)) * dble(K_store_y(i,j,k,ispec_CPML)) + &
+ (dble(d_store_x(i,j,k,ispec_CPML)) * dble(K_store_y(i,j,k,ispec_CPML)) + &
+ dble(d_store_y(i,j,k,ispec_CPML)) * dble(K_store_x(i,j,k,ispec_CPML))) * deltat / 2.d0) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * mat_coef * &
+ (K_store_x(i,j,k,ispec_CPML) * K_store_y(i,j,k,ispec_CPML) + &
+ (d_store_x(i,j,k,ispec_CPML) * K_store_y(i,j,k,ispec_CPML) + &
+ d_store_y(i,j,k,ispec_CPML) * K_store_x(i,j,k,ispec_CPML)) * deltat / 2.d0)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! XZ_edge C-PML
+ elseif( CPML_regions(ispec_CPML) == 5 ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! defines the material coefficient associated to the domain
+ if( ispec_is_elastic(ispec) ) then
+ mat_coef = rhostore(i,j,k,ispec)
+ elseif( ispec_is_acoustic(ispec) ) then
+ mat_coef = 1.d0 / kappastore(i,j,k,ispec)
+ endif
+
+ iglob = ibool(i,j,k,ispec)
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(mat_coef) * &
+ (dble(K_store_x(i,j,k,ispec_CPML)) * dble(K_store_z(i,j,k,ispec_CPML)) + &
+ (dble(d_store_x(i,j,k,ispec_CPML)) * dble(K_store_z(i,j,k,ispec_CPML)) + &
+ dble(d_store_z(i,j,k,ispec_CPML)) * dble(K_store_x(i,j,k,ispec_CPML))) * deltat / 2.d0) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * mat_coef * &
+ (K_store_x(i,j,k,ispec_CPML) * K_store_z(i,j,k,ispec_CPML) + &
+ (d_store_x(i,j,k,ispec_CPML) * K_store_z(i,j,k,ispec_CPML) + &
+ d_store_z(i,j,k,ispec_CPML) * K_store_x(i,j,k,ispec_CPML)) * deltat / 2.d0)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! YZ_edge C-PML
+ elseif( CPML_regions(ispec_CPML) == 6 ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! defines the material coefficient associated to the domain
+ if( ispec_is_elastic(ispec) ) then
+ mat_coef = rhostore(i,j,k,ispec)
+ elseif( ispec_is_acoustic(ispec) ) then
+ mat_coef = 1.d0 / kappastore(i,j,k,ispec)
+ endif
+
+ iglob = ibool(i,j,k,ispec)
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(mat_coef) * &
+ (dble(K_store_y(i,j,k,ispec_CPML)) * dble(K_store_z(i,j,k,ispec_CPML)) + &
+ (dble(d_store_y(i,j,k,ispec_CPML)) * dble(K_store_z(i,j,k,ispec_CPML)) + &
+ dble(d_store_z(i,j,k,ispec_CPML)) * dble(K_store_y(i,j,k,ispec_CPML))) * deltat / 2.d0) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * mat_coef * &
+ (K_store_y(i,j,k,ispec_CPML) * K_store_z(i,j,k,ispec_CPML) + &
+ (d_store_y(i,j,k,ispec_CPML) * K_store_z(i,j,k,ispec_CPML) + &
+ d_store_z(i,j,k,ispec_CPML) * K_store_y(i,j,k,ispec_CPML)) * deltat / 2.d0)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! XYZ_corner C-PML
+ elseif( CPML_regions(ispec_CPML) == 7 ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! defines the material coefficient associated to the domain
+ if( ispec_is_elastic(ispec) ) then
+ mat_coef = rhostore(i,j,k,ispec)
+ elseif( ispec_is_acoustic(ispec) ) then
+ mat_coef = 1.d0 / kappastore(i,j,k,ispec)
+ endif
+
+ iglob = ibool(i,j,k,ispec)
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(mat_coef) * &
+ (dble(K_store_x(i,j,k,ispec_CPML)) * dble(K_store_y(i,j,k,ispec_CPML)) * &
+ dble(K_store_z(i,j,k,ispec_CPML)) + (dble(d_store_x(i,j,k,ispec_CPML)) * &
+ dble(K_store_y(i,j,k,ispec_CPML)) * dble(K_store_z(i,j,k,ispec_CPML)) + &
+ dble(d_store_y(i,j,k,ispec_CPML)) * dble(K_store_x(i,j,k,ispec_CPML)) * &
+ dble(K_store_z(i,j,k,ispec_CPML)) + dble(d_store_z(i,j,k,ispec_CPML)) * &
+ dble(K_store_y(i,j,k,ispec_CPML)) * dble(K_store_z(i,j,k,ispec_CPML))) * &
+ deltat / 2.d0) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * mat_coef * &
+ (K_store_x(i,j,k,ispec_CPML) * K_store_y(i,j,k,ispec_CPML) * K_store_z(i,j,k,ispec_CPML) + &
+ (d_store_x(i,j,k,ispec_CPML) * K_store_y(i,j,k,ispec_CPML) * K_store_z(i,j,k,ispec_CPML) + &
+ d_store_y(i,j,k,ispec_CPML) * K_store_x(i,j,k,ispec_CPML) * K_store_z(i,j,k,ispec_CPML) + &
+ d_store_z(i,j,k,ispec_CPML) * K_store_y(i,j,k,ispec_CPML) * K_store_z(i,j,k,ispec_CPML)) * &
+ deltat / 2.d0)
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ endif
+ enddo ! do ispec_CPML=1,nspec_cpml
+
+ end subroutine create_mass_matrices_pml
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/create_regions_mesh.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/create_regions_mesh.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -45,7 +45,7 @@
ibelm_xmin, ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top, &
nodes_ibelm_xmin,nodes_ibelm_xmax,nodes_ibelm_ymin,nodes_ibelm_ymax,&
nodes_ibelm_bottom,nodes_ibelm_top, &
- SAVE_MESH_FILES, &
+ SAVE_MESH_FILES,PML_CONDITIONS, &
ANISOTROPY,NPROC,OCEANS,OLSEN_ATTENUATION_RATIO, &
ATTENUATION,USE_OLSEN_ATTENUATION, &
nspec2D_moho_ext,ibelm_moho,nodes_ibelm_moho
@@ -214,12 +214,21 @@
call sync_all()
call get_model_binaries(myrank,nspec,LOCAL_PATH)
+! calculates damping profiles and auxiliary coefficients on all C-PML points
+ call sync_all()
+ if( PML_CONDITIONS ) then
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...creating C-PML damping profiles '
+ endif
+ call pml_set_local_dampingcoeff(myrank,xstore_dummy,ystore_dummy,zstore_dummy)
+ endif
+
! creates mass matrix
call sync_all()
if( myrank == 0) then
write(IMAIN,*) ' ...creating mass matrix '
endif
- call create_mass_matrices(nglob_dummy,nspec,ibool)
+ call create_mass_matrices(nglob_dummy,nspec,ibool,PML_CONDITIONS)
! saves the binary mesh files
call sync_all()
@@ -279,7 +288,7 @@
deallocate(kappastore,mustore,rho_vp,rho_vs)
deallocate(rho_vpI,rho_vpII,rho_vsI)
deallocate(rhoarraystore,kappaarraystore,etastore,phistore,tortstore,permstore)
-
+
if( .not. SAVE_MOHO_MESH ) then
deallocate(xstore_dummy,ystore_dummy,zstore_dummy)
endif
@@ -308,6 +317,7 @@
use generate_databases_par, only: ABSORB_INSTEAD_OF_FREE_SURFACE,NGNOD,NGNOD2D
use create_regions_mesh_ext_par
+
implicit none
integer :: nspec,myrank
@@ -564,6 +574,7 @@
! creates global indexing array ibool
use create_regions_mesh_ext_par
+
implicit none
! number of spectral elements in each block
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/generate_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/generate_databases.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/generate_databases.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -189,6 +189,7 @@
subroutine generate_databases
use generate_databases_par
+
implicit none
! sizeprocs returns number of processes started (should be equal to NPROC).
@@ -263,7 +264,8 @@
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD, &
NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY, &
USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,IMODEL)
+ USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,PML_CONDITIONS, &
+ PML_INSTEAD_OF_FREE_SURFACE,PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL)
! check that the code is running with the requested nb of processes
if(sizeprocs /= NPROC) then
@@ -280,7 +282,7 @@
! there would be a problem with absorbing boundaries for different NGLLX,NGLLY,NGLLZ values
! just to be sure for now..
- if( ABSORBING_CONDITIONS ) then
+ if(ABSORBING_CONDITIONS) then
if( NGLLX /= NGLLY .and. NGLLY /= NGLLZ ) &
call exit_MPI(myrank,'must have NGLLX = NGLLY = NGLLZ for external meshes')
endif
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/generate_databases_par.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/generate_databases_par.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/generate_databases_par.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -57,19 +57,16 @@
! parameters read from parameter file
integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,SIMULATION_TYPE
integer :: NSOURCES,NGNOD,NGNOD2D,MOVIE_TYPE
+ integer :: NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO,NTSTEP_BETWEEN_READ_ADJSRC
- double precision :: DT,HDUR_MOVIE,OLSEN_ATTENUATION_RATIO
+ double precision :: DT,HDUR_MOVIE,OLSEN_ATTENUATION_RATIO,f0_FOR_PML,PML_WIDTH_MIN,PML_WIDTH_MAX
- logical :: ATTENUATION,USE_OLSEN_ATTENUATION, &
- OCEANS,TOPOGRAPHY,SAVE_FORWARD,USE_FORCE_POINT_SOURCE
- logical :: ANISOTROPY,ABSORBING_CONDITIONS,SAVE_MESH_FILES, &
- ABSORB_INSTEAD_OF_FREE_SURFACE
+ logical :: ATTENUATION,USE_OLSEN_ATTENUATION,OCEANS,TOPOGRAPHY,SAVE_FORWARD,USE_FORCE_POINT_SOURCE
+ logical :: ANISOTROPY,ABSORBING_CONDITIONS,SAVE_MESH_FILES,ABSORB_INSTEAD_OF_FREE_SURFACE
+ logical :: PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE
logical :: USE_RICKER_TIME_FUNCTION,PRINT_SOURCE_TIME_FUNCTION
+ logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT,USE_HIGHRES_FOR_MOVIES
- logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- USE_HIGHRES_FOR_MOVIES
- integer :: NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO,NTSTEP_BETWEEN_READ_ADJSRC
-
character(len=256) OUTPUT_FILES,LOCAL_PATH,TOMOGRAPHY_PATH
! parameters deduced from parameters read from file
@@ -114,16 +111,43 @@
! boundaries and materials
double precision, dimension(:,:), allocatable :: materials_ext_mesh
- integer :: ispec2D, boundary_number
- integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, nspec2D_bottom_ext, nspec2D_top_ext
+ integer :: ispec2D, boundary_number
+ integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, nspec2D_bottom_ext, nspec2D_top_ext
- integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax, &
+ integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax, &
ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top
- integer, dimension(:,:), allocatable :: nodes_ibelm_xmin,nodes_ibelm_xmax, &
+ integer, dimension(:,:), allocatable :: nodes_ibelm_xmin,nodes_ibelm_xmax, &
nodes_ibelm_ymin, nodes_ibelm_ymax, nodes_ibelm_bottom, nodes_ibelm_top
character (len=30), dimension(:,:), allocatable :: undef_mat_prop
+! C-PML absorbing boundary conditions
+
+ ! local number of C-PML spectral elements
+ integer :: nspec_cpml
+
+ ! global number of C-PML spectral elements
+ integer :: nspec_cpml_tot
+
+ ! C-PML spectral elements global indexing
+ integer, dimension(:), allocatable :: CPML_to_spec
+
+ ! C-PML regions
+ integer, dimension(:), allocatable :: CPML_regions
+
+ ! mask of C-PML elements for the global mesh
+ logical, dimension(:), allocatable :: CPML_mask_ibool
+
+ ! thickness of C-PML layers
+ real(kind=CUSTOM_REAL) :: CPML_width,CPML_width_x,CPML_width_y,CPML_width_z
+
+ ! C-PML damping profile arrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: d_store_x, d_store_y, d_store_z
+
+ ! auxiliary parameters arrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: K_store_x, K_store_y, K_store_z
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: alpha_store
+
! moho (optional)
integer :: nspec2D_moho_ext
integer, dimension(:), allocatable :: ibelm_moho
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/get_absorbing_boundary.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/get_absorbing_boundary.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/get_absorbing_boundary.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -34,8 +34,9 @@
! determines absorbing boundaries/free-surface, 2D jacobians, face normals for Stacey conditions
- use generate_databases_par, only: ABSORB_INSTEAD_OF_FREE_SURFACE, NGNOD2D
+ use generate_databases_par, only: ABSORB_INSTEAD_OF_FREE_SURFACE, PML_INSTEAD_OF_FREE_SURFACE, NGNOD2D
use create_regions_mesh_ext_par
+
implicit none
! number of spectral elements in each block
@@ -76,7 +77,7 @@
! face corner locations
real(kind=CUSTOM_REAL),dimension(NGNOD2D_FOUR_CORNERS) :: xcoord,ycoord,zcoord
- integer :: ispec,ispec2D,icorner,iabs,iface,igll,i,j,igllfree,ifree
+ integer :: ispec,ispec2D,icorner,itop,iabs,iface,igll,i,j,igllfree,ifree
! abs face counter
iabs = 0
@@ -397,6 +398,7 @@
jacobian2Dw_face(:,:) = 0.0_CUSTOM_REAL
! free surface face counter
ifree = 0
+
do ispec2D = 1, NSPEC2D_TOP
! sets element
ispec = ibelm_top(ispec2D)
@@ -454,7 +456,7 @@
free_surface_jacobian2Dw(igllfree,ifree) = jacobian2Dw_face(i,j)
free_surface_normal(:,igllfree,ifree) = normal_face(:,i,j)
enddo
- enddo
+ enddo
else
@@ -502,13 +504,19 @@
stop 'error number of absorbing faces'
endif
+ call sum_all_i(num_free_surface_faces,itop)
call sum_all_i(num_abs_boundary_faces,iabs)
if( myrank == 0 ) then
write(IMAIN,*) ' absorbing boundary:'
+ write(IMAIN,*) ' total number of free faces = ',itop
write(IMAIN,*) ' total number of faces = ',iabs
if( ABSORB_INSTEAD_OF_FREE_SURFACE ) then
write(IMAIN,*) ' absorbing boundary includes free surface'
endif
+ if( PML_INSTEAD_OF_FREE_SURFACE .and. itop /= 0 ) then
+ print*,'please check Par_file/free_surface_file and recompile solver'
+ stop 'error: number of free surface faces should be zero when PML_INSTEAD_OF_FREE_SURFACE is set to .true.'
+ endif
endif
end subroutine get_absorbing_boundary
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/get_model.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/get_model.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/get_model.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -88,7 +88,6 @@
! material properties on all GLL points: taken from material values defined for
! each spectral element in input mesh
do ispec = 1, nspec
-
! loops over all gll points in element
do k = 1, NGLLZ
do j = 1, NGLLY
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/memory_eval.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/memory_eval.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/memory_eval.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -32,6 +32,7 @@
subroutine memory_eval(NSPEC_AB,NGLOB_AB,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh,&
OCEANS,memory_size)
+ use generate_databases_par, only: PML_CONDITIONS,nspec_cpml
use create_regions_mesh_ext_par,only: NSPEC_ANISO,ispec_is_acoustic,ispec_is_elastic
implicit none
@@ -81,6 +82,57 @@
memory_size = memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_AB*dble(CUSTOM_REAL)
endif
+ ! see: read_mesh_databases.f90 and pml_allocate_arrays.f90
+ ! C-PML arrays
+ if( PML_CONDITIONS ) then
+ ! CPML_regions,CPML_to_spec,CPML_type
+ memory_size = memory_size + 3.d0*nspec_cpml*dble(SIZE_INTEGER)
+
+ ! spec_to_CPML
+ memory_size = memory_size + NSPEC_AB*dble(SIZE_INTEGER)
+
+ ! CPML_mask_ibool
+ memory_size = memory_size + NSPEC_AB*dble(SIZE_LOGICAL)
+
+ ! d_store_x,d_store_y,d_store_z,d_store_x,d_store_y,d_store_z,alpha_store
+ memory_size = memory_size + 7.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*nspec_cpml*dble(CUSTOM_REAL)
+
+ ! PML_dux_dxl,PML_dux_dyl,PML_dux_dzl,
+ ! PML_duy_dxl,PML_duy_dyl,PML_duy_dzl,
+ ! PML_duz_dxl,PML_duz_dyl,PML_duz_dzl,
+ ! PML_dux_dxl_new,PML_dux_dyl_new,PML_dux_dzl_new,
+ ! PML_duy_dxl_new,PML_duy_dyl_new,PML_duy_dzl_new,
+ ! PML_duz_dxl_new,PML_duz_dyl_new,PML_duz_dzl_new
+ memory_size = memory_size + 18.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*nspec_cpml*dble(CUSTOM_REAL)
+
+ ! PML_dpotential_dxl,PML_dpotential_dyl,PML_dpotential_dzl
+ ! PML_dpotential_dxl_new,PML_dpotential_dyl_new,PML_dpotential_dzl_new
+ memory_size = memory_size + 6.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*nspec_cpml*dble(CUSTOM_REAL)
+
+ ! rmemory_dux_dxl_x,rmemory_dux_dyl_x,rmemory_dux_dzl_x,rmemory_duy_dxl_x,
+ ! rmemory_duy_dyl_x,rmemory_duz_dxl_x,rmemory_duz_dzl_x,
+ ! rmemory_dux_dxl_y,rmemory_dux_dyl_y,rmemory_duy_dxl_y,rmemory_duy_dyl_y,
+ ! rmemory_duy_dzl_y,rmemory_duz_dyl_y,rmemory_duz_dzl_y,
+ ! rmemory_dux_dxl_z,rmemory_dux_dzl_z,rmemory_duy_dyl_z,rmemory_duy_dzl_z,
+ ! rmemory_duz_dxl_z,rmemory_duz_dyl_z,rmemory_duz_dzl_z
+ memory_size = memory_size + 21.d0*3.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*nspec_cpml*dble(CUSTOM_REAL)
+
+ ! rmemory_dpotential_dxl,rmemory_dpotential_dyl,rmemory_dpotential_dzl
+ memory_size = memory_size + 3.d0*3.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*nspec_cpml*dble(CUSTOM_REAL)
+
+ ! rmemory_displ_elastic
+ memory_size = memory_size + 3.d0*dble(NDIM)*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*nspec_cpml*dble(CUSTOM_REAL)
+
+ ! rmemory_potential_acoustic
+ memory_size = memory_size + 3.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*nspec_cpml*dble(CUSTOM_REAL)
+
+ ! accel_elastic_CPML
+ memory_size = memory_size + dble(NDIM)*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*nspec_cpml*dble(CUSTOM_REAL)
+
+ ! second derivative of the potential
+ memory_size = memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*nspec_cpml*dble(CUSTOM_REAL)
+ endif
+
! elastic arrays
call any_all_l( ANY(ispec_is_elastic), ELASTIC_SIMULATION )
if( ELASTIC_SIMULATION ) then
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/model_default.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/model_default.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/model_default.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -40,7 +40,9 @@
! takes model values specified by mesh properties
+ use generate_databases_par, only: myrank
use create_regions_mesh_ext_par
+
implicit none
integer, intent(in) :: nmat_ext_mesh
@@ -63,7 +65,7 @@
! local parameters
integer :: iflag,flag_below,flag_above
- integer :: iundef
+ integer :: iundef,num_mat
! check if the material is known or unknown
if( imaterial_id > 0 ) then
@@ -123,6 +125,18 @@
end select
+ else if ( imaterial_id <= -2001 .and. imaterial_id >= -2007 ) then
+
+ do iundef = 1,nundefMat_ext_mesh
+ read(undef_mat_prop(1,iundef),*) num_mat
+ if( num_mat == imaterial_id ) then
+ read(undef_mat_prop(2,iundef),*) rho
+ read(undef_mat_prop(3,iundef),*) vp
+ read(undef_mat_prop(4,iundef),*) vs
+ read(undef_mat_prop(6,iundef),*) idomain_id
+ endif
+ enddo
+
else if ( imaterial_def == 1 ) then
stop 'material: interface not implemented yet'
Added: seismo/3D/SPECFEM3D/trunk/src/generate_databases/pml_set_local_dampingcoeff.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/pml_set_local_dampingcoeff.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/pml_set_local_dampingcoeff.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -0,0 +1,1311 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 2 . 1
+! ---------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA and CNRS / INRIA / University of Pau
+! (c) Princeton University / California Institute of Technology and CNRS / INRIA / University of Pau
+! July 2012
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+subroutine pml_set_local_dampingcoeff(myrank,xstore,ystore,zstore)
+
+ ! calculates damping profiles and auxiliary coefficients on C-PML points
+
+ use generate_databases_par, only: ibool,NGLOB_AB,d_store_x,d_store_y,d_store_z, &
+ K_store_x,K_store_y,K_store_z,alpha_store,CPML_to_spec, &
+ CPML_width,CPML_width_x,CPML_width_y,CPML_width_z,NPOWER,K_MAX_PML, &
+ CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,nspec_cpml,PML_INSTEAD_OF_FREE_SURFACE, &
+ IMAIN,FOUR_THIRDS,CPML_REGIONS,f0_FOR_PML,PI
+
+ use create_regions_mesh_ext_par, only: kappastore,mustore,rhostore,rho_vp,ispec_is_acoustic,ispec_is_elastic
+
+ implicit none
+
+ integer, intent(in) :: myrank
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB), intent(in) :: xstore,ystore,zstore
+
+ ! local parameters
+ integer :: i,j,k,ispec,iglob,ispec_CPML,ier
+
+ ! JC JC: Remove the parameter definition here and make the calculation of ALPHA_MAX_PML automatic
+ ! by recovering the value of hdur in FORCESOLUTION/CMTSOLUTION
+ real(kind=CUSTOM_REAL) :: ALPHA_MAX_PML
+
+ real(kind=CUSTOM_REAL) :: pml_damping_profile_l,dist,vp
+ real(kind=CUSTOM_REAL) :: xoriginleft,xoriginright,yoriginfront,yoriginback,zoriginbottom,zorigintop
+ real(kind=CUSTOM_REAL) :: abscissa_in_PML_x,abscissa_in_PML_y,abscissa_in_PML_z
+ real(kind=CUSTOM_REAL) :: d_x,d_y,d_z,k_x,k_y,k_z,alpha_x,alpha_y,alpha_z
+
+ ! stores damping profiles
+ allocate(d_store_x(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array d_store_x'
+ allocate(d_store_y(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array d_store_y'
+ allocate(d_store_z(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array d_store_z'
+
+ ! stores auxiliary coefficients
+ allocate(K_store_x(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array K_store_x'
+ allocate(K_store_y(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array K_store_y'
+ allocate(K_store_z(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array K_store_z'
+ allocate(alpha_store(NGLLX,NGLLY,NGLLZ,nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array alpha_store'
+
+ d_store_x = 0._CUSTOM_REAL
+ d_store_y = 0._CUSTOM_REAL
+ d_store_z = 0._CUSTOM_REAL
+
+ K_store_x = 0._CUSTOM_REAL
+ K_store_y = 0._CUSTOM_REAL
+ K_store_z = 0._CUSTOM_REAL
+
+ alpha_store = 0._CUSTOM_REAL
+
+ ALPHA_MAX_PML = PI*f0_FOR_PML ! ELASTIC from Festa and Vilotte (2005)
+ ALPHA_MAX_PML = PI*f0_FOR_PML*2.0 ! ACOUSTIC from Festa and Vilotte (2005)
+
+ CPML_width_x = CPML_width
+ CPML_width_y = CPML_width
+ CPML_width_z = CPML_width
+
+ ! determines equations of C-PML/mesh interface planes
+ xoriginleft = minval(xstore(:)) + CPML_width_x
+ xoriginright = maxval(xstore(:)) - CPML_width_x
+ yoriginback = minval(ystore(:)) + CPML_width_y
+ yoriginfront = maxval(ystore(:)) - CPML_width_y
+ zoriginbottom = minval(zstore(:)) + CPML_width_z
+
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ zorigintop = maxval(zstore(:)) - CPML_width_z
+ endif
+
+ ! user output
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Boundary values of X-/Y-/Z-regions'
+ write(IMAIN,*) minval(xstore(:)), maxval(xstore(:))
+ write(IMAIN,*) minval(ystore(:)), maxval(ystore(:))
+ write(IMAIN,*) minval(zstore(:)), maxval(zstore(:))
+ write(IMAIN,*)
+ write(IMAIN,*) 'Origins of right/left X-surface C-PML',xoriginright,xoriginleft
+ write(IMAIN,*) 'Origins of front/back Y-surface C-PML',yoriginfront,yoriginback
+ write(IMAIN,*) 'Origin of bottom Z-surface C-PML',zoriginbottom
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ write(IMAIN,*) 'Origin of top Z-surface C-PML',zorigintop
+ end if
+ write(IMAIN,*)
+ write(IMAIN,*) 'CPML_width_x: ',CPML_width_x
+ write(IMAIN,*) 'CPML_width_y: ',CPML_width_y
+ write(IMAIN,*) 'CPML_width_z: ',CPML_width_z
+ write(IMAIN,*)
+ endif
+ call sync_all()
+
+ ! loops over all C-PML elements
+ do ispec_CPML=1,nspec_cpml
+ ispec = CPML_to_spec(ispec_CPML)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! calculates P-velocity
+ if( ispec_is_acoustic(ispec) ) then
+ vp = sqrt( kappastore(i,j,k,ispec)/rhostore(i,j,k,ispec) )
+ else if( ispec_is_elastic(ispec) ) then
+ vp = (FOUR_THIRDS * mustore(i,j,k,ispec) + kappastore(i,j,k,ispec)) / rho_vp(i,j,k,ispec)
+ else
+ print*,'element index',ispec
+ print*,'C-PML element index ',ispec_CPML
+ call exit_mpi(myrank,'C-PML error: element has an unvalid P-velocity')
+ endif
+
+ iglob = ibool(i,j,k,ispec)
+
+ if( CPML_regions(ispec_CPML) == 1 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- X-surface C-PML ---------------------------------
+ !------------------------------------------------------------------------------
+
+ if( xstore(iglob) .gt. 0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xstore(iglob) - xoriginright
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ else
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xoriginleft - xstore(iglob)
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML grid point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ endif
+
+ !! DK DK define an alias for y and z variable names (which are the same)
+ ! stores damping profiles and auxiliary coefficients at the C-PML element's GLL points
+ K_store_x(i,j,k,ispec_CPML) = K_x
+ d_store_x(i,j,k,ispec_CPML) = d_x
+
+ K_store_y(i,j,k,ispec_CPML) = 1.d0
+ d_store_y(i,j,k,ispec_CPML) = 0.d0
+
+ K_store_z(i,j,k,ispec_CPML) = 1.d0
+ d_store_z(i,j,k,ispec_CPML) = 0.d0
+
+ alpha_store(i,j,k,ispec_CPML) = alpha_x
+
+ elseif( CPML_regions(ispec_CPML) == 2 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- Y-surface C-PML ---------------------------------
+ !------------------------------------------------------------------------------
+
+ if( ystore(iglob) .gt. 0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = ystore(iglob) - yoriginfront
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ else
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = yoriginback - ystore(iglob)
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ endif
+
+ !! DK DK define an alias for y and z variable names (which are the same)
+ ! stores damping profiles and auxiliary coefficients at the C-PML element's GLL points
+ K_store_x(i,j,k,ispec_CPML) = 1.d0
+ d_store_x(i,j,k,ispec_CPML) = 0.d0
+
+ K_store_y(i,j,k,ispec_CPML) = K_y
+ d_store_y(i,j,k,ispec_CPML) = d_y
+
+ K_store_z(i,j,k,ispec_CPML) = 1.d0
+ d_store_z(i,j,k,ispec_CPML) = 0.d0
+
+ alpha_store(i,j,k,ispec_CPML) = alpha_y
+
+ elseif( CPML_regions(ispec_CPML) == 3 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- Z-surface C-PML ---------------------------------
+ !------------------------------------------------------------------------------
+
+ if( zstore(iglob) .gt. 0.d0 ) then
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zstore(iglob) - zorigintop
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+ endif
+ else
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zoriginbottom - zstore(iglob)
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+
+ endif
+
+ !! DK DK define an alias for y and z variable names (which are the same)
+ ! stores damping profiles and auxiliary coefficients at the C-PML element's GLL points
+ K_store_x(i,j,k,ispec_CPML) = 1.d0
+ d_store_x(i,j,k,ispec_CPML) = 0.d0
+
+ K_store_y(i,j,k,ispec_CPML) = 1.d0
+ d_store_y(i,j,k,ispec_CPML) = 0.d0
+
+ K_store_z(i,j,k,ispec_CPML) = K_z
+ d_store_z(i,j,k,ispec_CPML) = d_z
+
+ alpha_store(i,j,k,ispec_CPML) = alpha_z
+
+ elseif( CPML_regions(ispec_CPML) == 4 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- XY-edge C-PML -----------------------------------
+ !------------------------------------------------------------------------------
+
+ if( xstore(iglob).gt.0.d0 .and. ystore(iglob).gt.0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xstore(iglob) - xoriginright
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = ystore(iglob) - yoriginfront
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ elseif( xstore(iglob).gt.0.d0 .and. ystore(iglob).lt.0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xstore(iglob) - xoriginright
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = yoriginback - ystore(iglob)
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ elseif( xstore(iglob).lt.0.d0 .and. ystore(iglob).gt.0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xoriginleft - xstore(iglob)
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = ystore(iglob) - yoriginfront
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ elseif( xstore(iglob).lt.0.d0 .and. ystore(iglob).lt.0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xoriginleft - xstore(iglob)
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = yoriginback - ystore(iglob)
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ endif
+
+ !! DK DK define an alias for y and z variable names (which are the same)
+ ! stores damping profiles and auxiliary coefficients at the C-PML element's GLL points
+ K_store_x(i,j,k,ispec_CPML) = K_x
+ d_store_x(i,j,k,ispec_CPML) = d_x
+
+ K_store_y(i,j,k,ispec_CPML) = K_y
+ d_store_y(i,j,k,ispec_CPML) = d_y
+
+
+ K_store_z(i,j,k,ispec_CPML) = 1.d0
+ d_store_z(i,j,k,ispec_CPML) = 0.d0
+
+ alpha_store(i,j,k,ispec_CPML) = ALPHA_MAX_PML / 2.d0
+
+ elseif( CPML_regions(ispec_CPML) == 5 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- XZ-edge C-PML -----------------------------------
+ !------------------------------------------------------------------------------
+
+ if( xstore(iglob).gt.0.d0 .and. zstore(iglob).gt.0.d0 ) then
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xstore(iglob) - xoriginright
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zstore(iglob) - zorigintop
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+ endif
+
+ elseif( xstore(iglob).gt.0.d0 .and. zstore(iglob).lt.0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xstore(iglob) - xoriginright
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zoriginbottom - zstore(iglob)
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+
+ elseif( xstore(iglob).lt.0.d0 .and. zstore(iglob).gt.0.d0 ) then
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xoriginleft - xstore(iglob)
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zstore(iglob) - zorigintop
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+ endif
+
+ elseif( xstore(iglob).lt.0.d0 .and. zstore(iglob).lt.0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xoriginleft - xstore(iglob)
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zoriginbottom - zstore(iglob)
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+
+ endif
+
+ !! DK DK define an alias for y and z variable names (which are the same)
+ ! stores damping profiles and auxiliary coefficients at the C-PML element's GLL points
+ K_store_x(i,j,k,ispec_CPML) = K_x
+ d_store_x(i,j,k,ispec_CPML) = d_x
+
+ K_store_y(i,j,k,ispec_CPML) = 1.d0
+ d_store_y(i,j,k,ispec_CPML) = 0.d0
+
+ K_store_z(i,j,k,ispec_CPML) = K_z
+ d_store_z(i,j,k,ispec_CPML) = d_z
+
+ alpha_store(i,j,k,ispec_CPML) = ALPHA_MAX_PML / 2.d0
+
+ elseif( CPML_regions(ispec_CPML) == 6 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- YZ-edge C-PML -----------------------------------
+ !------------------------------------------------------------------------------
+
+ if( ystore(iglob).gt.0.d0 .and. zstore(iglob).gt.0.d0 ) then
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = ystore(iglob) - yoriginfront
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zstore(iglob) - zorigintop
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+ endif
+
+ elseif( ystore(iglob).gt.0.d0 .and. zstore(iglob).lt.0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = ystore(iglob) - yoriginfront
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zoriginbottom - zstore(iglob)
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+
+ elseif( ystore(iglob).lt.0.d0 .and. zstore(iglob).gt.0.d0 ) then
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = yoriginback - ystore(iglob)
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zstore(iglob) - zorigintop
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+ endif
+
+ elseif( ystore(iglob).lt.0.d0 .and. zstore(iglob).lt.0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = yoriginback - ystore(iglob)
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zoriginbottom - zstore(iglob)
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+
+ endif
+
+ !! DK DK define an alias for y and z variable names (which are the same)
+ K_store_x(i,j,k,ispec_CPML) = 1.d0
+ d_store_x(i,j,k,ispec_CPML) = 0.d0
+
+ K_store_y(i,j,k,ispec_CPML) = K_y
+ d_store_y(i,j,k,ispec_CPML) = d_y
+
+ K_store_z(i,j,k,ispec_CPML) = K_z
+ d_store_z(i,j,k,ispec_CPML) = d_z
+
+ alpha_store(i,j,k,ispec_CPML) = ALPHA_MAX_PML / 2.d0
+
+ elseif( CPML_regions(ispec_CPML) == 7 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- XYZ-corner C-PML --------------------------------
+ !------------------------------------------------------------------------------
+
+ if( xstore(iglob).gt.0.d0 .and. ystore(iglob).gt.0.d0 .and. zstore(iglob).gt.0.d0 ) then
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xstore(iglob) - xoriginright
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML grid point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = ystore(iglob) - yoriginfront
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zstore(iglob) - zorigintop
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+ endif
+
+ elseif( xstore(iglob).gt.0.d0 .and. ystore(iglob).gt.0.d0 .and. zstore(iglob).lt.0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xstore(iglob) - xoriginright
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML grid point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = ystore(iglob) - yoriginfront
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zoriginbottom - zstore(iglob)
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+
+ elseif( xstore(iglob).gt.0.d0 .and. ystore(iglob).lt.0.d0 .and. zstore(iglob).gt.0.d0 ) then
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xstore(iglob) - xoriginright
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = yoriginback - ystore(iglob)
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zstore(iglob) - zorigintop
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+ endif
+
+ elseif( xstore(iglob).gt.0.d0 .and. ystore(iglob).lt.0.d0 .and. zstore(iglob) .lt. 0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xstore(iglob) - xoriginright
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = yoriginback - ystore(iglob)
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zoriginbottom - zstore(iglob)
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+
+ elseif( xstore(iglob).lt.0.d0 .and. ystore(iglob).gt.0.d0 .and. zstore(iglob).gt.0.d0 ) then
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xoriginleft - xstore(iglob)
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML grid point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = ystore(iglob) - yoriginfront
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zstore(iglob) - zorigintop
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+ endif
+
+ elseif( xstore(iglob).lt.0.d0 .and. ystore(iglob).gt.0.d0 .and. zstore(iglob).lt.0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xoriginleft - xstore(iglob)
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML grid point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = ystore(iglob) - yoriginfront
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zoriginbottom - zstore(iglob)
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+
+ elseif( xstore(iglob).lt.0.d0 .and. ystore(iglob).lt.0.d0 .and. zstore(iglob).gt.0.d0 ) then
+ if( PML_INSTEAD_OF_FREE_SURFACE ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xoriginleft - xstore(iglob)
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = yoriginback - ystore(iglob)
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zstore(iglob) - zorigintop
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+ endif
+
+ elseif( xstore(iglob).lt.0.d0 .and. ystore(iglob).lt.0.d0 .and. zstore(iglob) .lt. 0.d0 ) then
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_x = xoriginleft - xstore(iglob)
+
+ if( abscissa_in_PML_x .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_x / CPML_width_x
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_x = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_x)
+ alpha_x = ALPHA_MAX_PML / 2.d0
+ K_x = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_x = 0.d0
+ alpha_x = 0.d0
+ K_x = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_y = yoriginback - ystore(iglob)
+
+ if( abscissa_in_PML_y .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_y / CPML_width_y
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_y = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_y)
+ alpha_y = ALPHA_MAX_PML / 2.d0
+ K_y = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_y = 0.d0
+ alpha_y = 0.d0
+ K_y = 1.d0
+ endif
+
+ ! gets abscissa of current grid point along the damping profile
+ abscissa_in_PML_z = zoriginbottom - zstore(iglob)
+
+ if( abscissa_in_PML_z .ge. 0.d0 ) then
+ ! determines distance to C-PML/mesh interface
+ dist = abscissa_in_PML_z / CPML_width_z
+
+ ! gets damping profile at the C-PML element's GLL point
+ d_z = pml_damping_profile_l(myrank,iglob,dist,vp,CPML_width_z)
+ alpha_z = ALPHA_MAX_PML / 2.d0
+ K_z = 1.d0 + (K_MAX_PML - 1.d0) * dist**NPOWER
+ else
+ d_z = 0.d0
+ alpha_z = 0.d0
+ K_z = 1.d0
+ endif
+
+ endif
+
+ !! DK DK define an alias for y and z variable names (which are the same)
+ K_store_x(i,j,k,ispec_CPML) = K_x
+ d_store_x(i,j,k,ispec_CPML) = d_x
+
+ K_store_y(i,j,k,ispec_CPML) = K_y
+ d_store_y(i,j,k,ispec_CPML) = d_y
+
+ K_store_z(i,j,k,ispec_CPML) = K_z
+ d_store_z(i,j,k,ispec_CPML) = d_z
+
+ alpha_store(i,j,k,ispec_CPML) = ALPHA_MAX_PML / 2.d0
+
+ endif
+ enddo
+ enddo
+ enddo
+ enddo !ispec_CPML
+
+end subroutine pml_set_local_dampingcoeff
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+function pml_damping_profile_l(myrank,iglob,dist,vp,delta)
+
+ ! defines d, the damping profile at the C-PML element's GLL point for a given:
+ ! dist: distance to C-PML/mesh interface
+ ! vp: P-velocity
+ ! delta: thickness of the C-PML layer
+
+ use generate_databases_par, only: CUSTOM_REAL,NPOWER,CPML_Rcoef,damping_factor,PML_WIDTH_MIN,PML_WIDTH_MAX
+
+ implicit none
+
+ integer, intent(in) :: myrank,iglob
+
+ real(kind=CUSTOM_REAL), intent(in) :: dist,vp,delta
+
+ real(kind=CUSTOM_REAL) :: pml_damping_profile_l
+
+ ! gets damping profile
+ if( NPOWER .ge. 1 ) then
+ ! INRIA research report section 6.1: http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf
+ pml_damping_profile_l = - ((NPOWER + 1) * vp * log(CPML_Rcoef) / (2.d0 * delta) * damping_factor) * dist**NPOWER
+ else
+ call exit_mpi(myrank,'C-PML error: NPOWER must be greater than or equal to 1')
+ endif
+
+!!$ JC JC (from Daniel in his PML_init.f90 file) dominant wavelength has to be set differently
+!!$ determines dominant wavelength based on maximum model speed and source half time duration
+!!$ hdur_max = maxval(hdur(:))
+!!$ if( hdur_max > 0.0 ) then
+!!$ dominant_wavelength = model_speed_max * 2.0 * hdur_max
+!!$ else
+!!$ dominant_wavelength = 0._CUSTOM_REAL
+!!$ endif
+
+ ! checks coordinates of C-PML points and thickness of C-PML layer
+ if( delta < dist ) then
+ print*,'C-PML point ',iglob
+ print*,'distance to C-PML/mesh interface ',dist
+ print*,'C-PML thickness ',delta
+ call exit_mpi(myrank,'C-PML error: distance to C-PML/mesh interface is bigger than thickness of C-PML layer')
+ else if( delta < PML_WIDTH_MIN .or. delta > PML_WIDTH_MAX ) then
+ print*,'C-PML thickness min/max ',PML_WIDTH_MIN,PML_WIDTH_MAX
+ print*,'C-PML thickness ',delta
+ call exit_mpi(myrank,'C-PML error: thickness of C-PML layer is out of bounds')
+!!$ else if( delta < dominant_wavelength/2.0 ) then ! JC JC
+!!$ print*,'dominant wavelength/2 ',dominant_wavelength/2.0
+!!$ print*,'C-PML thickness ',delta
+!!$ call exit_mpi(myrank,'C-PML error: thickness of C-PML layer must be set according to dominant wavelength')
+ endif
+
+end function pml_damping_profile_l
+
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/read_partition_files.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/read_partition_files.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/read_partition_files.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -31,11 +31,13 @@
! reads in proc***_Databases files
use generate_databases_par
+
implicit none
integer :: num_xmin,num_xmax,num_ymin,num_ymax,num_top,num_bottom,num
+ integer :: num_cpml
integer :: num_moho
- integer :: j
+ integer :: i,j
!character(len=128) :: line
! read databases about external mesh simulation
@@ -91,9 +93,11 @@
if( ier /= 0 ) stop 'error allocating array undef_mat_prop'
do imat = 1, nundefMat_ext_mesh
! format example tomography:
- ! e.g.: -1 tomography elastic tomography_model.xyz 1 2
+ ! e.g.: -1 tomography elastic tomography_model.xyz 0 2
! format example interface:
- ! e.g.: -1 interface 14 15 1 2
+ ! e.g.: -1 interface 14 15 0 2
+ ! format example C-PML:
+ ! e.g.: -2001 2300.0 2800.0 1500.0 0 2
read(IIN) undef_mat_prop(1,imat),undef_mat_prop(2,imat),undef_mat_prop(3,imat),undef_mat_prop(4,imat), &
undef_mat_prop(5,imat), undef_mat_prop(6,imat)
end do
@@ -126,11 +130,11 @@
call sum_all_i(nspec_ab,num)
if(myrank == 0) then
- write(IMAIN,*) ' spectral elements: ',num
+ write(IMAIN,*) ' total number of spectral elements: ',num
endif
call sync_all()
-! read boundaries
+! reads absorbing/free-surface boundaries
read(IIN) boundary_number ,nspec2D_xmin
if(boundary_number /= 1) stop "Error : invalid database file"
@@ -203,6 +207,58 @@
endif
call sync_all()
+ ! reads number of C-PML elements in the global mesh
+ read(IIN) nspec_cpml_tot
+ if(myrank == 0) then
+ write(IMAIN,*) ' total number of C-PML elements in the global mesh: ',nspec_cpml_tot
+ endif
+ call sync_all()
+
+ if( nspec_cpml_tot > 0 ) then
+ ! reads number of C-PML elements in this partition
+ read(IIN) nspec_cpml
+
+ if(myrank == 0) then
+ write(IMAIN,*) ' number of C-PML spectral elements in this partition: ',nspec_cpml
+ endif
+ call sync_all()
+
+ call sum_all_i(nspec_cpml,num_cpml)
+
+ ! checks that the sum of C-PML elements over all partitions is correct
+ if( myrank == 0 .and. nspec_cpml_tot /= num_cpml ) stop 'error while summing C-PML elements over all partitions'
+
+ ! reads thickness of C-PML layers for the global mesh
+ read(IIN) CPML_width
+
+ ! reads C-PML regions and C-PML spectral elements global indexing
+ allocate(CPML_to_spec(nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array CPML_to_spec'
+ allocate(CPML_regions(nspec_cpml),stat=ier)
+ if(ier /= 0) stop 'error allocating array CPML_regions'
+
+ do i=1,nspec_cpml
+ ! #id_cpml_regions = 1 : X_surface C-PML
+ ! #id_cpml_regions = 2 : Y_surface C-PML
+ ! #id_cpml_regions = 3 : Z_surface C-PML
+ ! #id_cpml_regions = 4 : XY_edge C-PML
+ ! #id_cpml_regions = 5 : XZ_edge C-PML
+ ! #id_cpml_regions = 6 : YZ_edge C-PML
+ ! #id_cpml_regions = 7 : XYZ_corner C-PML
+ !
+ ! format: #id_cpml_element #id_cpml_regions
+ read(IIN) CPML_to_spec(i), CPML_regions(i)
+ enddo
+
+ ! reads mask of C-PML elements for all elements in this partition
+ allocate(CPML_mask_ibool(NSPEC_AB),stat=ier)
+ if(ier /= 0) stop 'error allocating array CPML_mask_ibool'
+
+ do i=1,NSPEC_AB
+ read(IIN) CPML_mask_ibool(i)
+ enddo
+ endif
+
! MPI interfaces between different partitions
if( NPROC > 1 ) then
! format: #number_of_MPI_interfaces #maximum_number_of_elements_on_each_interface
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/save_arrays_solver.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/save_arrays_solver.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -32,6 +32,10 @@
max_interface_size_ext_mesh,ibool_interfaces_ext_mesh, &
SAVE_MESH_FILES,ANISOTROPY)
+ use generate_databases_par, only: nspec_cpml,CPML_width,CPML_to_spec,CPML_regions,CPML_mask_ibool,nspec_cpml_tot, &
+ d_store_x,d_store_y,d_store_z,k_store_x,k_store_y,k_store_z,alpha_store, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top,PML_CONDITIONS
use create_regions_mesh_ext_par
implicit none
@@ -122,6 +126,22 @@
write(IOUT) rho_vsI
endif
+! C-PML absorbing boundary conditions
+ write(IOUT) nspec_cpml
+ write(IOUT) CPML_width
+ if( nspec_cpml > 0 ) then
+ write(IOUT) CPML_regions
+ write(IOUT) CPML_to_spec
+ write(IOUT) CPML_mask_ibool
+ write(IOUT) d_store_x
+ write(IOUT) d_store_y
+ write(IOUT) d_store_z
+ write(IOUT) k_store_x
+ write(IOUT) k_store_y
+ write(IOUT) k_store_z
+ write(IOUT) alpha_store
+ endif
+
! absorbing boundary surface
write(IOUT) num_abs_boundary_faces
if( num_abs_boundary_faces > 0 ) then
@@ -140,6 +160,19 @@
endif
endif
+ write(IOUT) nspec2D_xmin
+ write(IOUT) nspec2D_xmax
+ write(IOUT) nspec2D_ymin
+ write(IOUT) nspec2D_ymax
+ write(IOUT) NSPEC2D_BOTTOM
+ write(IOUT) NSPEC2D_TOP
+ write(IOUT) ibelm_xmin
+ write(IOUT) ibelm_xmax
+ write(IOUT) ibelm_ymin
+ write(IOUT) ibelm_ymax
+ write(IOUT) ibelm_bottom
+ write(IOUT) ibelm_top
+
! free surface
write(IOUT) num_free_surface_faces
if( num_free_surface_faces > 0 ) then
@@ -271,8 +304,25 @@
endif
! cleanup
- deallocate(ibool_interfaces_ext_mesh_dummy,stat=ier); if( ier /= 0 ) stop 'error deallocating array'
+ deallocate(ibool_interfaces_ext_mesh_dummy,stat=ier)
+ if( ier /= 0 ) stop 'error deallocating array ibool_interfaces_ext_mesh_dummy'
+ if( nspec_cpml_tot > 0 ) then
+ deallocate(CPML_to_spec,stat=ier); if( ier /= 0 ) stop 'error deallocating array CPML_to_spec'
+ deallocate(CPML_regions,stat=ier); if( ier /= 0 ) stop 'error deallocating array CPML_regions'
+ deallocate(CPML_mask_ibool,stat=ier); if( ier /= 0 ) stop 'error deallocating array CPML_mask_ibool'
+ endif
+
+ if( PML_CONDITIONS ) then
+ deallocate(d_store_x,stat=ier); if( ier /= 0 ) stop 'error deallocating array d_store_x'
+ deallocate(d_store_y,stat=ier); if( ier /= 0 ) stop 'error deallocating array d_store_y'
+ deallocate(d_store_z,stat=ier); if( ier /= 0 ) stop 'error deallocating array d_store_z'
+ deallocate(k_store_x,stat=ier); if( ier /= 0 ) stop 'error deallocating array d_store_x'
+ deallocate(k_store_y,stat=ier); if( ier /= 0 ) stop 'error deallocating array d_store_y'
+ deallocate(k_store_z,stat=ier); if( ier /= 0 ) stop 'error deallocating array d_store_z'
+ deallocate(alpha_store,stat=ier); if( ier /= 0 ) stop 'error deallocating array alpha_store'
+ endif
+
end subroutine save_arrays_solver_ext_mesh
!
Modified: seismo/3D/SPECFEM3D/trunk/src/generate_databases/setup_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/generate_databases/setup_mesh.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/generate_databases/setup_mesh.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -31,6 +31,7 @@
! mesh creation for solver
use generate_databases_par
+
implicit none
! compute maximum number of points
Modified: seismo/3D/SPECFEM3D/trunk/src/meshfem3D/check_mesh_quality.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/meshfem3D/check_mesh_quality.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/meshfem3D/check_mesh_quality.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -101,11 +101,12 @@
USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO,NGNOD,NGNOD2D
double precision DT
- double precision HDUR_MOVIE,OLSEN_ATTENUATION_RATIO
+ double precision HDUR_MOVIE,OLSEN_ATTENUATION_RATIO,f0_FOR_PML,PML_WIDTH_MIN,PML_WIDTH_MAX
logical ATTENUATION,USE_OLSEN_ATTENUATION, &
OCEANS,TOPOGRAPHY,USE_FORCE_POINT_SOURCE
logical ABSORBING_CONDITIONS,SAVE_FORWARD,ABSORB_INSTEAD_OF_FREE_SURFACE
logical ANISOTROPY,SAVE_MESH_FILES,USE_RICKER_TIME_FUNCTION,PRINT_SOURCE_TIME_FUNCTION
+ logical PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE
character(len=256) LOCAL_PATH,TOMOGRAPHY_PATH
integer NPROC
integer MOVIE_TYPE,IMODEL
@@ -130,7 +131,8 @@
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD, &
NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY, &
USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,IMODEL)
+ USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,PML_CONDITIONS, &
+ PML_INSTEAD_OF_FREE_SURFACE,PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL)
if(NGNOD /= 8) stop 'error: check_mesh_quality only supports NGNOD == 8 for now'
Modified: seismo/3D/SPECFEM3D/trunk/src/meshfem3D/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/meshfem3D/meshfem3D.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/meshfem3D/meshfem3D.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -334,13 +334,14 @@
USE_HIGHRES_FOR_MOVIES
integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO,NGNOD,NGNOD2D
double precision DT
- double precision HDUR_MOVIE,OLSEN_ATTENUATION_RATIO
+ double precision HDUR_MOVIE,OLSEN_ATTENUATION_RATIO,f0_FOR_PML
logical ATTENUATION,USE_OLSEN_ATTENUATION, &
OCEANS,TOPOGRAPHY,USE_FORCE_POINT_SOURCE
logical ABSORBING_CONDITIONS,SAVE_FORWARD,ABSORB_INSTEAD_OF_FREE_SURFACE
logical ANISOTROPY,SAVE_MESH_FILES,USE_RICKER_TIME_FUNCTION,PRINT_SOURCE_TIME_FUNCTION
+ logical PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE
integer MOVIE_TYPE,IMODEL
- character(len=256) OUTPUT_FILES,LOCAL_PATH,TOMOGRAPHY_PATH
+ character(len=256) OUTPUT_FILES,LOCAL_PATH,TOMOGRAPHY_PATH,PML_WIDTH_MIN,PML_WIDTH_MAX
! ************** PROGRAM STARTS HERE **************
@@ -380,7 +381,8 @@
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD, &
NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY, &
USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,IMODEL)
+ USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,PML_CONDITIONS, &
+ PML_INSTEAD_OF_FREE_SURFACE,PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL)
! read the mesh parameter file
! nullify(subregions,material_properties)
Modified: seismo/3D/SPECFEM3D/trunk/src/meshfem3D/save_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/meshfem3D/save_databases.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/meshfem3D/save_databases.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -72,6 +72,8 @@
double precision , dimension(NMATERIALS,6) :: material_properties
double precision , dimension(16) :: matpropl
integer :: i,ispec,iglob,ier
+ ! dummy_nspec_cpml is used here to match the read instructions in generate_databases/read_partition_files.f90
+ integer :: dummy_nspec_cpml
! name of the database files
character(len=256) prname
@@ -147,6 +149,11 @@
ibool(NGLLX_M,NGLLY_M,NGLLZ_M,ibelm_top(i)),ibool(1,NGLLY_M,NGLLZ_M,ibelm_top(i))
end do
+ ! JC JC todo: implement C-PML code in internal mesher
+ ! dummy_nspec_cpml is used here to match the read instructions in generate_databases/read_partition_files.f90
+ dummy_nspec_cpml = 0
+ write(IIN_database) dummy_nspec_cpml
+
! MPI Interfaces
if(NPROC_XI >= 2 .or. NPROC_ETA >= 2) then
@@ -198,7 +205,6 @@
if(interfaces(SE)) nspec_interface(SE) = count((iMPIcut_xi(2,:) .eqv. .true.) .and. (iMPIcut_eta(1,:) .eqv. .true.))
if(interfaces(SW)) nspec_interface(SW) = count((iMPIcut_xi(1,:) .eqv. .true.) .and. (iMPIcut_eta(1,:) .eqv. .true.))
-
nspec_interfaces_max = maxval(nspec_interface)
write(IIN_database) nb_interfaces,nspec_interfaces_max
Modified: seismo/3D/SPECFEM3D/trunk/src/shared/check_mesh_resolution.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/shared/check_mesh_resolution.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/shared/check_mesh_resolution.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -122,31 +122,31 @@
NSPEC_AB,kappastore,mustore,rho_vp,rho_vs)
! min/max for whole cpu partition
- vpmin_glob = min ( vpmin_glob, vpmin)
- vpmax_glob = max ( vpmax_glob, vpmax)
+ vpmin_glob = min(vpmin_glob, vpmin)
+ vpmax_glob = max(vpmax_glob, vpmax)
- vsmin_glob = min ( vsmin_glob, vsmin)
- vsmax_glob = max ( vsmax_glob, vsmax)
+ vsmin_glob = min(vsmin_glob, vsmin)
+ vsmax_glob = max(vsmax_glob, vsmax)
! computes minimum and maximum distance of neighbor GLL points in this grid cell
call get_GLL_minmaxdistance(distance_min,distance_max,ispec, &
NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore)
- distance_min_glob = min( distance_min_glob, distance_min)
- distance_max_glob = max( distance_max_glob, distance_max)
+ distance_min_glob = min(distance_min_glob, distance_min)
+ distance_max_glob = max(distance_max_glob, distance_max)
! computes minimum and maximum size of this grid cell
call get_elem_minmaxsize(elemsize_min,elemsize_max,ispec, &
NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore)
- elemsize_min_glob = min( elemsize_min_glob, elemsize_min)
- elemsize_max_glob = max( elemsize_max_glob, elemsize_max)
+ elemsize_min_glob = min(elemsize_min_glob, elemsize_min)
+ elemsize_max_glob = max(elemsize_max_glob, elemsize_max)
! courant number
! based on minimum GLL point distance and maximum velocity
! i.e. on the maximum ratio of ( velocity / gridsize )
if( DT_PRESENT ) then
- cmax = max( vpmax,vsmax ) * DT / distance_min
+ cmax = max(vpmax,vsmax) * DT / distance_min
cmax_glob = max(cmax_glob,cmax)
! debug: for vtk output
Modified: seismo/3D/SPECFEM3D/trunk/src/shared/combine_vol_data.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/shared/combine_vol_data.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/shared/combine_vol_data.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -89,7 +89,7 @@
! for read_parameter_files
double precision :: DT
- double precision :: HDUR_MOVIE,OLSEN_ATTENUATION_RATIO
+ double precision :: HDUR_MOVIE,OLSEN_ATTENUATION_RATIO,f0_FOR_PML,PML_WIDTH_MIN,PML_WIDTH_MAX
integer :: NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP, &
UTM_PROJECTION_ZONE,SIMULATION_TYPE,NGNOD,NGNOD2D
integer :: NSOURCES,NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY
@@ -100,6 +100,7 @@
OCEANS,TOPOGRAPHY,USE_FORCE_POINT_SOURCE
logical :: ABSORBING_CONDITIONS,SAVE_FORWARD,ABSORB_INSTEAD_OF_FREE_SURFACE
logical :: ANISOTROPY,SAVE_MESH_FILES,USE_RICKER_TIME_FUNCTION,PRINT_SOURCE_TIME_FUNCTION
+ logical :: PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE
character(len=256) LOCAL_PATH,TOMOGRAPHY_PATH
integer :: IMODEL
@@ -183,7 +184,8 @@
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD, &
NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY, &
USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,IMODEL)
+ USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,PML_CONDITIONS, &
+ PML_INSTEAD_OF_FREE_SURFACE,PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL)
print *, 'Slice list: '
print *, node_list(1:num_node)
Modified: seismo/3D/SPECFEM3D/trunk/src/shared/constants.h.in
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/shared/constants.h.in 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/shared/constants.h.in 2013-01-12 21:24:23 UTC (rev 21224)
@@ -137,10 +137,19 @@
!!-----------------------------------------------------------
!!
-!! absorption and PML
+!! C-PML absorbing boundary conditions
!!
!!-----------------------------------------------------------
+ real(kind=CUSTOM_REAL), parameter :: NPOWER = 1.d0
+ real(kind=CUSTOM_REAL), parameter :: K_MAX_PML = 1.d0 ! (Martin and Komatitsch, Geophys. J. Int. 2009)
+! C-PML theoretical reflection coefficient
+! (INRIA research report section 6.1: http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf)
+ real(kind=CUSTOM_REAL), parameter :: CPML_Rcoef = 0.001d0
+
+! empirical damping modified factor
+ real(kind=CUSTOM_REAL), parameter :: damping_factor = 1.2d0
+
! absorb boundaries using a PML region
! (EXPERIMENTAL feature)
! (only acoustic domains supported...)
Modified: seismo/3D/SPECFEM3D/trunk/src/shared/create_movie_shakemap_AVS_DX_GMT.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/shared/create_movie_shakemap_AVS_DX_GMT.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/shared/create_movie_shakemap_AVS_DX_GMT.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -90,11 +90,12 @@
USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO,NGNOD,NGNOD2D
double precision DT
- double precision HDUR_MOVIE,OLSEN_ATTENUATION_RATIO
+ double precision HDUR_MOVIE,OLSEN_ATTENUATION_RATIO,f0_FOR_PML,PML_WIDTH_MIN,PML_WIDTH_MAX
logical ATTENUATION,USE_OLSEN_ATTENUATION, &
OCEANS,TOPOGRAPHY,USE_FORCE_POINT_SOURCE
logical ABSORBING_CONDITIONS,SAVE_FORWARD,ABSORB_INSTEAD_OF_FREE_SURFACE
logical ANISOTROPY,SAVE_MESH_FILES,USE_RICKER_TIME_FUNCTION,PRINT_SOURCE_TIME_FUNCTION
+ logical PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE
character(len=256) OUTPUT_FILES,LOCAL_PATH,TOMOGRAPHY_PATH
integer NPROC
integer ier
@@ -137,7 +138,8 @@
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD, &
NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY, &
USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,IMODEL)
+ USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,PML_CONDITIONS, &
+ PML_INSTEAD_OF_FREE_SURFACE,PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL)
! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', OUTPUT_FILES_PATH(1:len_trim(OUTPUT_FILES_PATH)))
Modified: seismo/3D/SPECFEM3D/trunk/src/shared/get_force.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/shared/get_force.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/shared/get_force.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -45,6 +45,7 @@
integer isource,dummyval
double precision t_shift(NSOURCES)
+ double precision length
character(len=7) dummy
character(len=256) string, FORCESOLUTION
@@ -129,7 +130,6 @@
endif
do isource=1,NSOURCES
-
! checks half-duration
! half-duration is the dominant frequency of the source
! point forces use a Ricker source time function
@@ -138,9 +138,13 @@
if( hdur(isource) < TINYVAL ) hdur(isource) = TINYVAL
! check (inclined) force source's direction vector
- if( comp_dir_vect_source_E(isource) .eq. 0.d0 .and. comp_dir_vect_source_N(isource) .eq. 0.d0 &
- .and. comp_dir_vect_source_Z_UP(isource) .eq. 0.d0 ) &
- stop 'When using USE_FORCE_POINT_SOURCE make sure all forces have a non null direction vector'
+ length = sqrt( comp_dir_vect_source_E(isource)**2 + comp_dir_vect_source_N(isource)**2 + &
+ comp_dir_vect_source_Z_UP(isource)**2 )
+ if( length < TINYVAL) then
+ print *, 'normal length: ', length
+ print *, 'isource: ',isource
+ stop 'error set force point normal length, make sure all forces have a non null direction vector'
+ endif
enddo
end subroutine get_force
Modified: seismo/3D/SPECFEM3D/trunk/src/shared/read_parameter_file.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/shared/read_parameter_file.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/shared/read_parameter_file.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -33,7 +33,8 @@
SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION,NTSTEP_BETWEEN_OUTPUT_INFO, &
SIMULATION_TYPE,SAVE_FORWARD,NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY, &
USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,IMODEL)
+ USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,PML_CONDITIONS, &
+ PML_INSTEAD_OF_FREE_SURFACE,PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL)
implicit none
@@ -44,12 +45,13 @@
integer NOISE_TOMOGRAPHY,NGNOD,NGNOD2D,MOVIE_TYPE
integer IMODEL
- double precision DT,HDUR_MOVIE,OLSEN_ATTENUATION_RATIO
+ double precision DT,HDUR_MOVIE,OLSEN_ATTENUATION_RATIO,f0_FOR_PML,PML_WIDTH_MIN,PML_WIDTH_MAX
logical ATTENUATION,USE_OLSEN_ATTENUATION,OCEANS,TOPOGRAPHY,ABSORBING_CONDITIONS,SAVE_FORWARD
logical MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT,USE_HIGHRES_FOR_MOVIES
logical ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION,SUPPRESS_UTM_PROJECTION
logical USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE,USE_RICKER_TIME_FUNCTION
+ logical PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE
character(len=256) LOCAL_PATH,TOMOGRAPHY_PATH,CMTSOLUTION,FORCESOLUTION
@@ -126,6 +128,20 @@
if(err_occurred() /= 0) return
call read_value_logical(ABSORB_INSTEAD_OF_FREE_SURFACE, 'model.ABSORB_INSTEAD_OF_FREE_SURFACE')
if(err_occurred() /= 0) return
+ call read_value_logical(PML_CONDITIONS, 'solver.PML_CONDITIONS')
+ if(err_occurred() /= 0) return
+ call read_value_logical(PML_INSTEAD_OF_FREE_SURFACE, 'model.PML_INSTEAD_OF_FREE_SURFACE')
+ if(err_occurred() /= 0) return
+ call read_value_double_precision(PML_WIDTH_MIN, 'model.PML_WIDTH_MIN')
+ if(err_occurred() /= 0) return
+ call read_value_double_precision(PML_WIDTH_MAX, 'model.PML_WIDTH_MAX')
+ if(err_occurred() /= 0) return
+ call read_value_double_precision(f0_FOR_PML, 'model.f0_FOR_PML')
+ if(err_occurred() /= 0) return
+ !call read_value_logical(ROTATE_PML_ACTIVATE, 'solver.ROTATE_PML_ACTIVATE')
+ !if(err_occurred() /= 0) return
+ !call read_value_double_precision(ROTATE_PML_ANGLE, 'solver.ROTATE_PML_ANGLE')
+ !if(err_occurred() /= 0) return
call read_value_logical(CREATE_SHAKEMAP, 'solver.CREATE_SHAKEMAP')
if(err_occurred() /= 0) return
call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE')
@@ -158,48 +174,42 @@
if(err_occurred() /= 0) return
call read_value_logical(PRINT_SOURCE_TIME_FUNCTION, 'solver.PRINT_SOURCE_TIME_FUNCTION')
if(err_occurred() /= 0) return
-
+
! close parameter file
call close_parameter_file()
- ! checks number of nodes for 2D and 3D shape functions for quadrilaterals and hexahedra
- ! curvature (i.e. HEX27 elements) is not handled by our internal mesher, for that use Gmsh (CUBIT does not handle it either)
- if ( NGNOD == 8 ) then
- NGNOD2D = 4
- else if ( NGNOD == 27 ) then
- NGNOD2D = 9
- else if ( NGNOD /= 8 .and. NGNOD /= 27 ) then
- stop 'elements should have 8 or 27 control nodes, please modify NGNOD in Par_file'
- endif
+ ! noise simulations:
+ ! double the number of time steps, if running noise simulations (+/- branches)
+ if( NOISE_TOMOGRAPHY /= 0 ) NSTEP = 2*NSTEP-1
- ! checks the MOVIE_TYPE parameter
- if ( MOVIE_TYPE /= 1 .and. MOVIE_TYPE /= 2 ) then
- stop 'error: MOVIE_TYPE must be either 1 or 2'
+ ! for noise simulations, we need to save movies at the surface (where the noise is generated)
+ ! and thus we force MOVIE_SURFACE to be .true., in order to use variables defined for surface movies later
+ if( NOISE_TOMOGRAPHY /= 0 ) then
+ MOVIE_TYPE = 1
+ MOVIE_SURFACE = .true.
+ USE_HIGHRES_FOR_MOVIES = .true. ! we need to save surface movie everywhere, i.e. at all GLL points on the surface
endif
- ! noise simulations:
- ! double the number of time steps, if running noise simulations (+/- branches)
- if ( NOISE_TOMOGRAPHY /= 0 ) NSTEP = 2*NSTEP-1
-
! the default value of NTSTEP_BETWEEN_READ_ADJSRC (0) is to read the whole trace at the same time
- if ( NTSTEP_BETWEEN_READ_ADJSRC == 0 ) NTSTEP_BETWEEN_READ_ADJSRC = NSTEP
+ if( NTSTEP_BETWEEN_READ_ADJSRC == 0 ) NTSTEP_BETWEEN_READ_ADJSRC = NSTEP
! total times steps must be dividable by adjoint source chunks/blocks
if ( mod(NSTEP,NTSTEP_BETWEEN_READ_ADJSRC) /= 0 ) then
- print*,'error: mod(NSTEP,NTSTEP_BETWEEN_READ_ADJSRC) must be zero!'
- print*,' change your Par_file (when NOISE_TOMOGRAPHY is not equal to zero, ACTUAL_NSTEP=2*NSTEP-1)'
- stop 'mod(NSTEP,NTSTEP_BETWEEN_READ_ADJSRC) must be zero!'
+ print*,'When NOISE_TOMOGRAPHY is not equal to zero, ACTUAL_NSTEP=2*NSTEP-1'
+ stop 'error: mod(NSTEP,NTSTEP_BETWEEN_READ_ADJSRC) must be zero! Please modify Par_file and recompile solver'
endif
- ! for noise simulations, we need to save movies at the surface (where the noise is generated)
- ! and thus we force MOVIE_SURFACE to be .true., in order to use variables defined for surface movies later
- if ( NOISE_TOMOGRAPHY /= 0 ) then
- MOVIE_TYPE = 1
- MOVIE_SURFACE = .true.
- USE_HIGHRES_FOR_MOVIES = .true. ! we need to save surface movie everywhere, i.e. at all GLL points on the surface
+ ! checks number of nodes for 2D and 3D shape functions for quadrilaterals and hexahedra
+ ! curvature (i.e. HEX27 elements) is not handled by our internal mesher, for that use Gmsh (CUBIT does not handle it either)
+ if( NGNOD == 8 ) then
+ NGNOD2D = 4
+ else if( NGNOD == 27 ) then
+ NGNOD2D = 9
+ else if( NGNOD /= 8 .and. NGNOD /= 27 ) then
+ stop 'elements should have 8 or 27 control nodes, please modify NGNOD in Par_file and recompile solver'
endif
- if (USE_FORCE_POINT_SOURCE) then
+ if( USE_FORCE_POINT_SOURCE ) then
! compute the total number of sources in the FORCESOLUTION file
! there are NLINES_PER_FORCESOLUTION_SOURCE lines per source in that file
call get_value_string(FORCESOLUTION, 'solver.FORCESOLUTION',&
@@ -215,11 +225,11 @@
enddo
close(21)
- if(mod(icounter,NLINES_PER_FORCESOLUTION_SOURCE) /= 0) &
- stop 'total number of lines in FORCESOLUTION file should be a multiple of NLINES_PER_FORCESOLUTION_SOURCE'
+ if( mod(icounter,NLINES_PER_FORCESOLUTION_SOURCE) /= 0 ) &
+ stop 'error: total number of lines in FORCESOLUTION file should be a multiple of NLINES_PER_FORCESOLUTION_SOURCE'
NSOURCES = icounter / NLINES_PER_FORCESOLUTION_SOURCE
- if(NSOURCES < 1) stop 'need at least one source in FORCESOLUTION file'
+ if(NSOURCES < 1) stop 'error: need at least one source in FORCESOLUTION file'
else
! compute the total number of sources in the CMTSOLUTION file
@@ -238,10 +248,10 @@
close(21)
if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) &
- stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
+ stop 'error: total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE
- if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
+ if(NSOURCES < 1) stop 'error: need at least one source in CMTSOLUTION file'
! compute the minimum value of hdur in CMTSOLUTION file
open(unit=21,file=trim(CMTSOLUTION),status='old',action='read')
@@ -267,8 +277,8 @@
close(21)
! one cannot use a Heaviside source for the movies
- if((MOVIE_SURFACE .or. MOVIE_VOLUME) .and. sqrt(minval_hdur**2 + HDUR_MOVIE**2) < TINYVAL) &
- stop 'hdur too small for movie creation, movies do not make sense for Heaviside source'
+ if( (MOVIE_SURFACE .or. MOVIE_VOLUME) .and. sqrt(minval_hdur**2 + HDUR_MOVIE**2) < TINYVAL ) &
+ stop 'error: hdur too small for movie creation, movies do not make sense for Heaviside source'
endif
! converts all string characters to lowercase
@@ -324,7 +334,7 @@
! check
if( IMODEL == IMODEL_IPATI .or. IMODEL == IMODEL_IPATI_WATER ) then
if( USE_RICKER_TIME_FUNCTION .eqv. .false. ) &
- stop 'please set USE_RICKER_TIME_FUNCTION to .true. in Par_file and recompile solver'
+ stop 'error: please set USE_RICKER_TIME_FUNCTION to .true. in Par_file and recompile solver'
endif
end subroutine read_parameter_file
Modified: seismo/3D/SPECFEM3D/trunk/src/shared/smooth_vol_data.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/shared/smooth_vol_data.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/shared/smooth_vol_data.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -97,7 +97,7 @@
! for read_parameter_files
double precision :: DT
- double precision :: HDUR_MOVIE,OLSEN_ATTENUATION_RATIO
+ double precision :: HDUR_MOVIE,OLSEN_ATTENUATION_RATIO,f0_FOR_PML,PML_WIDTH_MIN,PML_WIDTH_MAX
integer :: NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP, &
UTM_PROJECTION_ZONE,SIMULATION_TYPE,NGNOD,NGNOD2D
integer :: NSOURCES,NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY
@@ -108,6 +108,7 @@
OCEANS,TOPOGRAPHY,USE_FORCE_POINT_SOURCE
logical :: ABSORBING_CONDITIONS,SAVE_FORWARD,ABSORB_INSTEAD_OF_FREE_SURFACE
logical :: ANISOTROPY,SAVE_MESH_FILES,USE_RICKER_TIME_FUNCTION,PRINT_SOURCE_TIME_FUNCTION
+ logical :: PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE
character(len=256) LOCAL_PATH,TOMOGRAPHY_PATH
integer :: MOVIE_TYPE,IMODEL
@@ -221,7 +222,8 @@
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD, &
NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY, &
USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,IMODEL)
+ USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,PML_CONDITIONS, &
+ PML_INSTEAD_OF_FREE_SURFACE,PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL)
! checks if number of MPI process as specified
if (sizeprocs /= NPROC) then
Modified: seismo/3D/SPECFEM3D/trunk/src/shared/sum_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/shared/sum_kernels.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/shared/sum_kernels.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -103,7 +103,7 @@
! for read_parameter_files
double precision :: DT
- double precision :: HDUR_MOVIE,OLSEN_ATTENUATION_RATIO
+ double precision :: HDUR_MOVIE,OLSEN_ATTENUATION_RATIO,f0_FOR_PML,PML_WIDTH_MIN,PML_WIDTH_MAX
integer :: NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP, &
UTM_PROJECTION_ZONE,SIMULATION_TYPE,NGNOD,NGNOD2D
integer :: NSOURCES,NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY
@@ -115,6 +115,7 @@
OCEANS,TOPOGRAPHY,USE_FORCE_POINT_SOURCE
logical :: ABSORBING_CONDITIONS,SAVE_FORWARD,ABSORB_INSTEAD_OF_FREE_SURFACE
logical :: ANISOTROPY,SAVE_MESH_FILES,USE_RICKER_TIME_FUNCTION,PRINT_SOURCE_TIME_FUNCTION
+ logical :: PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE
character(len=256) LOCAL_PATH,TOMOGRAPHY_PATH
! ============ program starts here =====================
@@ -160,7 +161,8 @@
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD, &
NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY, &
USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,IMODEL)
+ USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,PML_CONDITIONS, &
+ PML_INSTEAD_OF_FREE_SURFACE,PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL)
! checks if number of MPI process as specified
if (sizeprocs /= NPROC) then
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/Makefile.in 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/Makefile.in 2013-01-12 21:24:23 UTC (rev 21224)
@@ -173,7 +173,7 @@
# solver objects - no statically allocated arrays anymore
SOLVER_ARRAY_OBJECTS = \
$O/specfem3D_par.o \
- $O/PML_init.o \
+ $O/pml_par.o \
$O/assemble_MPI_vector.o \
$O/fault_solver_common.o \
$O/fault_solver_dynamic.o \
@@ -211,6 +211,10 @@
$O/iterate_time.o \
$O/make_gravity.o \
$O/noise_tomography.o \
+ $O/pml_allocate_arrays.o \
+ $O/pml_output_VTKs.o \
+ $O/pml_set_accel_contribution.o \
+ $O/pml_set_memory_variables.o \
$O/prepare_timerun.o \
$O/program_specfem3D.o \
$O/read_mesh_databases.o \
@@ -228,6 +232,7 @@
MODEL_UPD_OBJECTS = \
$O/specfem3D_par.o \
+ $O/pml_par.o \
$O/model_update.o \
$O/check_mesh_resolution.shared.o \
$O/create_name_database.shared.o \
@@ -406,7 +411,7 @@
$O/serial.o: $(SHARED)constants.h $(SHARED)serial.f90
${FCCOMPILE_CHECK} -c -o $O/serial.o $(SHARED)serial.f90
-
+
$O/smooth_vol_data.o: $(SHARED)constants.h $(SHARED)smooth_vol_data.f90
${MPIFCCOMPILE_NO_CHECK} -c -o $O/smooth_vol_data.o $(SHARED)smooth_vol_data.f90
Deleted: seismo/3D/SPECFEM3D/trunk/src/specfem3D/PML_init.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/PML_init.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/PML_init.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -1,1248 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D V e r s i o n 2 . 1
-! ---------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA and CNRS / INRIA / University of Pau
-! (c) Princeton University / California Institute of Technology and CNRS / INRIA / University of Pau
-! July 2012
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-module PML_par
-
- use constants,only: CUSTOM_REAL
-
- !--------------------------------------------------------------------
- ! USER PARAMETERS
-
- ! damping profile coefficients:
- ! R: theoretical reflection coefficient after discretization
- real(kind=CUSTOM_REAL),parameter:: PML_damp_R = 1.e-3
-
- ! number of element layers for PML region
- ! default is 2 element layers
- integer :: PML_LAYERS = 2
-
- ! additional absorbing, Sommerfeld (^Stacey) condition at the boundaries
- logical,parameter:: PML_USE_SOMMERFELD = .false.
-
- !--------------------------------------------------------------------
-
- real(kind=CUSTOM_REAL):: PML_width
- real(kind=CUSTOM_REAL):: PML_width_min,PML_width_max
-
- ! PML element type flag
- integer,dimension(:),allocatable :: ispec_is_PML_inum
-
- ! PML global points
- integer,dimension(:),allocatable :: iglob_is_PML
-
- ! PML spectral elements
- integer,dimension(:),allocatable :: PML_ispec
- integer :: num_PML_ispec
-
- ! PML normal for each PML spectral element
- real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: PML_normal
- ! PML damping coefficients d & dprime
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable :: PML_damping_d,PML_damping_dprime
-
- !real(kind=CUSTOM_REAL),dimension(:),allocatable :: PML_damping_d_global
-
- ! PML interface
- integer,dimension(:),allocatable :: iglob_is_PML_interface
-
- ! mask ibool needed for time marching
- logical,dimension(:),allocatable :: PML_mask_ibool
-
-end module PML_par
-
-!--------
-
-module PML_par_acoustic
-
- ! potentials split into 4 terms plus temporary potential:
- ! chi = chi1 + chi2 + chi3 + chi4
- ! temporary: chi2_t = (\partial_t + d ) chi2
-
- use constants,only: CUSTOM_REAL
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- chi1,chi2,chi2_t,chi3,chi4
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
-
-end module PML_par_acoustic
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_damping_profile_l(d,x,vp,delta)
-
-! calculates damping coefficient value d for a given
-! x: distance x and
-! vp: p-velocity alpha
-! delta: PML width
-!
-! returns: d damping coefficients
- use PML_par,only: CUSTOM_REAL,PML_damp_R
- implicit none
- real(kind=CUSTOM_REAL),intent(out):: d
- real(kind=CUSTOM_REAL),intent(in):: x,vp,delta
-
- ! damping profile coefficients:
- ! d : damping function of (x)
- ! vp: P-velocity
- ! delta: width of PML layer
- ! R: theoretical reflection coefficient after discretization
-
- ! damping profile function: d = f(x)
- ! Komatitsch & Tromp, 2003: eq. 24 page 150
- d = 3.0*vp/(2.0*delta)*log(1.0/PML_damp_R)*x*x/(delta*delta)
-
-end subroutine PML_damping_profile_l
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_initialize()
-
- use specfem_par,only: NGLOB_AB,NSPEC_AB,myrank, &
- model_speed_max,hdur
- use PML_par
- use PML_par_acoustic
- use constants,only: FIX_UNDERFLOW_PROBLEM,VERYSMALLVAL,IMAIN,&
- NGLLX,NGLLY,NGLLZ,TINYVAL
- implicit none
-
- ! local parameters
- real(kind=CUSTOM_REAL):: d,dprime,d_glob,dprime_glob
- real(kind=CUSTOM_REAL) :: dominant_wavelength,hdur_max
- integer :: count,ilayer,sign,ier
-
- ! user output
- if( myrank == 0 ) then
- write(IMAIN,*)
- write(IMAIN,*) 'incorporating PML '
- write(IMAIN,*)
- endif
-
- ! PML element type array: 1 = face, 2 = edge, 3 = corner
- allocate(ispec_is_PML_inum(NSPEC_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array ispec_is_PML_inum'
- ispec_is_PML_inum(:) = 0
- num_PML_ispec = 0
-
- ! PML interface points between PML and "regular" region
- allocate(iglob_is_PML_interface(NGLOB_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array iglob_is_PML_interface'
- iglob_is_PML_interface(:) = 0
-
- ! PML global points
- allocate(iglob_is_PML(NGLOB_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array iglob_is_PML'
- iglob_is_PML(:) = 0
-
- ! PML ibool mask
- allocate(PML_mask_ibool(NGLOB_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array PML_mask_ibool'
- PML_mask_ibool(:) = .false.
-
- ! determines dominant wavelength based on maximum model speed
- ! and source half time duration
- hdur_max = maxval(hdur(:))
- if( hdur_max > 0.0 ) then
- dominant_wavelength = model_speed_max * 2.0 * hdur_max
- else
- dominant_wavelength = 0._CUSTOM_REAL
- endif
-
- ! for multiple PML element layers
- ilayer = 0
- do while( ilayer < PML_LAYERS )
- ilayer = ilayer + 1
-
- if( ilayer == 1 ) then
- ! sets ispec occurrences for first element layer in PML region based on absorbing boundary elements
- call PML_set_firstlayer()
- else
- ! adds an additional element layer based on adjacent elements on PML interface points
- call PML_add_layer()
- endif
-
- ! update global interface points of PML region to "regular" domain
- call PML_determine_interfacePoints()
-
- ! optional? update PML width according to dominant wavelength
- !call PML_get_width()
- ! checks with wavelength criteria
- !if( dominant_wavelength > 0.0 ) then
- ! if( PML_width > dominant_wavelength/2.0 ) then
- ! PML_LAYERS = ilayer
- ! exit
- ! else
- ! PML_LAYERS = ilayer + 1
- ! endif
- !endif
- enddo
-
- ! checks PML normals at edges and corners,
- ! tries to gather elements at edges & corners
- do ilayer=1,PML_LAYERS-1
- call PML_update_normals(ilayer)
- enddo
-
- ! updates statistics global PML width
- call PML_get_width()
-
- ! pre-calculates damping profiles on PML points
- ! damping coefficients
- call PML_set_local_dampingcoeff()
-
- ! pre-calculates derivatives of damping coefficients
- call PML_determine_dprime()
-
- ! wavefield array initialization
- allocate(chi1(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
- chi2(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
- chi2_t(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
- chi3(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
- chi4(NGLLX,NGLLY,NGLLZ,num_PML_ispec),stat=ier)
- if( ier /= 0 ) stop 'error allocating array chi1 etc.'
- allocate(chi1_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
- chi2_t_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
- chi3_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
- chi4_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),stat=ier)
- if( ier /= 0 ) stop 'error allocating array chi1_dot etc.'
- allocate(chi1_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
- chi2_t_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
- chi3_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
- chi4_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),stat=ier)
- if( ier /= 0 ) stop 'error allocating array chi1_dot_dot etc.'
-
- ! potentials
- chi1 = 0._CUSTOM_REAL
- chi2 = 0._CUSTOM_REAL
- chi2_t = 0._CUSTOM_REAL
- chi3 = 0._CUSTOM_REAL
- chi4 = 0._CUSTOM_REAL
-
- ! "velocity" potential
- chi1_dot = 0._CUSTOM_REAL
- chi2_t_dot = 0._CUSTOM_REAL
- chi3_dot = 0._CUSTOM_REAL
- chi4_dot = 0._CUSTOM_REAL
-
- ! "acceleration"/pressure potential
- chi1_dot_dot = 0._CUSTOM_REAL
- chi2_t_dot_dot = 0._CUSTOM_REAL
- chi3_dot_dot = 0._CUSTOM_REAL
- chi4_dot_dot = 0._CUSTOM_REAL
- if(FIX_UNDERFLOW_PROBLEM) then
- chi1_dot_dot = VERYSMALLVAL
- chi2_t_dot_dot = VERYSMALLVAL
- chi3_dot_dot = VERYSMALLVAL
- chi4_dot_dot = VERYSMALLVAL
- endif
-
- ! statistics user output
- d = maxval(abs(PML_damping_d(:,:,:,:)))
- if( d > TINYVAL ) then
- sign = maxval(PML_damping_d(:,:,:,:)) / maxval(abs(PML_damping_d(:,:,:,:)))
- else
- sign = 1.0
- endif
- dprime = maxval(abs(PML_damping_dprime(:,:,:,:)))
- call max_all_cr(d,d_glob)
- call max_all_cr(dprime,dprime_glob)
- call sum_all_i(num_PML_ispec,count)
- if( myrank == 0 ) then
- write(IMAIN,*)
- write(IMAIN,*) 'PML region: '
- write(IMAIN,*) ' total spectral elements:',count
- write(IMAIN,*) ' number of layers : ',PML_LAYERS
- write(IMAIN,*) ' dominant wavelength max: ',dominant_wavelength
- write(IMAIN,*) ' width min / max:',PML_width_min,PML_width_max
- write(IMAIN,*) ' reflection coefficient:',PML_damp_R
- write(IMAIN,*) ' maximum d : ',sign*d_glob
- write(IMAIN,*) ' maximum dprime : ',sign*dprime_glob
- write(IMAIN,*)
- endif
-
- ! VTK file output
- call PML_output_VTKs()
-
-end subroutine PML_initialize
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_set_firstlayer()
-
-! sets ispec occurrences for first element layer in PML region based on absorbing boundary elements
-
- use PML_par
- use specfem_par,only: NSPEC_AB,NGNOD, &
- abs_boundary_ispec,abs_boundary_normal,num_abs_boundary_faces,&
- abs_boundary_ijk,ibool
- use constants,only: NDIM,TINYVAL,NGNOD_EIGHT_CORNERS,NGLLX,NGLLY,NGLLZ,NGLLSQUARE
- implicit none
- ! local parameters
- real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: temp_ispec_pml_normal
- integer,dimension(:),allocatable:: temp_is_pml_elem
- integer:: iface,count,new_elemts,ispec,icorner,igll,iglobf,ier
- integer:: i,j,k,iglobcount,iglobcorners(NGNOD)
- integer,dimension(3,NGNOD_EIGHT_CORNERS),parameter :: ielem_corner_ijk = &
- reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ, &
- NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,NGNOD_EIGHT_CORNERS/))
-
-!! DK DK August 2012: added this when I added support for 27-node elements in the rest of the code
- if(NGNOD /= NGNOD_EIGHT_CORNERS) &
- stop 'the preliminary PML detection code of Daniel Peter currently works for 8-node bricks only; should be made more general'
-
- ! temporary arrays
- allocate(temp_is_pml_elem(NSPEC_AB), &
- temp_ispec_pml_normal(NDIM,NSPEC_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array temp_is_pml_elem'
-
- temp_is_pml_elem(:) = 0
- temp_ispec_pml_normal(:,:) = 0._CUSTOM_REAL
-
- count = 0
- do iface=1,num_abs_boundary_faces
- ! gets spectral elements with boundary face
- ispec = abs_boundary_ispec(iface)
-
- ! counts new PML elements
- if( temp_is_pml_elem(ispec) == 0 ) count = count + 1
-
- ! counts number of occurrences
- ! 1 : element with 1 face to regular one,
- ! 2 : element with 2 faces (elements at edges)
- ! 3 : element with 3 faces (elements at corners)
- temp_is_pml_elem(ispec) = temp_is_pml_elem(ispec) + 1
-
- ! adds contribution to element normal
- temp_ispec_pml_normal(:,ispec) = temp_ispec_pml_normal(:,ispec) + abs_boundary_normal(:,1,iface)
- enddo
- new_elemts = count
-
- ! doubling layers might have elements with only an edge on the absorbing surface
- ! poses problems if not accounted for
- count = 0
- do ispec = 1,NSPEC_AB
- ! only elements not recognized so far
- if( temp_is_pml_elem(ispec) > 0 ) cycle
-
- ! stores global indices of element corners
- do icorner=1,NGNOD
- i = ielem_corner_ijk(1,icorner)
- j = ielem_corner_ijk(2,icorner)
- k = ielem_corner_ijk(3,icorner)
- iglobcorners(icorner) = ibool(i,j,k,ispec)
- enddo
-
- ! checks if element has an edge (two corner points) on a absorbing boundary
- ! (refers mainly to elements in doubling layers)
- do iface=1,num_abs_boundary_faces
- ! checks if already encountered this element
- if( abs_boundary_ispec(iface) == ispec ) exit
-
- ! loops over face points
- iglobcount = 0
- do igll=1,NGLLSQUARE
- i = abs_boundary_ijk(1,igll,iface)
- j = abs_boundary_ijk(2,igll,iface)
- k = abs_boundary_ijk(3,igll,iface)
- iglobf = ibool(i,j,k,abs_boundary_ispec(iface))
- ! checks with corners
- do icorner=1,NGNOD
- if( iglobcorners(icorner) == iglobf ) iglobcount = iglobcount + 1
- enddo
- enddo
-
- ! adds as pml element
- if( iglobcount >= 2 ) then
- ! counter
- if( temp_is_pml_elem(ispec) == 0 ) count = count + 1
- temp_is_pml_elem(ispec) = temp_is_pml_elem(ispec) + 1
- ! updates normal
- temp_ispec_pml_normal(:,ispec) = temp_ispec_pml_normal(:,ispec) &
- + abs_boundary_normal(:,1,iface)
- exit
- endif
- enddo ! iface
-
- enddo
- new_elemts = new_elemts + count
-
- ! stores PML element indices and resulting normal
- call PML_set_elements(temp_is_pml_elem,temp_ispec_pml_normal,new_elemts)
-
- deallocate( temp_is_pml_elem)
- deallocate( temp_ispec_pml_normal)
-
-end subroutine PML_set_firstlayer
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_set_elements(temp_is_pml_elem,temp_ispec_pml_normal,new_elemts)
-
-! adds new elements to PML region
-
- use PML_par
- use specfem_par,only: NSPEC_AB,myrank
- use constants,only: NDIM,TINYVAL
- implicit none
-
- integer:: temp_is_pml_elem(NSPEC_AB)
- real(kind=CUSTOM_REAL):: temp_ispec_pml_normal(NDIM,NSPEC_AB)
- integer:: new_elemts
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: length
- integer :: ispec,ispecPML,ier
-
- ! sets new element type flags
- ispec_is_PML_inum(:) = temp_is_pml_elem(:)
-
- ! sets new number of elements
- num_PML_ispec = new_elemts
-
- ! re-allocates arrays
- if( allocated(PML_normal) ) deallocate(PML_normal)
- if( allocated(PML_ispec) ) deallocate(PML_ispec)
- allocate(PML_ispec(num_PML_ispec), &
- PML_normal(NDIM,num_PML_ispec),stat=ier)
- if( ier /= 0 ) stop 'error allocating array PML_ispec'
- PML_normal(:,:) = 0.0_CUSTOM_REAL
- PML_ispec(:) = 0
-
- ! stores PML elements flags and normals
- ispecPML = 0
- do ispec=1,NSPEC_AB
- if( ispec_is_PML_inum(ispec) > 0 ) then
- ! stores indices
- ispecPML = ispecPML+1
- PML_ispec(ispecPML) = ispec
-
- ! gets resulting element normal
- PML_normal(:,ispecPML) = temp_ispec_pml_normal(:,ispec)
-
- ! normalizes normal
- length = sqrt( PML_normal(1,ispecPML)**2 &
- + PML_normal(2,ispecPML)**2 &
- + PML_normal(3,ispecPML)**2 )
- if( length < TINYVAL ) then
- print*,'error set elements: normal length:',length
- print*,'elem:',ispec,ispecPML
- print*,'num_pml_ispec:',num_PML_ispec
- call exit_mpi(myrank,'error PML normal length')
- else
- ! normalizes normal
- PML_normal(:,ispecPML) = PML_normal(:,ispecPML)/length
- endif
- endif
- enddo
- if( ispecPML /= num_PML_ispec) call exit_mpi(myrank,'PML add layer count error')
-
-end subroutine PML_set_elements
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_determine_interfacePoints()
-
-! finds global interface points of PML region to "regular" domain
-
- use specfem_par,only: ibool,NGLOB_AB,NSPEC_AB, &
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
- my_neighbours_ext_mesh,NPROC
- use PML_par
- use PML_par_acoustic
- use constants,only: NGLLX,NGLLY,NGLLZ
- implicit none
-
- ! local parameters
- integer,dimension(:),allocatable:: temp_regulardomain
- integer:: i,j,k,ispec,iglob,ier
-
- ! PML interface points array
- iglob_is_PML_interface(:) = 0
-
- ! temporary arrays
- allocate(temp_regulardomain(NGLOB_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array temp_regulardomain'
- temp_regulardomain(:) = 0
-
- ! global PML points
- iglob_is_PML(:) = 0
-
- ! sets flags on PML and regular domain points
- do ispec=1,NSPEC_AB
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- ! sets flag for PML/regular domain
- if( ispec_is_PML_inum(ispec) > 0 ) then
- ! global points
- iglob_is_PML(iglob) = iglob_is_PML(iglob) + 1
- else
- ! not a PML point
- temp_regulardomain(iglob) = temp_regulardomain(iglob) + 1
- endif
- enddo
- enddo
- enddo
- enddo
-
- ! assemble on MPI interfaces
- call assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,iglob_is_PML, &
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh)
- call assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,temp_regulardomain, &
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh)
-
- ! stores interface points
- do ispec=1,NSPEC_AB
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- ! checks if it belongs to both, PML and regular domain
- if( temp_regulardomain(iglob) > 0 .and. iglob_is_PML(iglob) > 0 ) then
- ! increases flag on global point
- iglob_is_PML_interface(iglob) = iglob_is_PML_interface(iglob) + 1
- endif
- enddo
- enddo
- enddo
- enddo
-
- deallocate(temp_regulardomain)
-
-end subroutine PML_determine_interfacePoints
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
-subroutine PML_get_width()
-
-! calculates PML width for statistics
-
- use specfem_par,only: abs_boundary_ispec,abs_boundary_ijk,&
- num_abs_boundary_faces,&
- ibool,xstore,ystore,zstore,myrank, &
- NGLOB_AB
- use PML_par
- use constants,only: NGLLSQUARE,TINYVAL,HUGEVAL
- implicit none
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: length,width
- integer:: i,j,k,ispec,iglob,iface,igll,iglobf
-
- ! determines global PML width
- ! loops over domain surface
- width = HUGEVAL
- do iface=1,num_abs_boundary_faces
-
- ispec = abs_boundary_ispec(iface)
-
- ! avoids taking corner or edge elements for width
- if( ispec_is_PML_inum(ispec) > 1 ) cycle
-
- ! determines smallest distance to interface points
- do iglob=1,NGLOB_AB
- if( iglob_is_PML_interface(iglob) > 0 ) then
- ! loops over face points
- do igll=1,NGLLSQUARE
- i = abs_boundary_ijk(1,igll,iface)
- j = abs_boundary_ijk(2,igll,iface)
- k = abs_boundary_ijk(3,igll,iface)
-
- ! takes distance between two points
- iglobf = ibool(i,j,k,ispec)
- length = sqrt((xstore(iglobf)-xstore(iglob))**2 &
- + (ystore(iglobf)-ystore(iglob))**2 &
- + (zstore(iglobf)-zstore(iglob))**2 )
-
- ! checks length
- if( length < TINYVAL ) then
- print*,'PML:',myrank,'length:',length
- print*,' ijk:',i,j,k,ispec,'face:',iface,'iglob:',iglobf
- print*,' ijk xyz:',xstore(iglobf),ystore(iglobf),zstore(iglobf)
- print*,' iglob interface',iglob
- print*,' iglob xyz:',xstore(iglob),ystore(iglob),zstore(iglob)
- call exit_mpi(myrank,'PML length zero error')
- endif
-
- ! updates minimum width
- if( length < width ) width = length
-
- enddo
- endif
- enddo
- enddo
-
- ! determines maximum width on all MPI processes
- ! all process gets overall maximum
- call max_all_all_cr(width,PML_width_max)
- call min_all_all_cr(width,PML_width_min)
-
- ! sets PML width
- if( PML_width_min > TINYVAL ) then
- PML_width = PML_width_min
- else
- PML_width = PML_width_max
- endif
-
- ! checks
- if( PML_width < TINYVAL ) call exit_mpi(myrank,'PML width error: width too small')
-
-end subroutine PML_get_width
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_set_local_dampingcoeff()
-
-! calculates damping profiles on PML points
-
- use specfem_par,only: ibool,xstore,ystore,zstore,myrank, &
- kappastore,mustore,NGLOB_AB,&
- abs_boundary_ispec,abs_boundary_ijk,num_abs_boundary_faces
- use specfem_par_acoustic,only: ACOUSTIC_SIMULATION,rhostore
- use specfem_par_elastic,only: ELASTIC_SIMULATION,rho_vp
- use PML_par
- use constants,only: NGLLX,NGLLY,NGLLZ,HUGEVAL,FOUR_THIRDS,NGLLSQUARE,TINYVAL
- implicit none
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: length
- real(kind=CUSTOM_REAL) :: dist,vp
- real(kind=CUSTOM_REAL) :: d
- real(kind=CUSTOM_REAL) :: width
-
- integer:: i,j,k,ispec,iglob,ispecPML,iglobf,ier
- integer:: ispecB,igll,iface
-
- ! stores damping coefficient
- allocate( PML_damping_d(NGLLX,NGLLY,NGLLZ,num_PML_ispec),stat=ier)
- if( ier /= 0 ) stop 'error allocating array PML_damping_d'
- PML_damping_d(:,:,:,:) = 0._CUSTOM_REAL
-
- ! loops over all PML elements
- do ispecPML=1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
-
- ! determines smallest distance to interface points
- ! and determines smallest distance to absorbing boundary points
- ! (note: MPI partitioning not considered here yet; might be a problem)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- ! global index
- iglobf = ibool(i,j,k,ispec)
-
- ! ensures that PML interface points have zero damping coefficients
- if( iglob_is_PML_interface(iglobf) > 0 ) then
- PML_damping_d(i,j,k,ispecPML) = 0._CUSTOM_REAL
- cycle
- endif
-
- ! distance to PML interface points
- dist = HUGEVAL
- do iglob=1,NGLOB_AB
- if( iglob_is_PML_interface(iglob) > 0 ) then
- ! distance to interface
- length = (xstore(iglobf)-xstore(iglob))**2 &
- + (ystore(iglobf)-ystore(iglob))**2 &
- + (zstore(iglobf)-zstore(iglob))**2
- if( length < dist ) dist = length
- endif
- enddo !iglob
- !dist = distances(i,j,k)
- if( dist >= HUGEVAL ) then
- dist = PML_width_max
- else
- dist = sqrt( dist )
- endif
-
- ! distance to boundary points
- width = HUGEVAL
- do iface=1,num_abs_boundary_faces
- ispecB = abs_boundary_ispec(iface)
- do igll=1,NGLLSQUARE
- iglob = ibool(abs_boundary_ijk(1,igll,iface),&
- abs_boundary_ijk(2,igll,iface),&
- abs_boundary_ijk(3,igll,iface),ispecB)
- ! distance to boundary
- length = (xstore(iglobf)-xstore(iglob))**2 &
- + (ystore(iglobf)-ystore(iglob))**2 &
- + (zstore(iglobf)-zstore(iglob))**2
- if( length < width ) width = length
- enddo
- enddo ! iface
- ! apparent width of PML for this point
- if( width >= HUGEVAL ) then
- width = PML_width_max
- else
- width = sqrt( width ) + dist
- endif
-
- ! checks width
- if( width < TINYVAL ) then
- print*,'error: pml width ',width
- print*,'ijk:',ispec,i,j,k
- print*,'xyz:',xstore(ibool(i,j,k,ispec)),ystore(ibool(i,j,k,ispec)),zstore(ibool(i,j,k,ispec))
- print*,'dist:',dist
- print*,'pml min/max:',PML_width_max,PML_width_min
- call exit_mpi(myrank,'PML error getting width')
- endif
-
- ! P-velocity
- if( ACOUSTIC_SIMULATION ) then
- vp = sqrt( kappastore(i,j,k,ispec)/rhostore(i,j,k,ispec) )
- else if( ELASTIC_SIMULATION ) then
- vp = (FOUR_THIRDS * mustore(i,j,k,ispec) + kappastore(i,j,k,ispec)) &
- / rho_vp(i,j,k,ispec)
- else
- call exit_mpi(myrank,'PML error getting vp')
- endif
-
- ! gets damping coefficient
- call PML_damping_profile_l(d,dist,vp,width)
-
- ! stores d & dprime for this element's GLL points
- PML_damping_d(i,j,k,ispecPML) = d
-
- enddo
- enddo
- enddo
- enddo !ispecPML
-
-end subroutine PML_set_local_dampingcoeff
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_determine_dprime()
-
-! calculates derivatives dprime of damping coefficients on GLL points
-
- use PML_par
- use PML_par_acoustic
- use constants,only: NGLLX,NGLLY,NGLLZ
- use specfem_par,only: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,&
- hprime_xx,hprime_yy,hprime_zz
- implicit none
- ! local parameters
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLZ,NGLLZ) :: dprime_elem
- real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
- real(kind=CUSTOM_REAL) :: nx,ny,nz
- real(kind=CUSTOM_REAL) :: d_dx,d_dy,d_dz,tempd_dx,tempd_dy,tempd_dz
- integer :: ispec,i,j,k,l,ispecPML,ier
-
- ! dprime derivatives
- allocate( PML_damping_dprime(NGLLX,NGLLY,NGLLZ,num_PML_ispec),stat=ier)
- if( ier /= 0 ) stop 'error allocating array PML_damping_dprime'
- PML_damping_dprime(:,:,:,:) = 0._CUSTOM_REAL
-
- ! loops over all PML elements
- do ispecPML=1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
-
- ! PML normal
- nx = PML_normal(1,ispecPML)
- ny = PML_normal(2,ispecPML)
- nz = PML_normal(3,ispecPML)
-
- ! calculates terms:
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- ! derivative along x, y, z
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the loops because NGLLX == NGLLY == NGLLZ
- tempd_dx = 0._CUSTOM_REAL
- tempd_dy = 0._CUSTOM_REAL
- tempd_dz = 0._CUSTOM_REAL
- do l = 1,NGLLX
- tempd_dx = tempd_dx + PML_damping_d(l,j,k,ispecPML)*hprime_xx(i,l)
- tempd_dy = tempd_dy + PML_damping_d(i,l,k,ispecPML)*hprime_yy(j,l)
- tempd_dz = tempd_dz + PML_damping_d(i,j,l,ispecPML)*hprime_zz(k,l)
- enddo
-
- ! get derivatives of potential with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
-
- ! derivatives dprime
- d_dx = xixl*tempd_dx + etaxl*tempd_dy + gammaxl*tempd_dz
- d_dy = xiyl*tempd_dx + etayl*tempd_dy + gammayl*tempd_dz
- d_dz = xizl*tempd_dx + etazl*tempd_dy + gammazl*tempd_dz
- dprime_elem(i,j,k) = d_dx*nx + d_dy*ny + d_dz*nz
-
- enddo
- enddo
- enddo
-
- ! stores dprime coefficients
- PML_damping_dprime(:,:,:,ispecPML) = dprime_elem(:,:,:)
-
- enddo
-
-end subroutine PML_determine_dprime
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_add_layer()
-
-! adds an element layer to the PML region
-
- use PML_par
- use specfem_par,only: NSPEC_AB,NGLOB_AB, &
- ibool,myrank,&
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
- my_neighbours_ext_mesh,NPROC,NGNOD2D
- use constants,only: NDIM,TINYVAL,NGLLX,NGLLY,NGLLZ
- implicit none
-
- ! local parameters
- real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: iglob_pml_normal
- real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: ispec_pml_normal
- integer,dimension(:),allocatable:: is_pml_elem
- integer:: i,j,k,iglob,count,ispecPML,ispec,new_elemts,ier
- integer :: iface,icorner,ipmlcorners
-
- integer,dimension(3,4),parameter :: iface1_corner_ijk = &
- reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
- integer,dimension(3,4),parameter :: iface2_corner_ijk = &
- reshape((/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
- integer,dimension(3,4),parameter :: iface3_corner_ijk = &
- reshape((/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
- integer,dimension(3,4),parameter :: iface4_corner_ijk = &
- reshape((/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
- integer,dimension(3,4),parameter :: iface5_corner_ijk = &
- reshape((/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
- integer,dimension(3,4),parameter :: iface6_corner_ijk = &
- reshape((/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
- integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
- reshape((/ iface1_corner_ijk,iface2_corner_ijk, &
- iface3_corner_ijk,iface4_corner_ijk, &
- iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
- ! midpoint indices for each face (xmin,xmax,ymin,ymax,zmin,zmax)
- integer,dimension(3,6),parameter :: iface_all_midpointijk = &
- reshape( (/ 1,2,2, NGLLX,2,2, 2,1,2, 2,NGLLY,2, 2,2,1, 2,2,NGLLZ /),(/3,6/))
- logical :: is_done
-
- ! temporary arrays
- allocate(is_pml_elem(NSPEC_AB), &
- iglob_pml_normal(NDIM,NGLOB_AB), &
- ispec_pml_normal(NDIM,NSPEC_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array is_pml_elem etc.'
- iglob_pml_normal(:,:) = 0._CUSTOM_REAL
- ispec_pml_normal(:,:) = 0._CUSTOM_REAL
-
- ! sets pml normals on PML interface, global points
- do ispecPML=1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
- ! checks
- if( ispec_is_PML_inum(ispec) < 1 ) call exit_mpi(myrank,'PML error add ispec layer')
-
- ! starts from first layer elements
- ! stores normal information on temporary global points
- if( ispec_is_PML_inum(ispec) >= 1 ) then
- ! stores PML normal on interface points
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- if( iglob_is_PML_interface(iglob) > 0 ) then
- iglob_pml_normal(:,iglob) = iglob_pml_normal(:,iglob) + PML_normal(:,ispecPML)
- endif
- enddo
- enddo
- enddo
- endif
-
- enddo
-
- ! assembles with other MPI processes
- call assemble_MPI_vector_ext_mesh(NPROC,NGLOB_AB,iglob_pml_normal, &
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
- my_neighbours_ext_mesh)
-
-
- ! adds new elements sharing PML interface
- count = 0
- is_pml_elem(:) = 0
- do ispec=1,NSPEC_AB
-
- ! checks if we already have this element set as pml element in first layer
- is_done = .false.
- do ispecPML=1,num_PML_ispec
- if( PML_ispec(ispecPML) == ispec ) then
- ! adds as pml element
- if(is_pml_elem(ispec) == 0) count = count + 1
- ! copies normal
- ispec_pml_normal(:,ispec) = PML_normal(:,ispecPML)
- ! copies element type flag
- is_pml_elem(ispec) = ispec_is_PML_inum(ispec)
-
- is_done = .true.
- exit
- endif
- enddo
- if( is_done ) cycle
-
- ! loops over element faces
- do iface=1,6
- ipmlcorners = 0
- do icorner=1,NGNOD2D
- i = iface_all_corner_ijk(1,icorner,iface)
- j = iface_all_corner_ijk(2,icorner,iface)
- k = iface_all_corner_ijk(3,icorner,iface)
- iglob = ibool(i,j,k,ispec)
- if( iglob_is_PML_interface(iglob) > 0 ) ipmlcorners = ipmlcorners + 1
- enddo
-
- ! face is pml interface
- if( ipmlcorners == NGNOD2D ) then
- ! counts new pml elements
- if(is_pml_elem(ispec) == 0) count = count + 1
-
- ! increments flag
- is_pml_elem(ispec) = is_pml_elem(ispec) + 1
-
- ! sets normal
- ! reference midpoint on face
- i = iface_all_midpointijk(1,iface)
- j = iface_all_midpointijk(2,iface)
- k = iface_all_midpointijk(3,iface)
- iglob = ibool(i,j,k,ispec)
- if( iglob_is_PML_interface(iglob) < 1 ) call exit_mpi(myrank,'PML error midpoint interface')
-
- ! checks new normal
- if( sqrt(iglob_pml_normal(1,iglob)**2+iglob_pml_normal(2,iglob)**2 &
- +iglob_pml_normal(3,iglob)**2) < TINYVAL ) then
- print*,'error add layer: normal length zero: iglob',iglob
- print*,'face ',iface,ipmlcorners
- print*,'ijk ispec',i,j,k,ispec
- call exit_mpi(myrank,'PML add layer has new normal length error')
- endif
-
- ! adds contribution to normal
- ispec_pml_normal(:,ispec) = ispec_pml_normal(:,ispec) + iglob_pml_normal(:,iglob)
- endif
-
- enddo ! iface
- enddo ! ispec
- new_elemts = count
-
- ! adds new pml elements to PML region
- call PML_set_elements(is_pml_elem,ispec_pml_normal,new_elemts)
-
-end subroutine PML_add_layer
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_update_normals(ilayer)
-
-! updates normal's directions for elements in PML region
-
- use PML_par
- use specfem_par,only: NSPEC_AB,NGLOB_AB,ibool,myrank,NGNOD2D
- use constants,only: NGLLX,NGLLY,NGLLZ
- implicit none
- integer :: ilayer
-
- ! local parameters
- integer:: iglob,ispecPML,ispec
- integer :: iface,icorner
- integer :: ipmlcorners,ipmledges,ipmlsngl
- integer :: ipmlcorners_tot,ipmledges_tot,ipmlsngl_tot
-
- integer,dimension(3,4),parameter :: iface1_corner_ijk = &
- reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
- integer,dimension(3,4),parameter :: iface2_corner_ijk = &
- reshape((/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
- integer,dimension(3,4),parameter :: iface3_corner_ijk = &
- reshape((/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
- integer,dimension(3,4),parameter :: iface4_corner_ijk = &
- reshape((/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
- integer,dimension(3,4),parameter :: iface5_corner_ijk = &
- reshape((/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
- integer,dimension(3,4),parameter :: iface6_corner_ijk = &
- reshape((/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
- integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
- reshape((/ iface1_corner_ijk,iface2_corner_ijk, &
- iface3_corner_ijk,iface4_corner_ijk, &
- iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
- integer:: ispecngb,iadj,ipmlinterface,ier
- integer :: ispecPMLngb_corner,ispecPMLngb_edge,ispecPMLngb_sngl
- integer,dimension(:),allocatable :: iglob_nadj,ispec_is_PML_inum_org
- integer,dimension(:,:,:),allocatable :: iglob_adj
-
-
- ! checks normals for elements adjacent to edge/corner elements
- ! assigns element information to each global point
- ! (note: mpi partitioning/interface between elements not considered yet)
- allocate(iglob_nadj(NGLOB_AB),iglob_adj(2,32,NGLOB_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array iglob_nadj'
- iglob_nadj(:) = 0
- iglob_adj(:,:,:) = 0
- do ispecPML=1,num_PML_ispec
- ispec = PML_ispec(ispecPML)
- ! sets element corners
- do iface=1,2
- do icorner=1,NGNOD2D
- iglob = ibool(iface_all_corner_ijk(1,icorner,iface),&
- iface_all_corner_ijk(2,icorner,iface),&
- iface_all_corner_ijk(3,icorner,iface),ispec)
- ! number of occurrences
- iglob_nadj(iglob) = iglob_nadj(iglob) + 1
- ! first parameter is assigned element id ispec
- iglob_adj(1,iglob_nadj(iglob),iglob) = ispec
- ! second parameter is corresponding pml element id ispecPML
- iglob_adj(2,iglob_nadj(iglob),iglob) = ispecPML
- enddo
- enddo
- enddo
- if( maxval(iglob_nadj(:)) > 32 ) then
- print*,'info neighbors:',myrank
- print*,'max number of adjacents:',maxval(iglob_nadj(:)),maxloc(iglob_nadj(:))
- call exit_mpi(myrank,'error iglob number of adj')
- endif
-
- ! finds neighbors based on common nodes and changes type and normal accordingly
- ! for edges and corners
- allocate(ispec_is_PML_inum_org(NSPEC_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array ispec_is_PML_inum_org'
- ispec_is_PML_inum_org(:) = ispec_is_PML_inum(:)
- do ispecPML=1,num_PML_ispec
- ispec = PML_ispec(ispecPML)
-
- ! only non-corner elements
- if( ispec_is_PML_inum_org(ispec) <= 2 ) then
- ipmlsngl_tot = 0
- ipmlcorners_tot = 0
- ipmledges_tot = 0
- ipmlinterface = 0
- ispecPMLngb_edge = 0
- ispecPMLngb_corner = 0
- ispecPMLngb_sngl = 0
- ! loops over element corners
- do iface=1,2
- ! checks corner neighbors
- do icorner=1,NGNOD2D
- iglob = ibool(iface_all_corner_ijk(1,icorner,iface),&
- iface_all_corner_ijk(2,icorner,iface),&
- iface_all_corner_ijk(3,icorner,iface),ispec)
- ! adjacent elements
- ipmlsngl = 0
- ipmlcorners = 0
- ipmledges = 0
- do iadj=1,iglob_nadj(iglob)
- ispecngb = iglob_adj(1,iadj,iglob)
- if( ispecngb /= ispec ) then
- ! counts single normal neighbors
- if( ispec_is_PML_inum_org(ispecngb) == 1 ) then
- ipmlsngl = ipmlsngl + 1
- ispecPMLngb_sngl = iglob_adj(2,iadj,iglob)
- endif
- ! counts corner neighbors
- if( ispec_is_PML_inum_org(ispecngb) == 3 ) then
- ipmlcorners = ipmlcorners + 1
- ispecPMLngb_corner = iglob_adj(2,iadj,iglob)
- endif
- ! counts edge neighbors
- if( ispec_is_PML_inum_org(ispecngb) == 2 ) then
- ipmledges = ipmledges + 1
- ispecPMLngb_edge = iglob_adj(2,iadj,iglob)
- endif
- endif
- enddo
- if( ipmlsngl > 0 ) ipmlsngl_tot = ipmlsngl_tot + 1
- if( ipmlcorners > 0 ) ipmlcorners_tot = ipmlcorners_tot + 1
- if( ipmledges > 0 ) ipmledges_tot = ipmledges_tot + 1
-
- ! interface points
- if( iglob_is_PML_interface(iglob) > 0 ) ipmlinterface = ipmlinterface + 1
-
- enddo !icorner
- enddo
-
- ! elements inside PML
- if( ipmlinterface < 4 ) then
-
- ! shares two faces with edge elements, so it becomes an edge element too
- if( ispec_is_PML_inum_org(ispec) == 1 ) then
- if( ipmledges_tot >= 6 ) then
- ispec_is_PML_inum(ispec) = 2
- PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_edge)
- endif
- if( ipmlcorners_tot >= 5 ) then
- ispec_is_PML_inum(ispec) = 3
- PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_corner)
- endif
- else if( ispec_is_PML_inum_org(ispec) == 2 ) then
-
- ! shares at least a face and a face edge with a corner element,
- ! so it becomes a corner element too
- if( ipmlcorners_tot >= 5 ) then
- ispec_is_PML_inum(ispec) = 3
- PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_corner)
- endif
- endif
- endif
- ! avoid elements between two edges and next to corner to become edge elements
- if( ispec_is_PML_inum(ispec) == 2 .and. ilayer > 1 ) then
- if( ipmlsngl_tot == 8 .and. ipmlcorners_tot == 2 ) then
- ispec_is_PML_inum(ispec) = 1
- PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_sngl)
- endif
- endif
-
- endif
- enddo
- deallocate(iglob_adj,iglob_nadj)
- deallocate(ispec_is_PML_inum_org)
-
-end subroutine PML_update_normals
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_output_VTKs()
-
-! outputs informations about PML elements
-
- use PML_par
- use specfem_par,only: NGLOB_AB,NSPEC_AB,myrank, &
- prname,ibool,xstore,ystore,zstore
- use constants,only: NGLLX,NGLLY,NGLLZ,IMAIN
- implicit none
- ! local parameters
- real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: ispec_normal
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable:: temp_gllvalues
- integer,dimension(:),allocatable :: temp_iglob
- integer :: count,iglob,ispecPML,ispec,ier
- character(len=256) :: vtkfilename
-
- ! element type flags
- if( .false. ) then
- vtkfilename = prname(1:len_trim(prname))//'PML_ispec_inum'
- call write_VTK_data_elem_i(NSPEC_AB,NGLOB_AB,xstore,ystore,zstore,ibool,&
- ispec_is_PML_inum,vtkfilename)
- endif
-
- ! interface points
- if( .false. ) then
- ! puts global points in a temporary array for plotting
- count = 0
- do iglob=1,NGLOB_AB
- if( iglob_is_PML_interface(iglob) > 0 ) then
- count = count+1
- endif
- enddo
- allocate(temp_iglob(count),stat=ier)
- if( ier /= 0 ) stop 'error allocating array temp_iglob'
- count = 0
- do iglob=1,NGLOB_AB
- if( iglob_is_PML_interface(iglob) > 0 ) then
- count = count+1
- temp_iglob(count) = iglob
- endif
- enddo
- vtkfilename = prname(1:len_trim(prname))//'PML_interface_points'
- call write_VTK_data_points(NGLOB_AB,xstore,ystore,zstore, &
- temp_iglob,count,vtkfilename)
- deallocate(temp_iglob)
- endif
-
- ! pml normals
- if( .false. ) then
- allocate(ispec_normal(3,NSPEC_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array ispec_normal'
- ispec_normal(:,:) = 0._CUSTOM_REAL
- do ispecPML=1,num_PML_ispec
- ispec = PML_ispec(ispecPML)
- ispec_normal(:,ispec) = PML_normal(:,ispecPML)
- enddo
- vtkfilename = prname(1:len_trim(prname))//'PML_normals'
- call write_VTK_data_elem_vectors(NSPEC_AB,NGLOB_AB,xstore,ystore,zstore,ibool, &
- ispec_normal,vtkfilename)
- deallocate(ispec_normal)
- endif
-
- ! pml damping coefficients
- if( .false. ) then
- allocate(temp_gllvalues(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array temp_gllvalues'
- temp_gllvalues = 0._CUSTOM_REAL
- do ispecPML=1,num_PML_ispec
- ispec = PML_ispec(ispecPML)
- temp_gllvalues(:,:,:,ispec) = PML_damping_d(:,:,:,ispecPML)
- enddo
- vtkfilename = prname(1:len_trim(prname))//'PML_damping_d'
- call write_VTK_data_gll_cr(NSPEC_AB,NGLOB_AB, &
- xstore,ystore,zstore,ibool, &
- temp_gllvalues,vtkfilename)
- deallocate(temp_gllvalues)
- endif ! VTK file output
-
- if(myrank == 0) write(IMAIN,*)
-
-end subroutine PML_output_VTKs
-
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -57,14 +57,13 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
- use PML_par
- use PML_par_acoustic
+
implicit none
+
! local parameters
integer:: iphase
logical:: phase_is_inner
-
! enforces free surface (zeroes potentials at free surface)
if(.NOT. GPU_MODE) then
! on CPU
@@ -84,32 +83,6 @@
call acoustic_enforce_free_surf_cuda(Mesh_pointer,ABSORB_INSTEAD_OF_FREE_SURFACE)
endif
- if(ABSORB_USE_PML .and. ABSORBING_CONDITIONS) then
- ! enforces free surface on PML elements
-
- ! note:
- ! PML routines are not implemented as CUDA kernels, we just transfer the fields
- ! from the GPU to the CPU and vice versa
-
- ! transfers potentials to the CPU
- if(GPU_MODE) call transfer_fields_ac_from_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
-
- call PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
- ibool,free_surface_ijk,free_surface_ispec, &
- num_free_surface_faces,ispec_is_acoustic, &
- num_PML_ispec,PML_ispec,&
- chi1,chi2,chi2_t,chi3,chi4,&
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi2_t_dot_dot,&
- chi3_dot_dot,chi4_dot_dot)
-
- ! transfers potentials back to GPU
- if(GPU_MODE) call transfer_fields_ac_to_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
- endif
-
! distinguishes two runs: for elements on MPI interfaces, and elements within the partitions
do iphase=1,2
@@ -124,24 +97,28 @@
if(.NOT. GPU_MODE) then
! on CPU
call compute_forces_acoustic_pot( iphase, NSPEC_AB,NGLOB_AB, &
- potential_acoustic,potential_dot_dot_acoustic, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz, &
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- rhostore,jacobian,ibool, &
+ rhostore,jacobian,ibool,deltat, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic,&
phase_ispec_inner_acoustic )
! adjoint simulations
if( SIMULATION_TYPE == 3 ) &
call compute_forces_acoustic_pot( iphase, NSPEC_ADJOINT,NGLOB_ADJOINT, &
- b_potential_acoustic,b_potential_dot_dot_acoustic, &
+ b_potential_acoustic,b_potential_dot_acoustic,b_potential_dot_dot_acoustic, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz, &
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- rhostore,jacobian,ibool, &
+ rhostore,jacobian,ibool,deltat, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic,&
phase_ispec_inner_acoustic )
else
@@ -151,68 +128,17 @@
nspec_outer_acoustic, nspec_inner_acoustic)
endif
- if(ABSORB_USE_PML .and. ABSORBING_CONDITIONS) then
- ! transfers potentials to CPU
- if(GPU_MODE) call transfer_fields_ac_from_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
-
- call compute_forces_acoustic_PML(NSPEC_AB,NGLOB_AB, &
- ibool,ispec_is_inner,phase_is_inner, &
- rhostore,ispec_is_acoustic,potential_acoustic, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian,&
- wxgll,wygll,wzgll,&
- PML_damping_dprime,num_PML_ispec,&
- PML_ispec,PML_normal,&
- chi1_dot_dot,chi2_t_dot_dot,&
- chi3_dot_dot,chi4_dot_dot)
-
- ! couples potential_dot_dot with PML interface contributions
- call PML_acoustic_interface_coupling(phase_is_inner,NSPEC_AB,NGLOB_AB,&
- potential_dot_dot_acoustic,&
- ibool,ispec_is_inner,ispec_is_acoustic,&
- num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
- chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
-
- ! transfers potentials back to GPU
- if(GPU_MODE) call transfer_fields_ac_to_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
-
- endif ! PML
-
- ! absorbing boundaries
+ ! ! Stacey absorbing boundary conditions
if(ABSORBING_CONDITIONS) then
- if(ABSORB_USE_PML) then
- if( PML_USE_SOMMERFELD ) then
- ! adds a Sommerfeld condition on the domain's absorbing boundaries
- call PML_acoustic_abs_boundaries(phase_is_inner,NSPEC_AB,NGLOB_AB,&
- abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
- num_abs_boundary_faces, &
- kappastore,ibool,ispec_is_inner, &
- rhostore,ispec_is_acoustic,&
- potential_dot_acoustic,potential_dot_dot_acoustic,&
- num_PML_ispec,PML_ispec,ispec_is_PML_inum,&
- chi1_dot,chi2_t,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
-
- ! transfers potentials back to GPU
- if(GPU_MODE) call transfer_fields_ac_to_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
- endif
- else
- ! Stacey boundary conditions
- call compute_stacey_acoustic(NSPEC_AB,NGLOB_AB, &
- potential_dot_dot_acoustic,potential_dot_acoustic, &
- ibool,ispec_is_inner,phase_is_inner, &
- abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
- num_abs_boundary_faces,rhostore,kappastore,ispec_is_acoustic, &
- SIMULATION_TYPE,SAVE_FORWARD,NSTEP,it,NGLOB_ADJOINT, &
- b_potential_dot_dot_acoustic,b_reclen_potential, &
- b_absorb_potential,b_num_abs_boundary_faces, &
- GPU_MODE,Mesh_pointer)
- endif
+ call compute_stacey_acoustic(NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic,potential_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces,rhostore,kappastore,ispec_is_acoustic, &
+ SIMULATION_TYPE,SAVE_FORWARD,NSTEP,it,NGLOB_ADJOINT, &
+ b_potential_dot_dot_acoustic,b_reclen_potential, &
+ b_absorb_potential,b_num_abs_boundary_faces, &
+ GPU_MODE,Mesh_pointer)
endif
! elastic coupling
@@ -403,25 +329,6 @@
call kernel_3_a_acoustic_cuda(Mesh_pointer,NGLOB_AB)
endif
-
- if(ABSORB_USE_PML .and. ABSORBING_CONDITIONS) then
- ! note: no need to transfer fields between CPU and GPU;
- ! PML arrays are all handled on the CPU
-
- ! divides local contributions with mass term
- call PML_acoustic_mass_update(NSPEC_AB,NGLOB_AB,&
- ispec_is_acoustic,rmass_acoustic,ibool,&
- num_PML_ispec,PML_ispec,&
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
-
- ! Newmark time scheme corrector terms
- call PML_acoustic_time_corrector(NSPEC_AB,ispec_is_acoustic,deltatover2,&
- num_PML_ispec,PML_ispec,PML_damping_d,&
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
- endif
-
-
! update velocity
! note: Newmark finite-difference time scheme with acoustic domains:
! (see e.g. Hughes, 1987; Chaljub et al., 2003)
@@ -450,30 +357,6 @@
call kernel_3_b_acoustic_cuda(Mesh_pointer,NGLOB_AB,deltatover2,b_deltatover2)
endif
- ! updates potential_dot_acoustic and potential_dot_dot_acoustic inside PML region for plotting seismograms/movies
- if(ABSORB_USE_PML .and. ABSORBING_CONDITIONS) then
- ! transfers potentials to CPU
- if(GPU_MODE) call transfer_fields_ac_from_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
-
- call PML_acoustic_update_potentials(NGLOB_AB,NSPEC_AB, &
- ibool,ispec_is_acoustic, &
- potential_dot_acoustic,potential_dot_dot_acoustic,&
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh,NPROC,&
- num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
- PML_mask_ibool,PML_damping_d,&
- chi1,chi2,chi2_t,chi3,&
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
-
- ! transfers potentials to GPU
- if(GPU_MODE) call transfer_fields_ac_to_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
-
- endif
-
! enforces free surface (zeroes potentials at free surface)
if(.NOT. GPU_MODE) then
! on CPU
@@ -499,35 +382,12 @@
call acoustic_enforce_free_surf_cuda(Mesh_pointer,ABSORB_INSTEAD_OF_FREE_SURFACE)
endif
-
- if(ABSORB_USE_PML .and. ABSORBING_CONDITIONS) then
- ! enforces free surface on PML elements
- if( GPU_MODE ) call transfer_fields_ac_from_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
-
- call PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
- ibool,free_surface_ijk,free_surface_ispec, &
- num_free_surface_faces, &
- ispec_is_acoustic, &
- num_PML_ispec,PML_ispec,&
- chi1,chi2,chi2_t,chi3,chi4,&
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi2_t_dot_dot,&
- chi3_dot_dot,chi4_dot_dot)
-
- if( GPU_MODE ) call transfer_fields_ac_to_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
- endif
-
end subroutine compute_forces_acoustic
-
!
!-------------------------------------------------------------------------------------------------
!
-
subroutine acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB,ABSORB_INSTEAD_OF_FREE_SURFACE, &
potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
ibool,free_surface_ijk,free_surface_ispec, &
Deleted: seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic_PML.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic_PML.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic_PML.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -1,1194 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D V e r s i o n 2 . 1
-! ---------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA and CNRS / INRIA / University of Pau
-! (c) Princeton University / California Institute of Technology and CNRS / INRIA / University of Pau
-! July 2012
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-subroutine compute_forces_acoustic_PML(NSPEC_AB,NGLOB_AB, &
- ibool,ispec_is_inner,phase_is_inner, &
- rhostore,ispec_is_acoustic,potential_acoustic, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian,&
- wxgll,wygll,wzgll,&
- PML_damping_dprime,num_PML_ispec,&
- PML_ispec,PML_normal,&
- chi1_dot_dot,chi2_t_dot_dot,&
- chi3_dot_dot,chi4_dot_dot)
-
- use constants,only: NGLLX,NGLLY,NGLLZ,NDIM,TINYVAL_SNGL,CUSTOM_REAL
- implicit none
-
- integer :: NSPEC_AB,NGLOB_AB
-
- ! potential
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_acoustic
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
- ! split-potentials
- integer :: num_PML_ispec
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- PML_damping_dprime
- integer,dimension(num_PML_ispec):: PML_ispec
- real(kind=CUSTOM_REAL),dimension(NDIM,num_PML_ispec):: PML_normal
-
- ! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rhostore
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian
-
- ! array with derivatives of Lagrange polynomials and precalculated products
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
- double precision, dimension(NGLLX) :: wxgll
- double precision, dimension(NGLLY) :: wygll
- double precision, dimension(NGLLZ) :: wzgll
-
- ! local parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: chi_elem
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1_n,temp2_n,temp3_n
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1_p,temp2_p,temp3_p
- real(kind=CUSTOM_REAL) :: rho_invl
- real(kind=CUSTOM_REAL) :: temp1l,temp2l,temp3l
- real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) :: dpotentialdxl,dpotentialdyl,dpotentialdzl
- real(kind=CUSTOM_REAL) :: dpotentialdxl_n,dpotentialdyl_n,dpotentialdzl_n
- real(kind=CUSTOM_REAL) :: dpotentialdxl_p,dpotentialdyl_p,dpotentialdzl_p
- real(kind=CUSTOM_REAL) :: nx,ny,nz,grad_n,dprime,weights
- integer :: ispec,iglob,i,j,k,l,ispecPML
-
- ! loops over all PML elements
- do ispecPML=1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
-
- ! checks with MPI interface flag
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- ! only acoustic part
- if( ispec_is_acoustic(ispec) ) then
-
- ! gets values for element
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- chi_elem(i,j,k) = potential_acoustic(ibool(i,j,k,ispec))
- enddo
- enddo
- enddo
- ! checks if anything to do
- if( maxval( abs( chi_elem ) ) < TINYVAL_SNGL ) cycle
-
- ! PML normal
- nx = PML_normal(1,ispecPML)
- ny = PML_normal(2,ispecPML)
- nz = PML_normal(3,ispecPML)
-
- ! calculates terms:
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- ! density (reciproc)
- rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
-
- ! derivative along x, y, z
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the loops because NGLLX == NGLLY == NGLLZ
- temp1l = 0._CUSTOM_REAL
- temp2l = 0._CUSTOM_REAL
- temp3l = 0._CUSTOM_REAL
-
- do l = 1,NGLLX
- temp1l = temp1l + chi_elem(l,j,k)*hprime_xx(i,l)
- temp2l = temp2l + chi_elem(i,l,k)*hprime_yy(j,l)
- temp3l = temp3l + chi_elem(i,j,l)*hprime_zz(k,l)
- enddo
-
- ! get derivatives of potential with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
- jacobianl = jacobian(i,j,k,ispec)
-
- ! derivatives of potential
- ! \npartial_i \chi
- dpotentialdxl = xixl*temp1l + etaxl*temp2l + gammaxl*temp3l
- dpotentialdyl = xiyl*temp1l + etayl*temp2l + gammayl*temp3l
- dpotentialdzl = xizl*temp1l + etazl*temp2l + gammazl*temp3l
-
- ! splits derivatives of potential into normal and parallel components
- ! dpotential normal to PML plane
- ! \hat{n} \partial_n \chi
- grad_n = dpotentialdxl*nx + dpotentialdyl*ny + dpotentialdzl*nz
- dpotentialdxl_n = nx * grad_n
- dpotentialdyl_n = ny * grad_n
- dpotentialdzl_n = nz * grad_n
-
-
- ! dpotential parallel to plane
- ! \nabla^{parallel} \chi
- dpotentialdxl_p = dpotentialdxl - dpotentialdxl_n
- dpotentialdyl_p = dpotentialdyl - dpotentialdyl_n
- dpotentialdzl_p = dpotentialdzl - dpotentialdzl_n
-
- ! normal incidence term: ( 1/rho J \hat{n} \partial_n \chi )
- ! (note: we can add two weights at this point to save some computations )
- temp1_n(i,j,k) = rho_invl * jacobianl * dpotentialdxl_n
- temp2_n(i,j,k) = rho_invl * jacobianl * dpotentialdyl_n
- temp3_n(i,j,k) = rho_invl * jacobianl * dpotentialdzl_n
-
- ! parallel incidence 1/rho J \nabla^{parallel} \chi
- temp1_p(i,j,k) = rho_invl * jacobianl * dpotentialdxl_p
- temp2_p(i,j,k) = rho_invl * jacobianl * dpotentialdyl_p
- temp3_p(i,j,k) = rho_invl * jacobianl * dpotentialdzl_p
- enddo
- enddo
- enddo
-
- ! second double-loop over GLL to compute all the terms
- do k = 1,NGLLZ
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,k,ispec)
-
- ! 1. split term:
- !-----------------
- ! normal derivative of w dotted with normal dpotential
- ! ( \hat{n} \nabla_n w ) \cdot ( 1/rho \hat{n} \nabla_n \chi )
- temp1l = 0._CUSTOM_REAL
- temp2l = 0._CUSTOM_REAL
- temp3l = 0._CUSTOM_REAL
- do l=1,NGLLX
- ! derivatives
- xixl = xix(l,j,k,ispec)
- xiyl = xiy(l,j,k,ispec)
- xizl = xiz(l,j,k,ispec)
- ! note: hprimewgll_xx(l,i) = hprime_xx(l,i)*wxgll(l)
- ! don't confuse order of indices in hprime_xx: they are l and i
- ! -> lagrangian (hprime) function i evaluated at point xi_{ l }
- temp1l = temp1l + hprimewgll_xx(l,i) &
- *(nx*temp1_n(l,j,k)+ny*temp2_n(l,j,k)+nz*temp3_n(l,j,k)) &
- *(nx*xixl+ny*xiyl+nz*xizl)
-
- etaxl = etax(i,l,k,ispec)
- etayl = etay(i,l,k,ispec)
- etazl = etaz(i,l,k,ispec)
-
- temp2l = temp2l + hprimewgll_yy(l,j) &
- *(nx*temp1_n(i,l,k)+ny*temp2_n(i,l,k)+nz*temp3_n(i,l,k)) &
- *(nx*etaxl+ny*etayl+nz*etazl)
-
- gammaxl = gammax(i,j,l,ispec)
- gammayl = gammay(i,j,l,ispec)
- gammazl = gammaz(i,j,l,ispec)
-
- temp3l = temp3l + hprimewgll_zz(l,k) &
- *(nx*temp1_n(i,j,l)+ny*temp2_n(i,j,l)+nz*temp3_n(i,j,l)) &
- *(nx*gammaxl+ny*gammayl+nz*gammazl)
- enddo
- temp1l = temp1l * wgllwgll_yz(j,k)
- temp2l = temp2l * wgllwgll_xz(i,k)
- temp3l = temp3l * wgllwgll_xy(i,j)
-
- chi1_dot_dot(i,j,k,ispecPML) = - (temp1l + temp2l + temp3l)
-
- ! 2. split term:
- !-----------------
- ! dprime times normal w dotted with normal dpotential
- ! w dprime \hat{n} \cdot ( 1/rho \hat{n} \nabla_n \chi )
-
- weights = wxgll(i)*wygll(j)*wzgll(k)
-
- temp1l = nx*temp1_n(i,j,k)*weights
- temp2l = ny*temp2_n(i,j,k)*weights
- temp3l = nz*temp3_n(i,j,k)*weights
-
- dprime = PML_damping_dprime(i,j,k,ispecPML)
-
- ! contribution has negative sign?
- chi2_t_dot_dot(i,j,k,ispecPML) = - dprime*(temp1l + temp2l + temp3l )
-
-
- ! 3. split term:
- !-----------------
- ! parallel derivative of w dotted with normal dpotential
- ! ( \nabla^{parallel} w ) \cdot ( 1/rho \hat{n} \nabla_n \chi )
- ! and
- ! normal derivative of w dotted with parallel dpotential
- ! ( \hat{n} \nabla_n w ) \cdot ( 1/rho \nabla_{parallel} \chi )
- temp1l = 0._CUSTOM_REAL
- temp2l = 0._CUSTOM_REAL
- temp3l = 0._CUSTOM_REAL
- do l=1,NGLLX
- ! derivatives
- xixl = xix(l,j,k,ispec)
- xiyl = xiy(l,j,k,ispec)
- xizl = xiz(l,j,k,ispec)
- etaxl = etax(i,l,k,ispec)
- etayl = etay(i,l,k,ispec)
- etazl = etaz(i,l,k,ispec)
- gammaxl = gammax(i,j,l,ispec)
- gammayl = gammay(i,j,l,ispec)
- gammazl = gammaz(i,j,l,ispec)
-
- ! normal derivative of w dotted with parallel dpotential
- temp1l = temp1l + hprimewgll_xx(l,i) &
- *(nx*temp1_p(l,j,k)+ny*temp2_p(l,j,k)+nz*temp3_p(l,j,k)) &
- *(nx*xixl+ny*xiyl+nz*xizl)
-
- temp2l = temp2l + hprimewgll_yy(l,j) &
- *(nx*temp1_p(i,l,k)+ny*temp2_p(i,l,k)+nz*temp3_p(i,l,k)) &
- *(nx*etaxl+ny*etayl+nz*etazl)
-
- temp3l = temp3l + hprimewgll_zz(l,k) &
- *(nx*temp1_p(i,j,l)+ny*temp2_p(i,j,l)+nz*temp3_p(i,j,l)) &
- *(nx*gammaxl+ny*gammayl+nz*gammazl)
-
-
- ! parallel derivative of w dotted with normal dpotential
- temp1l = temp1l + hprimewgll_xx(l,i) &
- *( (xixl - nx*(nx*xixl+ny*xiyl+nz*xizl))*temp1_n(l,j,k) &
- +(xiyl - ny*(nx*xixl+ny*xiyl+nz*xizl))*temp2_n(l,j,k) &
- +(xizl - nz*(nx*xixl+ny*xiyl+nz*xizl))*temp3_n(l,j,k) )
-
- temp2l = temp2l + hprimewgll_yy(l,j) &
- *( (etaxl - nx*(nx*etaxl+ny*etayl+nz*etazl))*temp1_n(i,l,k) &
- +(etayl - ny*(nx*etaxl+ny*etayl+nz*etazl))*temp2_n(i,l,k) &
- +(etazl - nz*(nx*etaxl+ny*etayl+nz*etazl))*temp3_n(i,l,k) )
-
- temp3l = temp3l + hprimewgll_zz(l,k) &
- *( (gammaxl - nx*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp1_n(i,j,l) &
- +(gammayl - ny*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp2_n(i,j,l) &
- +(gammazl - nz*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp3_n(i,j,l) )
- enddo
- temp1l = temp1l * wgllwgll_yz(j,k)
- temp2l = temp2l * wgllwgll_xz(i,k)
- temp3l = temp3l * wgllwgll_xy(i,j)
-
- chi3_dot_dot(i,j,k,ispecPML) = - (temp1l + temp2l + temp3l)
-
-
- ! 4. split term:
- !-----------------
- ! parallel derivative of w dotted with parallel dpotential
- ! ( \nabla_{parallel} w ) \cdot ( 1/rho \nabla_{parallel} \chi )
- temp1l = 0._CUSTOM_REAL
- temp2l = 0._CUSTOM_REAL
- temp3l = 0._CUSTOM_REAL
- do l=1,NGLLX
- ! derivatives
- xixl = xix(l,j,k,ispec)
- xiyl = xiy(l,j,k,ispec)
- xizl = xiz(l,j,k,ispec)
- etaxl = etax(i,l,k,ispec)
- etayl = etay(i,l,k,ispec)
- etazl = etaz(i,l,k,ispec)
- gammaxl = gammax(i,j,l,ispec)
- gammayl = gammay(i,j,l,ispec)
- gammazl = gammaz(i,j,l,ispec)
-
- temp1l = temp1l + hprimewgll_xx(l,i) &
- *( (xixl - nx*(nx*xixl+ny*xiyl+nz*xizl))*temp1_p(l,j,k) &
- +(xiyl - ny*(nx*xixl+ny*xiyl+nz*xizl))*temp2_p(l,j,k) &
- +(xizl - nz*(nx*xixl+ny*xiyl+nz*xizl))*temp3_p(l,j,k) )
-
- temp2l = temp2l + hprimewgll_yy(l,j) &
- *( (etaxl - nx*(nx*etaxl+ny*etayl+nz*etazl))*temp1_p(i,l,k) &
- +(etayl - ny*(nx*etaxl+ny*etayl+nz*etazl))*temp2_p(i,l,k) &
- +(etazl - nz*(nx*etaxl+ny*etayl+nz*etazl))*temp3_p(i,l,k) )
-
- temp3l = temp3l + hprimewgll_zz(l,k) &
- *( (gammaxl - nx*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp1_p(i,j,l) &
- +(gammayl - ny*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp2_p(i,j,l) &
- +(gammazl - nz*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp3_p(i,j,l) )
- enddo
- temp1l = temp1l * wgllwgll_yz(j,k)
- temp2l = temp2l * wgllwgll_xz(i,k)
- temp3l = temp3l * wgllwgll_xy(i,j)
-
- chi4_dot_dot(i,j,k,ispecPML) = - (temp1l + temp2l + temp3l)
-
- enddo
- enddo
- enddo
-
- ! note: the surface integral expressions would be needed for points on a free surface
- !
- ! BUT at the free surface: potentials are set to zero (zero pressure condition),
- ! thus the additional surface term contributions would be zeored again.
-
- endif ! ispec_is_acoustic
- endif ! ispec_is_inner
- enddo ! num_PML_ispec
-
-end subroutine compute_forces_acoustic_PML
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_acoustic_abs_boundaries(phase_is_inner,NSPEC_AB,NGLOB_AB,&
- abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
- num_abs_boundary_faces, &
- kappastore,ibool,ispec_is_inner, &
- rhostore,ispec_is_acoustic,&
- potential_dot_acoustic,potential_dot_dot_acoustic,&
- num_PML_ispec,PML_ispec,ispec_is_PML_inum,&
- chi1_dot,chi2_t,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
-
-! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
-
- use constants,only: NGLLX,NGLLY,NGLLZ,NGLLSQUARE,CUSTOM_REAL
- implicit none
-
- integer :: NSPEC_AB,NGLOB_AB
-
- ! split-potentials
- integer :: num_PML_ispec
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot,chi2_t,chi2_t_dot,chi3_dot,chi4_dot
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot_dot,chi3_dot_dot,chi4_dot_dot
- integer,dimension(num_PML_ispec):: PML_ispec
- integer,dimension(NSPEC_AB):: ispec_is_PML_inum
-
- ! potentials
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic,&
- potential_dot_acoustic
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
- ! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rhostore,kappastore
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
- ! absorbing boundary surface
- integer :: num_abs_boundary_faces
- real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
- integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
- integer :: abs_boundary_ispec(num_abs_boundary_faces)
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: rhol,cpl,jacobianw,temp
- integer :: ispec,iglob,i,j,k,iface,igll,ispecPML
-
- ! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
- do iface=1,num_abs_boundary_faces
-
- ispec = abs_boundary_ispec(iface)
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- if( ispec_is_acoustic(ispec) .and. ispec_is_PML_inum(ispec) > 0 ) then
-
- do ispecPML=1,num_PML_ispec
-
- if( PML_ispec(ispecPML) == ispec) then
-
- ! reference gll points on boundary face
- do igll = 1,NGLLSQUARE
-
- ! gets local indices for GLL point
- i = abs_boundary_ijk(1,igll,iface)
- j = abs_boundary_ijk(2,igll,iface)
- k = abs_boundary_ijk(3,igll,iface)
-
- ! gets global index
- iglob=ibool(i,j,k,ispec)
-
- ! determines bulk sound speed
- rhol = rhostore(i,j,k,ispec)
- cpl = sqrt( kappastore(i,j,k,ispec) / rhol )
-
- ! gets associated, weighted jacobian
- jacobianw = abs_boundary_jacobian2Dw(igll,iface)
-
- temp = jacobianw / cpl / rhol
-
- ! Sommerfeld condition
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob) * jacobianw / cpl / rhol
- ! split-potentials
- chi1_dot_dot(i,j,k,ispecPML) = chi1_dot_dot(i,j,k,ispecPML) - chi1_dot(i,j,k,ispecPML) * temp
- chi3_dot_dot(i,j,k,ispecPML) = chi3_dot_dot(i,j,k,ispecPML) - chi3_dot(i,j,k,ispecPML) * temp
- chi4_dot_dot(i,j,k,ispecPML) = chi4_dot_dot(i,j,k,ispecPML) - chi4_dot(i,j,k,ispecPML) * temp
-
- ! chi2 potential?
- chi2_t_dot(i,j,k,ispecPML) = chi2_t_dot(i,j,k,ispecPML) - chi2_t(i,j,k,ispecPML) * temp
-
- enddo
- endif
- enddo
- endif ! ispec_is_acoustic
- endif ! ispec_is_inner
- enddo ! num_abs_boundary_faces
-
-end subroutine PML_acoustic_abs_boundaries
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_acoustic_interface_coupling(phase_is_inner,NSPEC_AB,NGLOB_AB,&
- potential_dot_dot_acoustic,&
- ibool,ispec_is_inner,ispec_is_acoustic,&
- num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
- chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
-
-! couples potential_dot_dot with PML interface contributions
-
- use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
- implicit none
-
- integer :: NGLOB_AB,NSPEC_AB
-
- ! split-potentials
- integer :: num_PML_ispec
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot_dot,chi3_dot_dot,chi4_dot_dot
- integer,dimension(num_PML_ispec):: PML_ispec
- integer,dimension(NGLOB_AB):: iglob_is_PML_interface
-
- ! potential
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
- ! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
-
- !local parameters
- integer :: iglob,ispecPML,i,j,k,ispec
-
- ! experimental:
- ! updates with the contribution from potential_dot_dot_acoustic on split potentials and vice versa
-
- do ispecPML = 1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
-
- if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
-
- ! acoustic potentials
- if( ispec_is_acoustic(ispec) ) then
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
-
- ! sums contributions to PML potentials on interface points
- if( iglob_is_PML_interface(iglob) > 0 ) then
-
- ! this would be the contribution to the potential_dot_dot array
- ! note: on PML interface, damping coefficient d should to be zero
- ! as well as dprime (-> no chi2 contribution)
-
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
- + chi1_dot_dot(i,j,k,ispecPML) &
- + chi3_dot_dot(i,j,k,ispecPML) &
- + chi4_dot_dot(i,j,k,ispecPML)
-
- endif ! interface iglob
- enddo
- enddo
- enddo
-
- endif ! ispec_is_acoustic
- endif ! ispec_is_inner
- enddo ! ispecPML
-
-
-end subroutine PML_acoustic_interface_coupling
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
-subroutine PML_acoustic_mass_update(NSPEC_AB,NGLOB_AB,&
- ispec_is_acoustic,rmass_acoustic,ibool,&
- num_PML_ispec,PML_ispec,&
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
-
-! updates split-potentials with local mass in PML region
-
- use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
- implicit none
- integer :: NSPEC_AB,NGLOB_AB
-
- ! split-potentials
- integer :: num_PML_ispec
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
- integer,dimension(num_PML_ispec):: PML_ispec
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: rmass_acoustic
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
- !local parameters
- real(kind=CUSTOM_REAL):: mass
- integer :: ispec,ispecPML,i,j,k,iglob
-
- ! updates the dot_dot potentials for the PML
- do ispecPML = 1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
-
- ! acoustic potentials
- if( ispec_is_acoustic(ispec) ) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
-
- ! global mass ( sum over elements included)
- mass = rmass_acoustic(iglob)
-
- chi1_dot_dot(i,j,k,ispecPML) = chi1_dot_dot(i,j,k,ispecPML) * mass
- chi2_t_dot_dot(i,j,k,ispecPML) = chi2_t_dot_dot(i,j,k,ispecPML) * mass
- chi3_dot_dot(i,j,k,ispecPML) = chi3_dot_dot(i,j,k,ispecPML) * mass
- chi4_dot_dot(i,j,k,ispecPML) = chi4_dot_dot(i,j,k,ispecPML) * mass
-
- enddo
- enddo
- enddo
- endif
- enddo
-
-end subroutine PML_acoustic_mass_update
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_acoustic_time_march(NSPEC_AB,NGLOB_AB,ibool,&
- potential_acoustic,potential_dot_acoustic,&
- deltat,deltatsqover2,deltatover2,&
- num_PML_ispec,PML_ispec,PML_damping_d,&
- chi1,chi2,chi2_t,chi3,chi4,&
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot,&
- iglob_is_PML_interface,PML_mask_ibool,&
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh,&
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh,NPROC,&
- ispec_is_acoustic)
-
-
-! time marching scheme - updates with corrector terms
-!
-! note that the value of d changes according to the distance to the boundary,
-! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
-
- use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
- implicit none
-
- integer :: NSPEC_AB,NGLOB_AB
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
- ! potentials
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_acoustic
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_acoustic
-
- real(kind=CUSTOM_REAL):: deltat,deltatsqover2,deltatover2
-
- ! split-potentials
- integer :: num_PML_ispec
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1,chi2,chi2_t,chi3,chi4
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- PML_damping_d
-
- integer,dimension(num_PML_ispec):: PML_ispec
- integer,dimension(NGLOB_AB) :: iglob_is_PML_interface
- logical,dimension(NGLOB_AB) :: PML_mask_ibool
-
- ! MPI communication
- integer :: NPROC
- integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
- integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
- integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
-
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
- !local parameters
- real(kind=CUSTOM_REAL),dimension(:),allocatable:: contributions,contributions_dot
- real(kind=CUSTOM_REAL):: d
- integer :: ispec,ispecPML,i,j,k,iglob,ier
-
- ! updates local points in PML
- allocate(contributions_dot(NGLOB_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array contributions_dot'
- allocate(contributions(NGLOB_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array contributions'
- contributions_dot(:) = 0._CUSTOM_REAL
- contributions(:) = 0._CUSTOM_REAL
-
- do ispecPML = 1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
-
- ! acoustic potentials
- if( ispec_is_acoustic(ispec) ) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- ! updates split-potential arrays
- d = PML_damping_d(i,j,k,ispecPML)
-
- call PML_acoustic_time_march_s(chi1(i,j,k,ispecPML),chi2(i,j,k,ispecPML),&
- chi2_t(i,j,k,ispecPML),chi3(i,j,k,ispecPML),chi4(i,j,k,ispecPML), &
- chi1_dot(i,j,k,ispecPML),chi2_t_dot(i,j,k,ispecPML),&
- chi3_dot(i,j,k,ispecPML),chi4_dot(i,j,k,ispecPML), &
- chi1_dot_dot(i,j,k,ispecPML),chi2_t_dot_dot(i,j,k,ispecPML),&
- chi3_dot_dot(i,j,k,ispecPML),chi4_dot_dot(i,j,k,ispecPML), &
- deltat,deltatsqover2,deltatover2,d)
-
- ! adds new contributions
- iglob = ibool(i,j,k,ispec)
- if( iglob_is_PML_interface(iglob) > 0 ) then
- ! on interface points, the time marched global potential from the regular domains applies
- contributions(iglob) = 0._CUSTOM_REAL
- contributions_dot(iglob) = 0._CUSTOM_REAL
- else
- contributions(iglob) = contributions(iglob) &
- + chi1(i,j,k,ispecPML) &
- + chi2(i,j,k,ispecPML) &
- + chi3(i,j,k,ispecPML) &
- + chi4(i,j,k,ispecPML)
-
- contributions_dot(iglob) = contributions_dot(iglob) &
- + chi1_dot(i,j,k,ispecPML) - d*chi1(i,j,k,ispecPML) &
- + chi2_t(i,j,k,ispecPML) - d*chi2(i,j,k,ispecPML) &
- + chi3_dot(i,j,k,ispecPML) - d*chi3(i,j,k,ispecPML) &
- + chi4_dot(i,j,k,ispecPML)
- endif
- enddo
- enddo
- enddo
- endif
- enddo
-
- ! assembles contributions from different MPI processes
- call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions, &
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh)
- call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions_dot, &
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh)
-
- ! separates contributions from regular domain
- PML_mask_ibool = .false.
-
- !do ispec = 1,NSPEC_AB
- do ispecPML = 1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
-
- ! acoustic potentials
- if( ispec_is_acoustic(ispec) ) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
-
- if( PML_mask_ibool(iglob) .eqv. .false. ) then
- ! on interface points, leave contribution from regular domain
-
- ! inside PML region, split potentials determine the global acoustic potential
- if( iglob_is_PML_interface(iglob) == 0 ) then
- potential_acoustic(iglob) = contributions(iglob)
- potential_dot_acoustic(iglob) = contributions_dot(iglob)
- endif
-
- PML_mask_ibool(iglob) = .true.
- endif
- enddo
- enddo
- enddo
- endif
- enddo
-
-end subroutine PML_acoustic_time_march
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_acoustic_time_march_s(chi1,chi2,chi2_t,chi3,chi4, &
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot, &
- chi1_dot_dot,chi2_t_dot_dot, &
- chi3_dot_dot,chi4_dot_dot, &
- deltat,deltatsqover2,deltatover2,d)
-
-! time marching scheme
-!
-! note that the value of d changes according to the distance to the boundary,
-! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
- use constants,only: CUSTOM_REAL
- implicit none
- real(kind=CUSTOM_REAL):: chi1,chi2,chi2_t,chi3,chi4
- real(kind=CUSTOM_REAL):: chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
- real(kind=CUSTOM_REAL):: chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
- real(kind=CUSTOM_REAL):: deltat,deltatsqover2,deltatover2,d
- !local parameters
- real(kind=CUSTOM_REAL):: fac1,fac2,fac3,fac4
-
- ! pre-computes some factors
- fac1 = 1._CUSTOM_REAL/(1.0_CUSTOM_REAL + deltatover2*d)
- fac2 = 1._CUSTOM_REAL/(d + 1.0_CUSTOM_REAL/deltatover2)
- fac3 = 1._CUSTOM_REAL/(2.0_CUSTOM_REAL + deltat*d)
- fac4 = deltatsqover2*d*d - deltat*d
-
- ! first term: chi1(t+deltat) update
- chi1 = chi1 + deltat*chi1_dot + deltatsqover2*chi1_dot_dot &
- + fac4*chi1 - deltat*deltat*d*chi1_dot
-
- ! chi1_dot predictor
- chi1_dot = fac1 * chi1_dot - d*fac2 * chi1_dot + fac2 * chi1_dot_dot
- chi1_dot_dot = 0._CUSTOM_REAL
-
- ! second term: chi2
- ! note that it uses chi2_t at time ( t )
- chi2 = 2.0*fac3 * chi2 - deltat*d*fac3 * chi2 + deltat*fac3 * chi2_t
-
- ! temporary chi2_t(t+deltat) update
- chi2_t = chi2_t + deltat*chi2_t_dot + deltatsqover2*chi2_t_dot_dot &
- + fac4*chi2_t - deltat*deltat*d*chi2_t_dot
-
- ! chi2 - corrector using updated chi2_t(t+deltat)
- chi2 = chi2 + deltat*fac3 * chi2_t
-
- ! temporary chi2_t_dot - predictor
- chi2_t_dot = fac1 * chi2_t_dot - d*fac2 * chi2_t_dot + fac2 * chi2_t_dot_dot
- chi2_t_dot_dot = 0._CUSTOM_REAL
-
- ! third term: chi3 (t+deltat) update
- chi3 = chi3 + deltat*chi3_dot + deltatsqover2*chi3_dot_dot &
- + fac4*chi3 - deltatsqover2*d*chi3_dot
- chi3_dot = chi3_dot + deltatover2*chi3_dot_dot
- chi3_dot_dot = 0._CUSTOM_REAL
-
- ! fourth term: chi4 (t+deltat) update
- chi4 = chi4 + deltat*chi4_dot + deltatsqover2*chi4_dot_dot
- chi4_dot = chi4_dot + deltatover2*chi4_dot_dot
- chi4_dot_dot = 0._CUSTOM_REAL
-
-end subroutine PML_acoustic_time_march_s
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_acoustic_time_corrector(NSPEC_AB,ispec_is_acoustic,deltatover2,&
- num_PML_ispec,PML_ispec,PML_damping_d,&
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
-
-! time marching scheme - updates with corrector terms
-!
-! note that the value of d changes according to the distance to the boundary,
-! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
-
- use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
- implicit none
-
- ! split-potentials
- integer :: num_PML_ispec
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: PML_damping_d
-
- integer,dimension(num_PML_ispec):: PML_ispec
-
- real(kind=CUSTOM_REAL):: deltatover2
-
- integer :: NSPEC_AB
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
- !local parameters
- real(kind=CUSTOM_REAL):: d
- integer :: ispec,ispecPML,i,j,k
-
- ! updates "velocity" potentials in PML with corrector terms
- do ispecPML = 1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
-
- ! acoustic potentials
- if( ispec_is_acoustic(ispec) ) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- ! time marches chi_dot,.. potentials
- d = PML_damping_d(i,j,k,ispecPML)
-
- call PML_acoustic_time_corrector_s(chi1_dot(i,j,k,ispecPML),chi2_t_dot(i,j,k,ispecPML), &
- chi3_dot(i,j,k,ispecPML),chi4_dot(i,j,k,ispecPML), &
- chi1_dot_dot(i,j,k,ispecPML),chi2_t_dot_dot(i,j,k,ispecPML), &
- chi3_dot_dot(i,j,k,ispecPML),chi4_dot_dot(i,j,k,ispecPML), &
- deltatover2,d)
- enddo
- enddo
- enddo
- endif
- enddo
-
-
-end subroutine PML_acoustic_time_corrector
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_acoustic_time_corrector_s(chi1_dot,chi2_t_dot,chi3_dot,chi4_dot, &
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot, &
- deltatover2,d)
-
-! time marching scheme - updates with corrector terms
-!
-! note that the value of d changes according to the distance to the boundary,
-! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
- use constants,only: CUSTOM_REAL
- implicit none
- real(kind=CUSTOM_REAL):: chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
- real(kind=CUSTOM_REAL):: chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
- real(kind=CUSTOM_REAL):: deltatover2,d
- real(kind=CUSTOM_REAL):: fac1
-
- fac1 = 1.0_CUSTOM_REAL/(d + 1.0_CUSTOM_REAL/deltatover2)
-
- ! first term:
- chi1_dot = chi1_dot + fac1*chi1_dot_dot
-
- ! second term:
- chi2_t_dot = chi2_t_dot + fac1*chi2_t_dot_dot
-
- ! third term:
- chi3_dot = chi3_dot + deltatover2*chi3_dot_dot
-
- ! fourth term:
- chi4_dot = chi4_dot + deltatover2*chi4_dot_dot
-
-end subroutine PML_acoustic_time_corrector_s
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
- ibool,free_surface_ijk,free_surface_ispec, &
- num_free_surface_faces, &
- ispec_is_acoustic, &
- num_PML_ispec,PML_ispec,&
- chi1,chi2,chi2_t,chi3,chi4,&
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi2_t_dot_dot,&
- chi3_dot_dot,chi4_dot_dot)
-
- use constants,only: NGLLX,NGLLY,NGLLZ,NGLLSQUARE,CUSTOM_REAL
- implicit none
-
- integer :: NSPEC_AB,NGLOB_AB
- logical :: ABSORB_INSTEAD_OF_FREE_SURFACE
-
- ! split-potentials
- integer :: num_PML_ispec
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1,chi2,chi2_t,chi3,chi4
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
- integer,dimension(num_PML_ispec):: PML_ispec
-
- ! acoustic potentials
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: &
- potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
- ! free surface
- integer :: num_free_surface_faces
- integer :: free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)
- integer :: free_surface_ispec(num_free_surface_faces)
-
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
-! local parameters
- integer :: iface,igll,i,j,k,ispec,iglob,ispecPML
-
- ! checks if free surface became an absorbing boundary
- if( ABSORB_INSTEAD_OF_FREE_SURFACE ) return
-
- ! enforce potentials to be zero at surface
- do iface = 1, num_free_surface_faces
-
- ispec = free_surface_ispec(iface)
-
- if( ispec_is_acoustic(ispec) ) then
-
- do ispecPML=1,num_PML_ispec
- if( PML_ispec(ispecPML) == ispec ) then
-
- do igll = 1, NGLLSQUARE
- i = free_surface_ijk(1,igll,iface)
- j = free_surface_ijk(2,igll,iface)
- k = free_surface_ijk(3,igll,iface)
- iglob = ibool(i,j,k,ispec)
-
- ! sets potentials to zero
- potential_acoustic(iglob) = 0._CUSTOM_REAL
- potential_dot_acoustic(iglob) = 0._CUSTOM_REAL
- potential_dot_dot_acoustic(iglob) = 0._CUSTOM_REAL
-
- ! sets PML potentials to zero
- chi1(i,j,k,ispecPML) = 0._CUSTOM_REAL
- chi1_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
- chi1_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
-
- chi2(i,j,k,ispecPML) = 0._CUSTOM_REAL
- chi2_t(i,j,k,ispecPML) = 0._CUSTOM_REAL
- chi2_t_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
- chi2_t_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
-
- chi3(i,j,k,ispecPML) = 0._CUSTOM_REAL
- chi3_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
- chi3_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
-
- chi4(i,j,k,ispecPML) = 0._CUSTOM_REAL
- chi4_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
- chi4_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
- enddo
- endif
- enddo
- endif
-
- enddo
-
-end subroutine PML_acoustic_enforce_free_srfc
-
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
-subroutine PML_acoustic_update_potentials(NGLOB_AB,NSPEC_AB, &
- ibool,ispec_is_acoustic, &
- potential_dot_acoustic,potential_dot_dot_acoustic,&
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh,NPROC,&
- num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
- PML_mask_ibool,PML_damping_d,&
- chi1,chi2,chi2_t,chi3,&
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
-
-! updates potential_dot_acoustic and potential_dot_dot_acoustic inside PML region
-
- use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
- implicit none
-
- integer :: NGLOB_AB,NSPEC_AB
-
- ! split-potentials
- integer :: num_PML_ispec
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1,chi2,chi2_t,chi3
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- chi1_dot_dot,chi3_dot_dot,chi4_dot_dot
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
- PML_damping_d
- integer,dimension(num_PML_ispec):: PML_ispec
- integer,dimension(NGLOB_AB):: iglob_is_PML_interface
- logical,dimension(NGLOB_AB):: PML_mask_ibool
-
-
- ! potentials
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_acoustic
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
- ! MPI communication
- integer :: NPROC
- integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
- integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
- integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
-
- !local parameters
- real(kind=CUSTOM_REAL),dimension(:),allocatable :: contributions_dot_dot,contributions_dot
- real(kind=CUSTOM_REAL):: d
- integer :: ispec,ispecPML,i,j,k,iglob,ier
-
- allocate(contributions_dot_dot(NGLOB_AB),contributions_dot(NGLOB_AB),stat=ier)
- if( ier /= 0 ) stop 'error allocating array contributions_dot_dot and contributions_dot'
- contributions_dot_dot = 0._CUSTOM_REAL
- contributions_dot = 0._CUSTOM_REAL
-
- ! updates the potential_dot & potential_dot_dot_acoustic array inside the PML
- do ispecPML = 1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
-
- ! acoustic potentials
- if( ispec_is_acoustic(ispec) ) then
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
-
- ! for points inside PML region
- if( iglob_is_PML_interface(iglob) == 0 ) then
-
- ! damping coefficient
- d = PML_damping_d(i,j,k,ispecPML)
-
- ! inside PML region: at this stage, this is only needed for seismogram/plotting output
- ! afterwards potential_dot_dot, resp. chi1_dot_dot,.. get reset to zero
-
- ! potential_dot: note that we defined
- ! chi1_dot = (\partial_t + d) chi1
- ! chi2_t = (\partial_t + d) chi2
- ! chi3_dot = (\partial_t + d) chi3
- ! chi4_dot = \partial_t chi4
- ! where \partial_t is the time derivative, thus \partial_t (chi1+chi2+chi3+chi4) equals
- contributions_dot(iglob) = contributions_dot(iglob) &
- + chi1_dot(i,j,k,ispecPML) - d*chi1(i,j,k,ispecPML) &
- + chi2_t(i,j,k,ispecPML) - d*chi2(i,j,k,ispecPML) &
- + chi3_dot(i,j,k,ispecPML) - d*chi3(i,j,k,ispecPML) &
- + chi4_dot(i,j,k,ispecPML)
-
- ! potential_dot_dot: note that we defined
- ! chi1_dot_dot = (\partial_t + d)**2 chi1
- ! chi2_t_dot = (\partial_t + d)**2 chi2
- ! chi3_dot = \partial_t (\partial_t + d) chi3
- ! chi4_dot = \partial_t**2 chi4
- ! where \partial_t is the time derivative, thus \partial_t**2 (chi1+chi2+chi3+chi4) equals
- contributions_dot_dot(iglob) = contributions_dot_dot(iglob) &
- + chi1_dot_dot(i,j,k,ispecPML) - 2.0*d*chi1_dot(i,j,k,ispecPML) + d*d*chi1(i,j,k,ispecPML) &
- + chi2_t_dot(i,j,k,ispecPML) - 2.0*d*chi2_t(i,j,k,ispecPML) + d*d*chi2(i,j,k,ispecPML) &
- + chi3_dot_dot(i,j,k,ispecPML) - d*chi3_dot(i,j,k,ispecPML) + d*d*chi3(i,j,k,ispecPML) &
- + chi4_dot_dot(i,j,k,ispecPML)
-
- endif
-
- enddo
- enddo
- enddo
- endif
- enddo
-
- ! assembles contributions from different MPI processes
- call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions_dot, &
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh)
- call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions_dot_dot, &
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh)
-
- ! updates the potential_dot & potential_dot_dot_acoustic array inside the PML
- PML_mask_ibool = .false.
- do ispecPML = 1,num_PML_ispec
-
- ispec = PML_ispec(ispecPML)
-
- ! acoustic potentials
- if( ispec_is_acoustic(ispec) ) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
-
- if( PML_mask_ibool(iglob) .eqv. .false. ) then
- ! for points inside PML region
- if( iglob_is_PML_interface(iglob) == 0 ) then
- potential_dot_acoustic(iglob) = contributions_dot(iglob)
- potential_dot_dot_acoustic(iglob) = contributions_dot(iglob)
- endif
- PML_mask_ibool(iglob) = .true.
- endif
- enddo
- enddo
- enddo
- endif
- enddo
-
-end subroutine PML_acoustic_update_potentials
-
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic_pot.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic_pot.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_acoustic_pot.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -27,12 +27,14 @@
! for acoustic solver
subroutine compute_forces_acoustic_pot( iphase, NSPEC_AB,NGLOB_AB, &
- potential_acoustic,potential_dot_dot_acoustic, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz, &
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- rhostore,jacobian,ibool, &
+ rhostore,jacobian,ibool,deltat, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic,&
phase_ispec_inner_acoustic )
@@ -41,17 +43,21 @@
! note that pressure is defined as:
! p = - Chi_dot_dot
!
- use specfem_par,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,TINYVAL_SNGL,ABSORB_USE_PML,ABSORBING_CONDITIONS
- use PML_par,only:ispec_is_PML_inum
+ use specfem_par,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,TINYVAL_SNGL,ABSORB_USE_PML,ABSORBING_CONDITIONS,PML_CONDITIONS
+ use pml_par
implicit none
+
!include "constants.h"
integer :: NSPEC_AB,NGLOB_AB
! acoustic potentials
real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: &
- potential_acoustic,potential_dot_dot_acoustic
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic
+! time step
+ real(kind=CUSTOM_REAL) :: deltat
+
! arrays with mesh parameters per slice
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
@@ -78,17 +84,39 @@
integer :: num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic
integer, dimension(num_phase_ispec_acoustic,2) :: phase_ispec_inner_acoustic
+! C-PML absorbing boundary conditions
+ integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP
+ integer, dimension(nspec2D_xmin) :: ibelm_xmin
+ integer, dimension(nspec2D_xmax) :: ibelm_xmax
+ integer, dimension(nspec2D_ymin) :: ibelm_ymin
+ integer, dimension(nspec2D_ymax) :: ibelm_ymax
+ integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
+ integer, dimension(NSPEC2D_TOP) :: ibelm_top
+
! local variables
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz,sigma_yx,sigma_zx,sigma_zy
+ real(kind=CUSTOM_REAL) :: hp1,hp2,hp3
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: chi_elem
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1,temp2,temp3
- real(kind=CUSTOM_REAL) temp1l,temp2l,temp3l
+ real(kind=CUSTOM_REAL) :: temp1l,temp2l,temp3l
+ real(kind=CUSTOM_REAL) :: temp1l_new,temp2l_new,temp3l_new
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
- real(kind=CUSTOM_REAL) rho_invl
+ real(kind=CUSTOM_REAL) :: lambdal,mul,lambdalplus2mul
- integer :: ispec,iglob,i,j,k,l,ispec_p,num_elements
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) :: dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) :: dpotentialdxl_new,dpotentialdyl_new,dpotentialdzl_new
+ real(kind=CUSTOM_REAL) :: rho_invl
+ integer :: ispec,ispec2D,iglob,i,j,k,l,ispec_p,num_elements
+
+ ! local C-PML absorbing boundary conditions parameters
+ integer :: ispec_CPML
+
if( iphase == 1 ) then
num_elements = nspec_outer_acoustic
else
@@ -98,17 +126,12 @@
! loop over spectral elements
do ispec_p = 1,num_elements
- !if ( (ispec_is_inner(ispec) .eqv. phase_is_inner) ) then
+ !if( (ispec_is_inner(ispec) .eqv. phase_is_inner) ) then
ispec = phase_ispec_inner_acoustic(ispec_p,iphase)
- ! only elements outside PML, inside "regular" domain
- if( ABSORB_USE_PML .and. ABSORBING_CONDITIONS) then
- if( ispec_is_PML_inum(ispec) > 0 ) cycle
- endif
+ !if( ispec_is_acoustic(ispec) ) then
-! if( ispec_is_acoustic(ispec) ) then
-
! gets values for element
do k=1,NGLLZ
do j=1,NGLLY
@@ -131,13 +154,39 @@
temp1l = 0._CUSTOM_REAL
temp2l = 0._CUSTOM_REAL
temp3l = 0._CUSTOM_REAL
+
do l = 1,NGLLX
temp1l = temp1l + chi_elem(l,j,k)*hprime_xx(i,l)
temp2l = temp2l + chi_elem(i,l,k)*hprime_yy(j,l)
temp3l = temp3l + chi_elem(i,j,l)*hprime_zz(k,l)
enddo
- ! get derivatives of potential with respect to x, y and z
+ if( PML_CONDITIONS .and. CPML_mask_ibool(ispec) ) then
+ temp1l_new = temp1l
+ temp2l_new = temp2l
+ temp3l_new = temp3l
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(l,i)
+ iglob = ibool(l,j,k,ispec)
+ temp1l_new = temp1l_new + deltat*potential_dot_acoustic(iglob)*hp1
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(l,j)
+ iglob = ibool(i,l,k,ispec)
+ temp2l_new = temp2l_new + deltat*potential_dot_acoustic(iglob)*hp2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(l,k)
+ iglob = ibool(i,j,l,ispec)
+ temp3l_new = temp3l_new + deltat*potential_dot_acoustic(iglob)*hp3
+ enddo
+ endif
+
+ ! get derivatives of potential with respect to x, y and z
xixl = xix(i,j,k,ispec)
xiyl = xiy(i,j,k,ispec)
xizl = xiz(i,j,k,ispec)
@@ -147,14 +196,30 @@
gammaxl = gammax(i,j,k,ispec)
gammayl = gammay(i,j,k,ispec)
gammazl = gammaz(i,j,k,ispec)
+ jacobianl = jacobian(i,j,k,ispec)
! derivatives of potential
dpotentialdxl = xixl*temp1l + etaxl*temp2l + gammaxl*temp3l
dpotentialdyl = xiyl*temp1l + etayl*temp2l + gammayl*temp3l
dpotentialdzl = xizl*temp1l + etazl*temp2l + gammazl*temp3l
- jacobianl = jacobian(i,j,k,ispec)
+ ! stores derivatives of ux, uy and uz with respect to x, y and z
+ if( PML_CONDITIONS .and. CPML_mask_ibool(ispec) ) then
+ ispec_CPML = spec_to_CPML(ispec)
+ PML_dpotential_dxl(i,j,k,ispec_CPML) = dpotentialdxl
+ PML_dpotential_dyl(i,j,k,ispec_CPML) = dpotentialdyl
+ PML_dpotential_dzl(i,j,k,ispec_CPML) = dpotentialdzl
+
+ dpotentialdxl_new = xixl*temp1l_new + etaxl*temp2l_new + gammaxl*temp3l_new
+ dpotentialdyl_new = xiyl*temp1l_new + etayl*temp2l_new + gammayl*temp3l_new
+ dpotentialdzl_new = xizl*temp1l_new + etazl*temp2l_new + gammazl*temp3l_new
+
+ PML_dpotential_dxl_new(i,j,k,ispec_CPML) = dpotentialdxl_new
+ PML_dpotential_dyl_new(i,j,k,ispec_CPML) = dpotentialdyl_new
+ PML_dpotential_dzl_new(i,j,k,ispec_CPML) = dpotentialdzl_new
+ endif
+
! density (reciproc)
rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
@@ -166,11 +231,21 @@
(etaxl*dpotentialdxl + etayl*dpotentialdyl + etazl*dpotentialdzl)
temp3(i,j,k) = rho_invl * wgllwgll_xy(i,j) * jacobianl* &
(gammaxl*dpotentialdxl + gammayl*dpotentialdyl + gammazl*dpotentialdzl)
-
enddo
enddo
enddo
+ if( PML_CONDITIONS .and. CPML_mask_ibool(ispec) ) then
+ ! sets C-PML elastic memory variables to compute stress sigma and form dot product with test vector
+ call pml_set_memory_variables(ispec,ispec_CPML,deltat,jacobianl,tempx1,tempy1,tempz1,tempx2,tempy2,tempz2, &
+ tempx3,tempy3,tempz3,sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz, &
+ sigma_yx,sigma_zx,sigma_zy,lambdal,mul,lambdalplus2mul,xixl,xiyl,xizl, &
+ etaxl,etayl,etazl,gammaxl,gammayl,gammazl)
+
+ ! calculates contribution from each C-PML element to update acceleration
+ call pml_set_accel_contribution(ispec,ispec_CPML,deltat,jacobianl,accel_elastic_CPML)
+ endif
+
! second double-loop over GLL to compute all the terms
do k = 1,NGLLZ
do j = 1,NGLLZ
@@ -182,6 +257,7 @@
temp1l = 0._CUSTOM_REAL
temp2l = 0._CUSTOM_REAL
temp3l = 0._CUSTOM_REAL
+
do l=1,NGLLX
temp1l = temp1l + temp1(l,j,k) * hprimewgll_xx(l,i)
temp2l = temp2l + temp2(i,l,k) * hprimewgll_yy(l,j)
@@ -190,9 +266,15 @@
! sum contributions from each element to the global values
iglob = ibool(i,j,k,ispec)
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
- - ( temp1l + temp2l + temp3l )
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - ( temp1l + temp2l + temp3l )
+
+ ! updates potential_dot_dot_acoustic with contribution from each C-PML element
+ if( PML_CONDITIONS .and. CPML_mask_ibool(ispec) ) then
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - &
+ potential_dot_dot_acoustic_CPML(i,j,k,ispec_CPML)
+ endif
+
enddo
enddo
enddo
@@ -202,5 +284,111 @@
enddo ! end of loop over all spectral elements
+ ! C-PML boundary
+ if( PML_CONDITIONS ) then
+ ! xmin
+ do ispec2D=1,nspec2D_xmin
+ ispec = ibelm_xmin(ispec2D)
+
+ i = 1
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ iglob = ibool(i,j,k,ispec)
+
+ potential_dot_dot_acoustic(iglob) = 0.d0
+ potential_dot_acoustic(iglob) = 0.d0
+ potential_acoustic(iglob) = 0.d0
+ enddo
+ enddo
+ enddo
+
+ ! xmax
+ do ispec2D=1,nspec2D_xmax
+ ispec = ibelm_xmax(ispec2D)
+
+ i = NGLLX
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ iglob = ibool(i,j,k,ispec)
+
+ potential_dot_dot_acoustic(iglob) = 0.d0
+ potential_dot_acoustic(iglob) = 0.d0
+ potential_acoustic(iglob) = 0.d0
+ enddo
+ enddo
+ enddo
+
+ ! ymin
+ do ispec2D=1,nspec2D_ymin
+ ispec = ibelm_ymin(ispec2D)
+
+ j = 1
+
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ potential_dot_dot_acoustic(iglob) = 0.d0
+ potential_dot_acoustic(iglob) = 0.d0
+ potential_acoustic(iglob) = 0.d0
+ enddo
+ enddo
+ enddo
+
+ ! ymax
+ do ispec2D=1,nspec2D_ymax
+ ispec = ibelm_ymax(ispec2D)
+
+ j = NGLLY
+
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ potential_dot_dot_acoustic(iglob) = 0.d0
+ potential_dot_acoustic(iglob) = 0.d0
+ potential_acoustic(iglob) = 0.d0
+ enddo
+ enddo
+ enddo
+
+ ! bottom (zmin)
+ do ispec2D=1,NSPEC2D_BOTTOM
+ ispec = ibelm_bottom(ispec2D)
+
+ k = 1
+
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ potential_dot_dot_acoustic(iglob) = 0.d0
+ potential_dot_acoustic(iglob) = 0.d0
+ potential_acoustic(iglob) = 0.d0
+ enddo
+ enddo
+ enddo
+
+ ! top (zmax)
+ do ispec2D=1,NSPEC2D_BOTTOM
+ ispec = ibelm_top(ispec2D)
+
+ k = NGLLZ
+
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ potential_dot_dot_acoustic(iglob) = 0.d0
+ potential_dot_acoustic(iglob) = 0.d0
+ potential_acoustic(iglob) = 0.d0
+ enddo
+ enddo
+ enddo
+
+ endif ! if( PML_CONDITIONS )
+
end subroutine compute_forces_acoustic_pot
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_elastic.F90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_elastic.F90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_elastic.F90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -66,56 +66,60 @@
call compute_forces_elastic_noDev( iphase, NSPEC_AB,NGLOB_AB,displ,veloc,accel, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,&
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
kappastore,mustore,jacobian,ibool, &
- ATTENUATION,deltat, &
+ ATTENUATION,deltat,PML_CONDITIONS, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
one_minus_sum_beta,factor_common, &
alphaval,betaval,gammaval,&
NSPEC_ATTENUATION_AB, &
R_xx,R_yy,R_xy,R_xz,R_yz, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,&
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
epsilondev_xz,epsilondev_yz,epsilon_trace_over_3, &
ANISOTROPY,NSPEC_ANISO, &
- c11store,c12store,c13store,c14store,c15store,c16store,&
- c22store,c23store,c24store,c25store,c26store,c33store,&
- c34store,c35store,c36store,c44store,c45store,c46store,&
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, &
+ c34store,c35store,c36store,c44store,c45store,c46store, &
c55store,c56store,c66store, &
SIMULATION_TYPE,COMPUTE_AND_STORE_STRAIN,NSPEC_STRAIN_ONLY, &
- NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ADJOINT,&
+ NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ADJOINT, &
is_moho_top,is_moho_bot, &
dsdx_top,dsdx_bot, &
ispec2D_moho_top,ispec2D_moho_bot, &
- num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic,&
- phase_ispec_inner_elastic )
+ num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic, &
+ phase_ispec_inner_elastic,ispec_is_elastic )
! adjoint simulations: backward/reconstructed wavefield
if( SIMULATION_TYPE == 3 ) &
- call compute_forces_elastic_noDev( iphase, NSPEC_AB,NGLOB_AB,&
+ call compute_forces_elastic_noDev( iphase, NSPEC_AB,NGLOB_AB, &
b_displ,b_veloc,b_accel, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,&
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
kappastore,mustore,jacobian,ibool, &
- ATTENUATION,deltat, &
+ ATTENUATION,deltat,PML_CONDITIONS, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
one_minus_sum_beta,factor_common, &
- b_alphaval,b_betaval,b_gammaval,&
+ b_alphaval,b_betaval,b_gammaval, &
NSPEC_ATTENUATION_AB, &
b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz, &
- b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy,&
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy, &
b_epsilondev_xz,b_epsilondev_yz,b_epsilon_trace_over_3, &
ANISOTROPY,NSPEC_ANISO, &
- c11store,c12store,c13store,c14store,c15store,c16store,&
- c22store,c23store,c24store,c25store,c26store,c33store,&
- c34store,c35store,c36store,c44store,c45store,c46store,&
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, &
+ c34store,c35store,c36store,c44store,c45store,c46store, &
c55store,c56store,c66store, &
SIMULATION_TYPE,COMPUTE_AND_STORE_STRAIN,NSPEC_STRAIN_ONLY, &
- NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ADJOINT,&
+ NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ADJOINT, &
is_moho_top,is_moho_bot, &
b_dsdx_top,b_dsdx_bot, &
ispec2D_moho_top,ispec2D_moho_bot, &
- num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic,&
+ num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic, &
phase_ispec_inner_elastic )
endif
@@ -145,8 +149,8 @@
request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
! transfers mpi buffers onto GPU
- call transfer_boundary_to_device(NPROC,Mesh_pointer,buffer_recv_vector_ext_mesh,&
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh,&
+ call transfer_boundary_to_device(NPROC,Mesh_pointer,buffer_recv_vector_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
request_recv_vector_ext_mesh)
endif ! inner elements
@@ -154,8 +158,8 @@
! adds elastic absorbing boundary term to acceleration (Stacey conditions)
- if(ABSORBING_CONDITIONS) &
- call compute_stacey_elastic(NSPEC_AB,NGLOB_AB,accel, &
+ if( ABSORBING_CONDITIONS ) then
+ call compute_stacey_elastic(NSPEC_AB,NGLOB_AB,accel, &
ibool,ispec_is_inner,phase_is_inner, &
abs_boundary_normal,abs_boundary_jacobian2Dw, &
abs_boundary_ijk,abs_boundary_ispec, &
@@ -165,7 +169,9 @@
NSTEP,it,NGLOB_ADJOINT,b_accel, &
b_num_abs_boundary_faces,b_reclen_field,b_absorb_field,&
GPU_MODE,Mesh_pointer)
+ endif
+
! acoustic coupling
if( ACOUSTIC_SIMULATION ) then
if( num_coupling_ac_el_faces > 0 ) then
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_elastic_noDev.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_elastic_noDev.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/compute_forces_elastic_noDev.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -31,7 +31,9 @@
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,&
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
kappastore,mustore,jacobian,ibool, &
- ATTENUATION,deltat, &
+ ATTENUATION,deltat,PML_CONDITIONS, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
one_minus_sum_beta,factor_common, &
alphaval,betaval,gammaval, &
NSPEC_ATTENUATION_AB, &
@@ -49,17 +51,14 @@
dsdx_top,dsdx_bot, &
ispec2D_moho_top,ispec2D_moho_bot, &
num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic, &
- phase_ispec_inner_elastic )
+ phase_ispec_inner_elastic)
- use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,NDIM, &
- N_SLS,SAVE_MOHO_MESH, &
- ONE_THIRD,FOUR_THIRDS
+ use constants, only: NGLLX,NGLLY,NGLLZ,NDIM,N_SLS,SAVE_MOHO_MESH,ONE_THIRD,FOUR_THIRDS
+ use pml_par
use fault_solver_dynamic, only : Kelvin_Voigt_eta
implicit none
- !include "constants.h"
-
integer :: NSPEC_AB,NGLOB_AB
! displacement, velocity and acceleration
@@ -114,69 +113,79 @@
! New dloc = displ + Kelvin Voigt damping*veloc
real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLY,NGLLZ) :: dloc
-! logical,dimension(NSPEC_AB) :: ispec_is_elastic
integer :: iphase
integer :: num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic
integer, dimension(num_phase_ispec_elastic,2) :: phase_ispec_inner_elastic
-
! adjoint simulations
integer :: SIMULATION_TYPE
integer :: NSPEC_BOUN,NSPEC2D_MOHO
! moho kernel
real(kind=CUSTOM_REAL),dimension(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO):: &
- dsdx_top,dsdx_bot
+ dsdx_top,dsdx_bot
logical,dimension(NSPEC_BOUN) :: is_moho_top,is_moho_bot
integer :: ispec2D_moho_top, ispec2D_moho_bot
+! C-PML absorbing boundary conditions
+ logical :: PML_CONDITIONS
+ integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP
+ integer, dimension(nspec2D_xmin) :: ibelm_xmin
+ integer, dimension(nspec2D_xmax) :: ibelm_xmax
+ integer, dimension(nspec2D_ymin) :: ibelm_ymin
+ integer, dimension(nspec2D_ymax) :: ibelm_ymax
+ integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
+ integer, dimension(NSPEC2D_TOP) :: ibelm_top
+
! local parameters
+ integer :: i_SLS
+ integer :: ispec,ispec2D,iglob,ispec_p,num_elements
+ integer :: i,j,k,l
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) :: duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
- real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=CUSTOM_REAL) :: duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL) :: duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
- real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz,sigma_yx,sigma_zx,sigma_zy
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz,sigma_yx,sigma_zx,sigma_zy
- real(kind=CUSTOM_REAL) hp1,hp2,hp3
- real(kind=CUSTOM_REAL) fac1,fac2,fac3
+ real(kind=CUSTOM_REAL) :: hp1,hp2,hp3
+ real(kind=CUSTOM_REAL) :: fac1,fac2,fac3
- real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
- real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
- real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+ real(kind=CUSTOM_REAL) :: tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) :: tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) :: tempz1l,tempz2l,tempz3l
- real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
- real(kind=CUSTOM_REAL) kappal
+ real(kind=CUSTOM_REAL) :: lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) :: kappal
- real(kind=CUSTOM_REAL) tempx1l_att,tempx2l_att,tempx3l_att
- real(kind=CUSTOM_REAL) tempy1l_att,tempy2l_att,tempy3l_att
- real(kind=CUSTOM_REAL) tempz1l_att,tempz2l_att,tempz3l_att
-
- real(kind=CUSTOM_REAL) duxdxl_att,duxdyl_att,duxdzl_att,duydxl_att
- real(kind=CUSTOM_REAL) duydyl_att,duydzl_att,duzdxl_att,duzdyl_att,duzdzl_att;
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl_att,duzdxl_plus_duxdzl_att,duzdyl_plus_duydzl_att;
-
! local anisotropy parameters
- real(kind=CUSTOM_REAL) c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ real(kind=CUSTOM_REAL) :: c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
! local attenuation parameters
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xx_loc, &
epsilondev_yy_loc, epsilondev_xy_loc, epsilondev_xz_loc, epsilondev_yz_loc
- real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
- real(kind=CUSTOM_REAL) factor_loc,alphaval_loc,betaval_loc,gammaval_loc,Sn,Snp1
- real(kind=CUSTOM_REAL) templ
+ real(kind=CUSTOM_REAL) :: R_xx_val,R_yy_val
+ real(kind=CUSTOM_REAL) :: factor_loc,alphaval_loc,betaval_loc,gammaval_loc,Sn,Snp1
+ real(kind=CUSTOM_REAL) :: templ
- integer i_SLS
- integer ispec,iglob,ispec_p,num_elements
- integer i,j,k,l
+ real(kind=CUSTOM_REAL) :: tempx1l_new,tempx2l_new,tempx3l_new
+ real(kind=CUSTOM_REAL) :: tempy1l_new,tempy2l_new,tempy3l_new
+ real(kind=CUSTOM_REAL) :: tempz1l_new,tempz2l_new,tempz3l_new
+ real(kind=CUSTOM_REAL) :: duxdxl_new,duxdyl_new,duxdzl_new,duydxl_new
+ real(kind=CUSTOM_REAL) :: duydyl_new,duydzl_new,duzdxl_new,duzdyl_new,duzdzl_new;
+ real(kind=CUSTOM_REAL) :: duxdyl_plus_duydxl_new,duzdxl_plus_duxdzl_new,duzdyl_plus_duydzl_new;
+
real(kind=CUSTOM_REAL) :: eta
+ ! local C-PML absorbing boundary conditions parameters
+ integer :: ispec_CPML
if( iphase == 1 ) then
num_elements = nspec_outer_elastic
@@ -186,118 +195,115 @@
do ispec_p = 1,num_elements
- ispec = phase_ispec_inner_elastic(ispec_p,iphase)
+ ispec = phase_ispec_inner_elastic(ispec_p,iphase)
- ! adjoint simulations: moho kernel
- ! note: call this only once
- if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
- if (is_moho_top(ispec)) then
- ispec2D_moho_top = ispec2D_moho_top + 1
- else if (is_moho_bot(ispec)) then
- ispec2D_moho_bot = ispec2D_moho_bot + 1
- endif
- endif
+ ! adjoint simulations: moho kernel
+ ! note: call this only once
+ if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+ if (is_moho_top(ispec)) then
+ ispec2D_moho_top = ispec2D_moho_top + 1
+ else if (is_moho_bot(ispec)) then
+ ispec2D_moho_bot = ispec2D_moho_bot + 1
+ endif
+ endif
- ! Kelvin Voigt damping: artificial viscosity around dynamic faults
-
- if (allocated(Kelvin_Voigt_eta)) then
- eta = Kelvin_Voigt_eta(ispec)
- do k=1,NGLLZ
+ ! Kelvin Voigt damping: artificial viscosity around dynamic faults
+ if (allocated(Kelvin_Voigt_eta)) then
+ eta = Kelvin_Voigt_eta(ispec)
+ do k=1,NGLLZ
do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- dloc(:,i,j,k) = displ(:,iglob) + eta*veloc(:,iglob)
- enddo
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dloc(:,i,j,k) = displ(:,iglob) + eta*veloc(:,iglob)
+ enddo
enddo
- enddo
+ enddo
- else
- do k=1,NGLLZ
+ else
+ do k=1,NGLLZ
do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- dloc(:,i,j,k) = displ(:,iglob)
- enddo
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dloc(:,i,j,k) = displ(:,iglob)
+ enddo
enddo
- enddo
- endif
+ enddo
+ endif
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
- tempx1l = 0.
- tempx2l = 0.
- tempx3l = 0.
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
- tempy1l = 0.
- tempy2l = 0.
- tempy3l = 0.
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
- tempz1l = 0.
- tempz2l = 0.
- tempz3l = 0.
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
do l=1,NGLLX
hp1 = hprime_xx(i,l)
- !iglob = ibool(l,j,k,ispec)
tempx1l = tempx1l + dloc(1,l,j,k)*hp1
tempy1l = tempy1l + dloc(2,l,j,k)*hp1
tempz1l = tempz1l + dloc(3,l,j,k)*hp1
!!! can merge these loops because NGLLX = NGLLY = NGLLZ
hp2 = hprime_yy(j,l)
- !iglob = ibool(i,l,k,ispec)
tempx2l = tempx2l + dloc(1,i,l,k)*hp2
tempy2l = tempy2l + dloc(2,i,l,k)*hp2
tempz2l = tempz2l + dloc(3,i,l,k)*hp2
!!! can merge these loops because NGLLX = NGLLY = NGLLZ
hp3 = hprime_zz(k,l)
- !iglob = ibool(i,j,l,ispec)
tempx3l = tempx3l + dloc(1,i,j,l)*hp3
tempy3l = tempy3l + dloc(2,i,j,l)*hp3
tempz3l = tempz3l + dloc(3,i,j,l)*hp3
enddo
- if( ATTENUATION .and. COMPUTE_AND_STORE_STRAIN ) then
- tempx1l_att = tempx1l
- tempx2l_att = tempx2l
- tempx3l_att = tempx3l
+ if( (ATTENUATION .and. COMPUTE_AND_STORE_STRAIN) .or. &
+ (PML_CONDITIONS .and. CPML_mask_ibool(ispec)) ) then
+ tempx1l_new = tempx1l
+ tempx2l_new = tempx2l
+ tempx3l_new = tempx3l
- tempy1l_att = tempy1l
- tempy2l_att = tempy2l
- tempy3l_att = tempy3l
+ tempy1l_new = tempy1l
+ tempy2l_new = tempy2l
+ tempy3l_new = tempy3l
- tempz1l_att = tempz1l
- tempz2l_att = tempz2l
- tempz3l_att = tempz3l
+ tempz1l_new = tempz1l
+ tempz2l_new = tempz2l
+ tempz3l_new = tempz3l
! use first order Taylor expansion of displacement for local storage of stresses
! at this current time step, to fix attenuation in a consistent way
do l=1,NGLLX
hp1 = hprime_xx(i,l)
iglob = ibool(l,j,k,ispec)
- tempx1l_att = tempx1l_att + deltat*veloc(1,iglob)*hp1
- tempy1l_att = tempy1l_att + deltat*veloc(2,iglob)*hp1
- tempz1l_att = tempz1l_att + deltat*veloc(3,iglob)*hp1
+ tempx1l_new = tempx1l_new + deltat*veloc(1,iglob)*hp1
+ tempy1l_new = tempy1l_new + deltat*veloc(2,iglob)*hp1
+ tempz1l_new = tempz1l_new + deltat*veloc(3,iglob)*hp1
!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
hp2 = hprime_yy(j,l)
iglob = ibool(i,l,k,ispec)
- tempx2l_att = tempx2l_att + deltat*veloc(1,iglob)*hp2
- tempy2l_att = tempy2l_att + deltat*veloc(2,iglob)*hp2
- tempz2l_att = tempz2l_att + deltat*veloc(3,iglob)*hp2
+ tempx2l_new = tempx2l_new + deltat*veloc(1,iglob)*hp2
+ tempy2l_new = tempy2l_new + deltat*veloc(2,iglob)*hp2
+ tempz2l_new = tempz2l_new + deltat*veloc(3,iglob)*hp2
!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
hp3 = hprime_zz(k,l)
iglob = ibool(i,j,l,ispec)
- tempx3l_att = tempx3l_att + deltat*veloc(1,iglob)*hp3
- tempy3l_att = tempy3l_att + deltat*veloc(2,iglob)*hp3
- tempz3l_att = tempz3l_att + deltat*veloc(3,iglob)*hp3
+ tempx3l_new = tempx3l_new + deltat*veloc(1,iglob)*hp3
+ tempy3l_new = tempy3l_new + deltat*veloc(2,iglob)*hp3
+ tempz3l_new = tempz3l_new + deltat*veloc(3,iglob)*hp3
enddo
endif
@@ -325,6 +331,23 @@
duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+ ! stores derivatives of ux, uy and uz with respect to x, y and z
+ if( PML_CONDITIONS .and. CPML_mask_ibool(ispec) ) then
+ ispec_CPML = spec_to_CPML(ispec)
+
+ PML_dux_dxl(i,j,k,ispec_CPML) = duxdxl
+ PML_dux_dyl(i,j,k,ispec_CPML) = duxdyl
+ PML_dux_dzl(i,j,k,ispec_CPML) = duxdzl
+
+ PML_duy_dxl(i,j,k,ispec_CPML) = duydxl
+ PML_duy_dyl(i,j,k,ispec_CPML) = duydyl
+ PML_duy_dzl(i,j,k,ispec_CPML) = duydzl
+
+ PML_duz_dxl(i,j,k,ispec_CPML) = duzdxl
+ PML_duz_dyl(i,j,k,ispec_CPML) = duzdyl
+ PML_duz_dzl(i,j,k,ispec_CPML) = duzdzl
+ endif
+
! adjoint simulations: save strain on the Moho boundary
if (SAVE_MOHO_MESH ) then
if (is_moho_top(ispec)) then
@@ -358,33 +381,52 @@
duzdxl_plus_duxdzl = duzdxl + duxdzl
duzdyl_plus_duydzl = duzdyl + duydzl
- if( ATTENUATION .and. COMPUTE_AND_STORE_STRAIN ) then
+ if( (ATTENUATION .and. COMPUTE_AND_STORE_STRAIN) .or. &
+ (PML_CONDITIONS .and. CPML_mask_ibool(ispec)) ) then
! temporary variables used for fixing attenuation in a consistent way
- duxdxl_att = xixl*tempx1l_att + etaxl*tempx2l_att + gammaxl*tempx3l_att
- duxdyl_att = xiyl*tempx1l_att + etayl*tempx2l_att + gammayl*tempx3l_att
- duxdzl_att = xizl*tempx1l_att + etazl*tempx2l_att + gammazl*tempx3l_att
+ duxdxl_new = xixl*tempx1l_new + etaxl*tempx2l_new + gammaxl*tempx3l_new
+ duxdyl_new = xiyl*tempx1l_new + etayl*tempx2l_new + gammayl*tempx3l_new
+ duxdzl_new = xizl*tempx1l_new + etazl*tempx2l_new + gammazl*tempx3l_new
- duydxl_att = xixl*tempy1l_att + etaxl*tempy2l_att + gammaxl*tempy3l_att
- duydyl_att = xiyl*tempy1l_att + etayl*tempy2l_att + gammayl*tempy3l_att
- duydzl_att = xizl*tempy1l_att + etazl*tempy2l_att + gammazl*tempy3l_att
+ duydxl_new = xixl*tempy1l_new + etaxl*tempy2l_new + gammaxl*tempy3l_new
+ duydyl_new = xiyl*tempy1l_new + etayl*tempy2l_new + gammayl*tempy3l_new
+ duydzl_new = xizl*tempy1l_new + etazl*tempy2l_new + gammazl*tempy3l_new
- duzdxl_att = xixl*tempz1l_att + etaxl*tempz2l_att + gammaxl*tempz3l_att
- duzdyl_att = xiyl*tempz1l_att + etayl*tempz2l_att + gammayl*tempz3l_att
- duzdzl_att = xizl*tempz1l_att + etazl*tempz2l_att + gammazl*tempz3l_att
+ duzdxl_new = xixl*tempz1l_new + etaxl*tempz2l_new + gammaxl*tempz3l_new
+ duzdyl_new = xiyl*tempz1l_new + etayl*tempz2l_new + gammayl*tempz3l_new
+ duzdzl_new = xizl*tempz1l_new + etazl*tempz2l_new + gammazl*tempz3l_new
- ! precompute some sums to save CPU time
- duxdyl_plus_duydxl_att = duxdyl_att + duydxl_att
- duzdxl_plus_duxdzl_att = duzdxl_att + duxdzl_att
- duzdyl_plus_duydzl_att = duzdyl_att + duydzl_att
+ if( ATTENUATION .and. COMPUTE_AND_STORE_STRAIN ) then
+ ! precompute some sums to save CPU time
+ duxdyl_plus_duydxl_new = duxdyl_new + duydxl_new
+ duzdxl_plus_duxdzl_new = duzdxl_new + duxdzl_new
+ duzdyl_plus_duydzl_new = duzdyl_new + duydzl_new
- ! compute deviatoric strain
- if( SIMULATION_TYPE == 3 ) epsilon_trace_over_3(i,j,k,ispec) = ONE_THIRD * (duxdxl_att + duydyl_att + duzdzl_att)
- epsilondev_xx_loc(i,j,k) = duxdxl_att - epsilon_trace_over_3(i,j,k,ispec)
- epsilondev_yy_loc(i,j,k) = duydyl_att - epsilon_trace_over_3(i,j,k,ispec)
- epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl_att
- epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl_att
- epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl_att
- else
+ ! compute deviatoric strain
+ if( SIMULATION_TYPE == 3 ) epsilon_trace_over_3(i,j,k,ispec) = ONE_THIRD * (duxdxl_new + duydyl_new + duzdzl_new)
+ epsilondev_xx_loc(i,j,k) = duxdxl_new - epsilon_trace_over_3(i,j,k,ispec)
+ epsilondev_yy_loc(i,j,k) = duydyl_new - epsilon_trace_over_3(i,j,k,ispec)
+ epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl_new
+ epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl_new
+ epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl_new
+ endif
+
+ if( PML_CONDITIONS .and. CPML_mask_ibool(ispec) ) then
+ PML_dux_dxl_new(i,j,k,ispec_CPML) = duxdxl_new
+ PML_dux_dyl_new(i,j,k,ispec_CPML) = duxdyl_new
+ PML_dux_dzl_new(i,j,k,ispec_CPML) = duxdzl_new
+
+ PML_duy_dxl_new(i,j,k,ispec_CPML) = duydxl_new
+ PML_duy_dyl_new(i,j,k,ispec_CPML) = duydyl_new
+ PML_duy_dzl_new(i,j,k,ispec_CPML) = duydzl_new
+
+ PML_duz_dxl_new(i,j,k,ispec_CPML) = duzdxl_new
+ PML_duz_dyl_new(i,j,k,ispec_CPML) = duzdyl_new
+ PML_duz_dzl_new(i,j,k,ispec_CPML) = duzdzl_new
+ endif
+
+ elseif( .not.(ATTENUATION .and. COMPUTE_AND_STORE_STRAIN) ) then
+
! computes deviatoric strain attenuation and/or for kernel calculations
if (COMPUTE_AND_STORE_STRAIN) then
templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
@@ -473,43 +515,57 @@
enddo
endif
- ! define symmetric components of sigma
- sigma_yx = sigma_xy
- sigma_zx = sigma_xz
- sigma_zy = sigma_yz
+ if( .not. PML_CONDITIONS ) then
+ ! define symmetric components of sigma
+ sigma_yx = sigma_xy
+ sigma_zx = sigma_xz
+ sigma_zy = sigma_yz
- ! form dot product with test vector, non-symmetric form (which is useful in the case of PML)
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl) ! this goes to accel_x
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl) ! this goes to accel_y
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl) ! this goes to accel_z
+ ! form dot product with test vector, non-symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl) ! this goes to accel_x
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl) ! this goes to accel_y
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl) ! this goes to accel_z
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl) ! this goes to accel_x
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl) ! this goes to accel_y
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl) ! this goes to accel_z
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl) ! this goes to accel_x
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl) ! this goes to accel_y
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl) ! this goes to accel_z
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl) ! this goes to accel_x
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl) ! this goes to accel_y
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl) ! this goes to accel_z
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl) ! this goes to accel_x
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl) ! this goes to accel_y
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl) ! this goes to accel_z
+ endif
enddo
enddo
enddo
+ if( PML_CONDITIONS .and. CPML_mask_ibool(ispec) ) then
+ ! sets C-PML elastic memory variables to compute stress sigma and form dot product with test vector
+ call pml_set_memory_variables(ispec,ispec_CPML,deltat,jacobianl,tempx1,tempy1,tempz1,tempx2,tempy2,tempz2, &
+ tempx3,tempy3,tempz3,sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz, &
+ sigma_yx,sigma_zx,sigma_zy,lambdal,mul,lambdalplus2mul,xixl,xiyl,xizl, &
+ etaxl,etayl,etazl,gammaxl,gammayl,gammazl)
+
+ ! calculates contribution from each C-PML element to update acceleration
+ call pml_set_accel_contribution(ispec,ispec_CPML,deltat,jacobianl,accel_elastic_CPML)
+ endif
+
+ ! second double-loop over GLL to compute all the terms
do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
+ do j=1,NGLLY
+ do i=1,NGLLX
- tempx1l = 0.
- tempy1l = 0.
- tempz1l = 0.
+ tempx1l = 0._CUSTOM_REAL
+ tempy1l = 0._CUSTOM_REAL
+ tempz1l = 0._CUSTOM_REAL
- tempx2l = 0.
- tempy2l = 0.
- tempz2l = 0.
+ tempx2l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
- tempx3l = 0.
- tempy3l = 0.
- tempz3l = 0.
+ tempx3l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
do l=1,NGLLX
fac1 = hprimewgll_xx(l,i)
@@ -541,6 +597,13 @@
accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+ ! updates acceleration with contribution from each C-PML element
+ if( PML_CONDITIONS .and. CPML_mask_ibool(ispec) ) then
+ accel(1,iglob) = accel(1,iglob) - accel_elastic_CPML(1,i,j,k,ispec_CPML)
+ accel(2,iglob) = accel(2,iglob) - accel_elastic_CPML(2,i,j,k,ispec_CPML)
+ accel(3,iglob) = accel(3,iglob) - accel_elastic_CPML(3,i,j,k,ispec_CPML)
+ endif
+
! update memory variables based upon the Runge-Kutta scheme
if(ATTENUATION) then
@@ -589,7 +652,6 @@
endif ! end attenuation
-
enddo
enddo
enddo
@@ -604,7 +666,160 @@
endif
enddo ! spectral element loop
+
+ ! C-PML boundary
+ if( PML_CONDITIONS ) then
+ ! xmin
+ do ispec2D=1,nspec2D_xmin
+ ispec = ibelm_xmin(ispec2D)
+ i = 1
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ iglob = ibool(i,j,k,ispec)
+
+ accel(1,iglob) = 0._CUSTOM_REAL
+ accel(2,iglob) = 0._CUSTOM_REAL
+ accel(3,iglob) = 0._CUSTOM_REAL
+
+ veloc(1,iglob) = 0._CUSTOM_REAL
+ veloc(2,iglob) = 0._CUSTOM_REAL
+ veloc(3,iglob) = 0._CUSTOM_REAL
+
+ displ(1,iglob) = 0._CUSTOM_REAL
+ displ(2,iglob) = 0._CUSTOM_REAL
+ displ(3,iglob) = 0._CUSTOM_REAL
+ enddo
+ enddo
+ enddo
+
+ ! xmax
+ do ispec2D=1,nspec2D_xmax
+ ispec = ibelm_xmax(ispec2D)
+
+ i = NGLLX
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ iglob = ibool(i,j,k,ispec)
+
+ accel(1,iglob) = 0._CUSTOM_REAL
+ accel(2,iglob) = 0._CUSTOM_REAL
+ accel(3,iglob) = 0._CUSTOM_REAL
+
+ veloc(1,iglob) = 0._CUSTOM_REAL
+ veloc(2,iglob) = 0._CUSTOM_REAL
+ veloc(3,iglob) = 0._CUSTOM_REAL
+
+ displ(1,iglob) = 0._CUSTOM_REAL
+ displ(2,iglob) = 0._CUSTOM_REAL
+ displ(3,iglob) = 0._CUSTOM_REAL
+ enddo
+ enddo
+ enddo
+
+ ! ymin
+ do ispec2D=1,nspec2D_ymin
+ ispec = ibelm_ymin(ispec2D)
+
+ j = 1
+
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ accel(1,iglob) = 0._CUSTOM_REAL
+ accel(2,iglob) = 0._CUSTOM_REAL
+ accel(3,iglob) = 0._CUSTOM_REAL
+
+ veloc(1,iglob) = 0._CUSTOM_REAL
+ veloc(2,iglob) = 0._CUSTOM_REAL
+ veloc(3,iglob) = 0._CUSTOM_REAL
+
+ displ(1,iglob) = 0._CUSTOM_REAL
+ displ(2,iglob) = 0._CUSTOM_REAL
+ displ(3,iglob) = 0._CUSTOM_REAL
+ enddo
+ enddo
+ enddo
+
+ ! ymax
+ do ispec2D=1,nspec2D_ymax
+ ispec = ibelm_ymax(ispec2D)
+
+ j = NGLLY
+
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ accel(1,iglob) = 0._CUSTOM_REAL
+ accel(2,iglob) = 0._CUSTOM_REAL
+ accel(3,iglob) = 0._CUSTOM_REAL
+
+ veloc(1,iglob) = 0._CUSTOM_REAL
+ veloc(2,iglob) = 0._CUSTOM_REAL
+ veloc(3,iglob) = 0._CUSTOM_REAL
+
+ displ(1,iglob) = 0._CUSTOM_REAL
+ displ(2,iglob) = 0._CUSTOM_REAL
+ displ(3,iglob) = 0._CUSTOM_REAL
+ enddo
+ enddo
+ enddo
+
+ ! bottom (zmin)
+ do ispec2D=1,NSPEC2D_BOTTOM
+ ispec = ibelm_bottom(ispec2D)
+
+ k = 1
+
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ accel(1,iglob) = 0._CUSTOM_REAL
+ accel(2,iglob) = 0._CUSTOM_REAL
+ accel(3,iglob) = 0._CUSTOM_REAL
+
+ veloc(1,iglob) = 0._CUSTOM_REAL
+ veloc(2,iglob) = 0._CUSTOM_REAL
+ veloc(3,iglob) = 0._CUSTOM_REAL
+
+ displ(1,iglob) = 0._CUSTOM_REAL
+ displ(2,iglob) = 0._CUSTOM_REAL
+ displ(3,iglob) = 0._CUSTOM_REAL
+ enddo
+ enddo
+ enddo
+
+ ! top (zmax)
+ do ispec2D=1,NSPEC2D_BOTTOM
+ ispec = ibelm_top(ispec2D)
+
+ k = NGLLZ
+
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ accel(1,iglob) = 0._CUSTOM_REAL
+ accel(2,iglob) = 0._CUSTOM_REAL
+ accel(3,iglob) = 0._CUSTOM_REAL
+
+ veloc(1,iglob) = 0._CUSTOM_REAL
+ veloc(2,iglob) = 0._CUSTOM_REAL
+ veloc(3,iglob) = 0._CUSTOM_REAL
+
+ displ(1,iglob) = 0._CUSTOM_REAL
+ displ(2,iglob) = 0._CUSTOM_REAL
+ displ(3,iglob) = 0._CUSTOM_REAL
+ enddo
+ enddo
+ enddo
+
+ endif ! if( PML_CONDITIONS )
+
end subroutine compute_forces_elastic_noDev
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/finalize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/finalize_simulation.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/finalize_simulation.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -27,6 +27,8 @@
! United States and French Government Sponsorship Acknowledged.
subroutine finalize_simulation()
+
+ use pml_par
use specfem_par
use specfem_par_elastic
@@ -162,6 +164,85 @@
deallocate(rmass_acoustic)
endif
+ ! C-PML absorbing boundary conditions
+ if( PML_CONDITIONS .and. NSPEC_CPML > 0 ) then
+ ! outputs informations about C-PML elements in VTK-file format
+ call pml_output_VTKs()
+
+ ! deallocates C_PML arrays
+ deallocate(CPML_regions)
+ deallocate(CPML_to_spec)
+ deallocate(CPML_mask_ibool)
+ deallocate(d_store_x)
+ deallocate(d_store_y)
+ deallocate(d_store_z)
+ deallocate(k_store_x)
+ deallocate(k_store_y)
+ deallocate(k_store_z)
+ deallocate(alpha_store)
+ deallocate(spec_to_CPML)
+ deallocate(CPML_type)
+ deallocate(PML_dux_dxl)
+ deallocate(PML_dux_dyl)
+ deallocate(PML_dux_dzl)
+ deallocate(PML_duy_dxl)
+ deallocate(PML_duy_dyl)
+ deallocate(PML_duy_dzl)
+ deallocate(PML_duz_dxl)
+ deallocate(PML_duz_dyl)
+ deallocate(PML_duz_dzl)
+ deallocate(PML_dux_dxl_new)
+ deallocate(PML_dux_dyl_new)
+ deallocate(PML_dux_dzl_new)
+ deallocate(PML_duy_dxl_new)
+ deallocate(PML_duy_dyl_new)
+ deallocate(PML_duy_dzl_new)
+ deallocate(PML_duz_dxl_new)
+ deallocate(PML_duz_dyl_new)
+ deallocate(PML_duz_dzl_new)
+ deallocate(PML_dpotential_dxl)
+ deallocate(PML_dpotential_dyl)
+ deallocate(PML_dpotential_dzl)
+ deallocate(PML_dpotential_dxl_new)
+ deallocate(PML_dpotential_dyl_new)
+ deallocate(PML_dpotential_dzl_new)
+ deallocate(rmemory_dux_dxl_x)
+ deallocate(rmemory_dux_dyl_x)
+ deallocate(rmemory_dux_dzl_x)
+ deallocate(rmemory_duy_dxl_x)
+ deallocate(rmemory_duy_dyl_x)
+ deallocate(rmemory_duz_dxl_x)
+ deallocate(rmemory_duz_dzl_x)
+ deallocate(rmemory_dux_dxl_y)
+ deallocate(rmemory_dux_dyl_y)
+ deallocate(rmemory_duy_dxl_y)
+ deallocate(rmemory_duy_dyl_y)
+ deallocate(rmemory_duy_dzl_y)
+ deallocate(rmemory_duz_dyl_y)
+ deallocate(rmemory_duz_dzl_y)
+ deallocate(rmemory_dux_dxl_z)
+ deallocate(rmemory_dux_dzl_z)
+ deallocate(rmemory_duy_dyl_z)
+ deallocate(rmemory_duy_dzl_z)
+ deallocate(rmemory_duz_dxl_z)
+ deallocate(rmemory_duz_dyl_z)
+ deallocate(rmemory_duz_dzl_z)
+ deallocate(rmemory_dpotential_dxl)
+ deallocate(rmemory_dpotential_dyl)
+ deallocate(rmemory_dpotential_dzl)
+ deallocate(rmemory_displ_elastic)
+ deallocate(rmemory_potential_acoustic)
+ deallocate(accel_elastic_CPML)
+ deallocate(potential_dot_dot_acoustic_CPML)
+ endif
+
+ deallocate(ibelm_xmin)
+ deallocate(ibelm_xmax)
+ deallocate(ibelm_ymin)
+ deallocate(ibelm_ymax)
+ deallocate(ibelm_bottom)
+ deallocate(ibelm_top)
+
! close the main output file
if(myrank == 0) then
write(IMAIN,*)
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/initialize_simulation.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/initialize_simulation.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -33,6 +33,7 @@
use specfem_par_acoustic
use specfem_par_poroelastic
use specfem_par_movie
+
implicit none
integer :: ier
@@ -48,7 +49,8 @@
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD, &
NTSTEP_BETWEEN_READ_ADJSRC,NOISE_TOMOGRAPHY, &
USE_FORCE_POINT_SOURCE,ABSORB_INSTEAD_OF_FREE_SURFACE, &
- USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,IMODEL)
+ USE_RICKER_TIME_FUNCTION,OLSEN_ATTENUATION_RATIO,PML_CONDITIONS, &
+ PML_INSTEAD_OF_FREE_SURFACE,PML_WIDTH_MIN,PML_WIDTH_MAX,f0_FOR_PML,IMODEL)
! GPU_MODE is in par_file
call read_gpu_mode(GPU_MODE,GRAVITY)
@@ -260,21 +262,52 @@
! gravity only on GPU supported
if( .not. GPU_MODE .and. GRAVITY ) &
stop 'GRAVITY only supported in GPU mode'
-
+
! absorbing surfaces
if( ABSORBING_CONDITIONS ) then
- ! for arbitrary orientation of elements, which face belongs to xmin,xmax,etc... -
- ! does it makes sense to have different NGLLX,NGLLY,NGLLZ?
- ! there is a problem with absorbing boundaries for faces with different NGLLX,NGLLY,NGLLZ values
- ! just to be sure for now..
- if( NGLLX /= NGLLY .and. NGLLY /= NGLLZ ) &
- stop 'ABSORBING_CONDITIONS must have NGLLX = NGLLY = NGLLZ'
+ ! for arbitrary orientation of elements, which face belongs to xmin,xmax,etc... -
+ ! does it makes sense to have different NGLLX,NGLLY,NGLLZ?
+ ! there is a problem with absorbing boundaries for faces with different NGLLX,NGLLY,NGLLZ values
+ ! just to be sure for now..
+ if( NGLLX /= NGLLY .and. NGLLY /= NGLLZ ) &
+ stop 'ABSORBING_CONDITIONS must have NGLLX = NGLLY = NGLLZ'
+ if( PML_CONDITIONS ) then
+ print*, 'please modify Par_file and recompile solver'
+ stop 'ABSORBING_CONDITIONS and PML_CONDITIONS are both set to .true.'
+ elseif( PML_INSTEAD_OF_FREE_SURFACE ) then
+ print*, 'please modify Par_file and recompile solver'
+ stop 'PML_INSTEAD_OF_FREE_SURFACE = .true. is incompatible with ABSORBING_CONDITIONS = .true.'
+ endif
else
- ! absorbing top surface
- if(ABSORB_INSTEAD_OF_FREE_SURFACE) &
- stop 'ABSORBING_CONDITIONS must be activated when ABSORB_INSTEAD_OF_FREE_SURFACE is true'
+ if( ABSORB_INSTEAD_OF_FREE_SURFACE ) then
+ print*, 'please modify Par_file and recompile solver'
+ stop 'ABSORBING_CONDITIONS must be activated when ABSORB_INSTEAD_OF_FREE_SURFACE is set to .true.'
+ endif
endif
+ if( PML_CONDITIONS ) then
+ if( ABSORB_INSTEAD_OF_FREE_SURFACE ) then
+ print*, 'please modify Par_file and recompile solver'
+ stop 'ABSORB_INSTEAD_OF_FREE_SURFACE = .true. is incompatible with PML_CONDITIONS = .true.'
+ elseif( .not. SUPPRESS_UTM_PROJECTION ) then
+ print*, 'please modify Par_file and recompile solver'
+ stop 'SUPPRESS_UTM_PROJECTION must be activated when PML_CONDITIONS is set to .true.'
+ endif
+ else
+ if( PML_INSTEAD_OF_FREE_SURFACE ) &
+ stop 'PML_CONDITIONS must be activated when PML_INSTEAD_OF_FREE_SURFACE is set to .true.'
+ endif
+
+ if( ABSORB_INSTEAD_OF_FREE_SURFACE .and. PML_INSTEAD_OF_FREE_SURFACE ) then
+ print*, 'please modify Par_file and recompile solver'
+ stop 'error: ABSORB_INSTEAD_OF_FREE_SURFACE and PML_INSTEAD_OF_FREE_SURFACE are both set to .true.'
+ endif
+
+ ! checks the MOVIE_TYPE parameter
+ if( MOVIE_TYPE /= 1 .and. MOVIE_TYPE /= 2 ) then
+ stop 'error: MOVIE_TYPE must be either 1 or 2! Please modify Par_file and recompile solver'
+ endif
+
! check that the code has been compiled with the right values
if( myrank == 0 ) then
call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', &
@@ -369,7 +402,9 @@
use specfem_par_elastic
use specfem_par_acoustic
use specfem_par_poroelastic
+
implicit none
+
! local parameters
integer :: ncuda_devices,ncuda_devices_min,ncuda_devices_max
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/iterate_time.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/iterate_time.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/iterate_time.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -33,6 +33,7 @@
use specfem_par_elastic
use specfem_par_poroelastic
use specfem_par_movie
+
implicit none
!
@@ -398,8 +399,7 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
- use PML_par
- use PML_par_acoustic
+
implicit none
! updates acoustic potentials
@@ -420,28 +420,6 @@
b_deltat, b_deltatsqover2, b_deltatover2)
endif
- ! time marching potentials
- if(ABSORB_USE_PML .and. ABSORBING_CONDITIONS) then
- if( GPU_MODE ) call transfer_fields_ac_from_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
-
- call PML_acoustic_time_march(NSPEC_AB,NGLOB_AB,ibool,&
- potential_acoustic,potential_dot_acoustic,&
- deltat,deltatsqover2,deltatover2,&
- num_PML_ispec,PML_ispec,PML_damping_d,&
- chi1,chi2,chi2_t,chi3,chi4,&
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot,&
- iglob_is_PML_interface,PML_mask_ibool,&
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh,&
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh,NPROC,&
- ispec_is_acoustic)
-
- if( GPU_MODE ) call transfer_fields_ac_to_device(NGLOB_AB,potential_acoustic, &
- potential_dot_acoustic, potential_dot_dot_acoustic, Mesh_pointer)
- endif
-
endif ! ACOUSTIC_SIMULATION
! updates elastic displacement and velocity
Added: seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_allocate_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_allocate_arrays.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_allocate_arrays.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -0,0 +1,239 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 2 . 1
+! ---------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA and CNRS / INRIA / University of Pau
+! (c) Princeton University / California Institute of Technology and CNRS / INRIA / University of Pau
+! July 2012
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+subroutine pml_allocate_arrays()
+
+ use pml_par
+ use specfem_par, only: NSPEC_AB
+ use constants, only: NDIM,NGLLX,NGLLY,NGLLZ
+
+ implicit none
+
+ ! local parameters
+ integer :: ier
+
+ ! C-PML spectral elements local indexing
+ allocate(spec_to_CPML(NSPEC_AB),stat=ier)
+ if(ier /= 0) stop 'error allocating array spec_to_CPML'
+
+ ! C-PML element type array: 1 = face, 2 = edge, 3 = corner
+ allocate(CPML_type(NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating array CPML_type'
+
+ ! stores derivatives of ux, uy and uz with respect to x, y and z
+ allocate(PML_dux_dxl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dux_dxl array'
+ allocate(PML_dux_dyl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dux_dyl array'
+ allocate(PML_dux_dzl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dux_dzl array'
+ allocate(PML_duy_dxl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duy_dxl array'
+ allocate(PML_duy_dyl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duy_dyl array'
+ allocate(PML_duy_dzl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duy_dzl array'
+ allocate(PML_duz_dxl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duz_dxl array'
+ allocate(PML_duz_dyl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duz_dyl array'
+ allocate(PML_duz_dzl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duz_dzl array'
+
+ allocate(PML_dux_dxl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dux_dxl_new array'
+ allocate(PML_dux_dyl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dux_dyl_new array'
+ allocate(PML_dux_dzl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dux_dzl_new array'
+ allocate(PML_duy_dxl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duy_dxl_new array'
+ allocate(PML_duy_dyl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duy_dyl_new array'
+ allocate(PML_duy_dzl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duy_dzl_new array'
+ allocate(PML_duz_dxl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duz_dxl_new array'
+ allocate(PML_duz_dyl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duz_dyl_new array'
+ allocate(PML_duz_dzl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_duz_dzl_new array'
+
+ ! stores derivatives of potential with respect to x, y and z
+ allocate(PML_dpotential_dxl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dpotential_dxl array'
+ allocate(PML_dpotential_dyl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dpotential_dxl array'
+ allocate(PML_dpotential_dzl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dpotential_dxl array'
+
+ allocate(PML_dpotential_dxl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dpotential_dxl_new array'
+ allocate(PML_dpotential_dyl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dpotential_dxl_new array'
+ allocate(PML_dpotential_dzl_new(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating PML_dpotential_dxl_new array'
+
+ ! stores C-PML memory variables
+ allocate(rmemory_dux_dxl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_dux_dxl_x array'
+ allocate(rmemory_dux_dyl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_dux_dyl_x array'
+ allocate(rmemory_dux_dzl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_dux_dzl_x array'
+ allocate(rmemory_duy_dxl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duy_dxl_x array'
+ allocate(rmemory_duy_dyl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duy_dyl_x array'
+ allocate(rmemory_duz_dxl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duz_dxl_x array'
+ allocate(rmemory_duz_dzl_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duz_dzl_x array'
+
+ allocate(rmemory_dux_dxl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_dux_dxl_y array'
+ allocate(rmemory_dux_dyl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_dux_dyl_y array'
+ allocate(rmemory_duy_dxl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duy_dxl_y array'
+ allocate(rmemory_duy_dyl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duy_dyl_y array'
+ allocate(rmemory_duy_dzl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duy_dzl_y array'
+ allocate(rmemory_duz_dyl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duz_dyl_y array'
+ allocate(rmemory_duz_dzl_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duz_dzl_y array'
+
+ allocate(rmemory_dux_dxl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_dux_dxl_z array'
+ allocate(rmemory_dux_dzl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_dux_dzl_z array'
+ allocate(rmemory_duy_dyl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duy_dyl_z array'
+ allocate(rmemory_duy_dzl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duy_dzl_z array'
+ allocate(rmemory_duz_dxl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duz_dxl_z array'
+ allocate(rmemory_duz_dyl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duz_dyl_z array'
+ allocate(rmemory_duz_dzl_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_duz_dzl_z array'
+
+ allocate(rmemory_dpotential_dxl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_dpotential_dxl array'
+ allocate(rmemory_dpotential_dyl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_dpotential_dyl array'
+ allocate(rmemory_dpotential_dzl(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_dpotential_dzl array'
+
+ ! stores C-PML memory variables needed for displacement
+ allocate(rmemory_displ_elastic(NDIM,NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_displ_elastic array'
+
+ ! stores C-PML memory variables needed for potential
+ allocate(rmemory_potential_acoustic(NGLLX,NGLLY,NGLLZ,NSPEC_CPML,3),stat=ier)
+ if(ier /= 0) stop 'error allocating rmemory_displ_elastic array'
+
+ ! stores C-PML contribution to update acceleration to the global mesh
+ allocate(accel_elastic_CPML(NDIM,NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating accel_elastic_CPML array'
+
+ ! stores C-PML contribution to update the second derivative of the potential to the global mesh
+ allocate(potential_dot_dot_acoustic_CPML(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating potential_dot_dot_acoustic_CPML array'
+
+ spec_to_CPML(:) = 0
+
+ CPML_type(:) = 0
+
+ PML_dux_dxl(:,:,:,:) = 0._CUSTOM_REAL
+ PML_dux_dyl(:,:,:,:) = 0._CUSTOM_REAL
+ PML_dux_dzl(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duy_dxl(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duy_dyl(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duy_dzl(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duz_dxl(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duz_dyl(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duz_dzl(:,:,:,:) = 0._CUSTOM_REAL
+
+ PML_dux_dxl_new(:,:,:,:) = 0._CUSTOM_REAL
+ PML_dux_dyl_new(:,:,:,:) = 0._CUSTOM_REAL
+ PML_dux_dzl_new(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duy_dxl_new(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duy_dyl_new(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duy_dzl_new(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duz_dxl_new(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duz_dyl_new(:,:,:,:) = 0._CUSTOM_REAL
+ PML_duz_dzl_new(:,:,:,:) = 0._CUSTOM_REAL
+
+ PML_dpotential_dxl(:,:,:,:) = 0._CUSTOM_REAL
+ PML_dpotential_dyl(:,:,:,:) = 0._CUSTOM_REAL
+ PML_dpotential_dzl(:,:,:,:) = 0._CUSTOM_REAL
+
+ PML_dpotential_dxl_new(:,:,:,:) = 0._CUSTOM_REAL
+ PML_dpotential_dyl_new(:,:,:,:) = 0._CUSTOM_REAL
+ PML_dpotential_dzl_new(:,:,:,:) = 0._CUSTOM_REAL
+
+ rmemory_dux_dxl_x(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_dux_dyl_x(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_dux_dzl_x(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duy_dxl_x(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duy_dyl_x(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duz_dxl_x(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duz_dzl_x(:,:,:,:,:) = 0._CUSTOM_REAL
+
+ rmemory_dux_dxl_y(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_dux_dyl_y(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duy_dxl_y(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duy_dyl_y(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duy_dzl_y(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duz_dyl_y(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duz_dzl_y(:,:,:,:,:) = 0._CUSTOM_REAL
+
+ rmemory_dux_dxl_z(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_dux_dzl_z(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duy_dyl_z(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duy_dzl_z(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duz_dxl_z(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duz_dyl_z(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_duz_dzl_z(:,:,:,:,:) = 0._CUSTOM_REAL
+
+ rmemory_dpotential_dxl(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_dpotential_dyl(:,:,:,:,:) = 0._CUSTOM_REAL
+ rmemory_dpotential_dzl(:,:,:,:,:) = 0._CUSTOM_REAL
+
+ rmemory_displ_elastic(:,:,:,:,:,:) = 0._CUSTOM_REAL
+
+ rmemory_potential_acoustic(:,:,:,:,:) = 0._CUSTOM_REAL
+
+ accel_elastic_CPML(:,:,:,:,:) = 0._CUSTOM_REAL
+
+ potential_dot_dot_acoustic_CPML(:,:,:,:) = 0._CUSTOM_REAL
+
+end subroutine pml_allocate_arrays
Added: seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_output_VTKs.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_output_VTKs.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_output_VTKs.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -0,0 +1,101 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 2 . 1
+! ---------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA and CNRS / INRIA / University of Pau
+! (c) Princeton University / California Institute of Technology and CNRS / INRIA / University of Pau
+! July 2012
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+subroutine pml_output_VTKs()
+
+ ! outputs informations about C-PML elements in VTK-file format
+
+ use pml_par
+ use specfem_par, only: NGLOB_AB,NSPEC_AB,myrank,prname,xstore,ystore,zstore,ibool
+ use constants, only: NGLLX,NGLLY,NGLLZ,IMAIN
+
+ implicit none
+
+ ! local parameters
+ integer :: ispec,ispec_CPML,ier
+ integer, dimension(:), allocatable :: temp_CPML_regions
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable:: temp_d_store_x,temp_d_store_y,temp_d_store_z
+ character(len=256) :: vtkfilename
+
+ if(myrank == 0) write(IMAIN,*) 'Writing informations about C-PML elements in VTK-file format'
+
+ ! C-PML regions
+ allocate(temp_CPML_regions(NSPEC_AB),stat=ier)
+ if(ier /= 0) stop 'error allocating array temp_CPML_regions'
+
+ temp_CPML_regions(:) = 0
+
+ do ispec_CPML=1,nspec_cpml
+ ispec = CPML_to_spec(ispec_CPML)
+
+ temp_CPML_regions(ispec) = CPML_regions(ispec_CPML)
+ enddo
+
+ if(myrank == 0) write(IMAIN,*) 'Generating CPML_regions VTK file'
+
+ vtkfilename = prname(1:len_trim(prname))//'CPML_regions'
+ call write_VTK_data_elem_i(NSPEC_AB,NGLOB_AB,xstore,ystore,zstore,ibool,temp_CPML_regions,vtkfilename)
+
+ deallocate(temp_CPML_regions)
+
+ ! C-PML damping profile arrays
+ allocate(temp_d_store_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier)
+ if(ier /= 0) stop 'error allocating array temp_d_store_x'
+ allocate(temp_d_store_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier)
+ if(ier /= 0) stop 'error allocating array temp_d_store_y'
+ allocate(temp_d_store_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB),stat=ier)
+ if(ier /= 0) stop 'error allocating array temp_d_store_z'
+
+ temp_d_store_x(:,:,:,:) = 0._CUSTOM_REAL
+ temp_d_store_y(:,:,:,:) = 0._CUSTOM_REAL
+ temp_d_store_z(:,:,:,:) = 0._CUSTOM_REAL
+
+ do ispec_CPML=1,nspec_cpml
+ ispec = CPML_to_spec(ispec_CPML)
+
+ temp_d_store_x(:,:,:,ispec) = d_store_x(:,:,:,ispec_CPML)
+ temp_d_store_y(:,:,:,ispec) = d_store_y(:,:,:,ispec_CPML)
+ temp_d_store_z(:,:,:,ispec) = d_store_z(:,:,:,ispec_CPML)
+ enddo
+
+ if(myrank == 0) write(IMAIN,*) 'Generating CPML_damping_dx, CPML_damping_dy and CPML_damping_dz VTK files'
+
+ vtkfilename = prname(1:len_trim(prname))//'CPML_damping_dx'
+ call write_VTK_data_gll_cr(NSPEC_AB,NGLOB_AB,xstore,ystore,zstore,ibool,temp_d_store_x,vtkfilename)
+
+ vtkfilename = prname(1:len_trim(prname))//'CPML_damping_dy'
+ call write_VTK_data_gll_cr(NSPEC_AB,NGLOB_AB,xstore,ystore,zstore,ibool,temp_d_store_y,vtkfilename)
+
+ vtkfilename = prname(1:len_trim(prname))//'CPML_damping_dz'
+ call write_VTK_data_gll_cr(NSPEC_AB,NGLOB_AB,xstore,ystore,zstore,ibool,temp_d_store_z,vtkfilename)
+
+ deallocate(temp_d_store_x)
+ deallocate(temp_d_store_y)
+ deallocate(temp_d_store_z)
+
+end subroutine pml_output_VTKs
Added: seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_par.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_par.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_par.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -0,0 +1,108 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 2 . 1
+! ---------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA and CNRS / INRIA / University of Pau
+! (c) Princeton University / California Institute of Technology and CNRS / INRIA / University of Pau
+! July 2012
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+module pml_par
+
+ ! main parameter module for C-PML simulations
+
+ use constants, only: CUSTOM_REAL
+
+ implicit none
+
+ ! number of C-PML spectral elements
+ integer :: NSPEC_CPML
+
+ ! C-PML spectral elements global indexing
+ integer, dimension(:), allocatable :: CPML_to_spec
+
+ ! C-PML spectral elements local indexing
+ integer, dimension(:), allocatable :: spec_to_CPML
+
+ ! C-PML regions
+ integer, dimension(:), allocatable :: CPML_regions
+
+ ! C-PML element type array: 1 = face, 2 = edge, 3 = corner
+ integer, dimension(:), allocatable :: CPML_type
+
+ ! mask of C-PML elements for the global mesh
+ logical, dimension(:), allocatable :: CPML_mask_ibool
+
+ ! thickness of C-PML layers read in "absorbing_cpml_file.asc"
+ real(CUSTOM_REAL) :: CPML_width,CPML_width_x,CPML_width_y,CPML_width_z
+
+ ! C-PML damping profile arrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: d_store_x, d_store_y, d_store_z
+
+ ! auxiliary parameters arrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: K_store_x, K_store_y, K_store_z
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: alpha_store
+
+ ! derivatives of ux, uy and uz with respect to x, y and z
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: PML_dux_dxl,PML_dux_dyl,PML_dux_dzl
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: PML_duy_dxl,PML_duy_dyl,PML_duy_dzl
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: PML_duz_dxl,PML_duz_dyl,PML_duz_dzl
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: PML_dux_dxl_new,PML_dux_dyl_new,PML_dux_dzl_new
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: PML_duy_dxl_new,PML_duy_dyl_new,PML_duy_dzl_new
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: PML_duz_dxl_new,PML_duz_dyl_new,PML_duz_dzl_new
+
+ ! derivatives of potential with respect to x, y and z
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: PML_dpotential_dxl,PML_dpotential_dyl,PML_dpotential_dzl
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: PML_dpotential_dxl_new,PML_dpotential_dyl_new,PML_dpotential_dzl_new
+
+ ! C-PML memory variables
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_dux_dxl_x,rmemory_dux_dyl_x,rmemory_dux_dzl_x
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_duy_dxl_x,rmemory_duy_dyl_x
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_duz_dxl_x,rmemory_duz_dzl_x
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_dux_dxl_y,rmemory_dux_dyl_y
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_duy_dxl_y,rmemory_duy_dyl_y,rmemory_duy_dzl_y
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_duz_dzl_y,rmemory_duz_dyl_y
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_dux_dxl_z,rmemory_dux_dzl_z
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_duy_dyl_z,rmemory_duy_dzl_z
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_duz_dxl_z,rmemory_duz_dyl_z,rmemory_duz_dzl_z
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_dpotential_dxl
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_dpotential_dyl
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_dpotential_dzl
+
+ ! C-PML memory variable needed for displacement
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: rmemory_displ_elastic
+
+ ! C-PML memory variable needed for potential
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: rmemory_potential_acoustic
+
+ ! C-PML contribution to update acceleration to the global mesh
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: accel_elastic_CPML
+
+ ! C-PML contribution to update the second derivative of the potential to the global mesh
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: potential_dot_dot_acoustic_CPML
+
+end module pml_par
Added: seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_set_accel_contribution.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_set_accel_contribution.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_set_accel_contribution.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -0,0 +1,825 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 2 . 1
+! ---------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA and CNRS / INRIA / University of Pau
+! (c) Princeton University / California Institute of Technology and CNRS / INRIA / University of Pau
+! July 2012
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+subroutine pml_set_accel_contribution(ispec,ispec_CPML,deltat,jacobianl,accel_elastic_CPML)
+
+ ! calculates contribution from each C-PML element to update acceleration to the global mesh
+
+ use specfem_par, only: ibool,wgllwgll_yz,wgllwgll_xz,wgllwgll_xy,it,kappastore
+ use specfem_par_elastic, only: rho_vp,displ,veloc,ispec_is_elastic
+ use specfem_par_acoustic, only: potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic,ispec_is_acoustic
+ use pml_par, only: NSPEC_CPML,rmemory_displ_elastic,rmemory_potential_acoustic,CPML_regions,spec_to_CPML,alpha_store, &
+ d_store_x,d_store_y,d_store_z,K_store_x,K_store_y,K_store_z,potential_dot_dot_acoustic_CPML
+ use constants, only: CUSTOM_REAL,NDIM,NGLLX,NGLLY,NGLLZ
+
+ implicit none
+
+ integer, intent(in) :: ispec,ispec_CPML
+
+ real(kind=CUSTOM_REAL), intent(in) :: deltat,jacobianl
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSPEC_CPML), intent(out) :: accel_elastic_CPML
+
+ ! local parameters
+ integer :: i,j,k,iglob
+
+ real(kind=CUSTOM_REAL) :: fac1,fac2,fac3,fac4,rhol,kappal
+ real(kind=CUSTOM_REAL) :: bb,coef0_1,coef1_1,coef2_1,coef0_2,coef1_2,coef2_2,coef0_3,coef1_3,coef2_3
+ real(kind=CUSTOM_REAL) :: A0,A1,A2,A3,A4,A5 ! for convolution of acceleration
+ real(kind=CUSTOM_REAL) :: temp_A3,temp_A4,temp_A5
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ rhol = rho_vp(i,j,k,ispec)
+ kappal = kappastore(i,j,k,ispec)
+
+ iglob = ibool(i,j,k,ispec)
+
+ if( CPML_regions(ispec_CPML) == 1 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- X-surface C-PML ---------------------------------
+ !------------------------------------------------------------------------------
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) / bb
+ coef2_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) * exp(-bb * deltat/2.0d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * coef1_1 + displ(1,iglob) * coef2_1
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) = 0.0
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) = 0.0
+
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * coef1_1 + displ(2,iglob) * coef2_1
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) = 0.0
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) = 0.0
+
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * coef1_1 + displ(3,iglob) * coef2_1
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) = 0.0
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) = 0.0
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,1)=coef0_1 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * coef1_1 &
+ + potential_acoustic(iglob) * coef2_1
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,2)=0.0
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,3)=0.0
+ endif
+
+ !---------------------- A0, A1, A2, A3, A4 and A5 --------------------------
+ A0 = k_store_x(i,j,k,ispec_CPML)
+ A1 = d_store_x(i,j,k,ispec_CPML)
+ A2 = - alpha_store(i,j,k,ispec_CPML) * d_store_x(i,j,k,ispec_CPML)
+ A3 = d_store_x(i,j,k,ispec_CPML) * alpha_store(i,j,k,ispec_CPML) ** 2
+ A4 = 0.d0
+ A5 = 0.d0
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+ fac4 = sqrt(fac1 * fac2 * fac3)
+
+ if( ispec_is_elastic(ispec) ) then
+
+ accel_elastic_CPML(1,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(1,iglob) + A2 * displ(1,iglob) + &
+ A3 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(2,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(2,iglob) + A2 * displ(2,iglob) + &
+ A3 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(3,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(3,iglob) + A2 * displ(3,iglob) + &
+ A3 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) &
+ )
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ potential_dot_dot_acoustic_CPML(i,j,k,ispec_CPML) = fac4 * 1.0/kappal *jacobianl * &
+ ( A1 * potential_dot_acoustic(iglob) + A2 * potential_acoustic(iglob) + &
+ A3 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1)+ &
+ A4 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2)+ &
+ A5 * rmemory_potential_acoustic(i,j,k,ispec_CPML,3) &
+ )
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 2 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- Y-surface C-PML ---------------------------------
+ !------------------------------------------------------------------------------
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) / bb
+ coef2_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) * exp(-bb * deltat/2.0d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * coef1_1 + displ(1,iglob) * coef2_1
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) = 0.0
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) = 0.0
+
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * coef1_1 + displ(2,iglob) * coef2_1
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) = 0.0
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) = 0.0
+
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * coef1_1 + displ(3,iglob) * coef2_1
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) = 0.0
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) = 0.0
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,1)=coef0_1 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * coef1_1 &
+ + potential_acoustic(iglob) * coef2_1
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,2)=0.0
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,3)=0.0
+ endif
+
+ !---------------------- A0, A1, A2, A3, A4 and A5 --------------------------
+ A0 = k_store_y(i,j,k,ispec_CPML)
+ A1 = d_store_y(i,j,k,ispec_CPML)
+ A2 = - alpha_store(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML)
+ A3 = d_store_y(i,j,k,ispec_CPML) * alpha_store(i,j,k,ispec_CPML) ** 2
+ A4 = 0.d0
+ A5 = 0.d0
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+ fac4 = sqrt(fac1 * fac2 * fac3)
+
+ if( ispec_is_elastic(ispec) ) then
+
+ accel_elastic_CPML(1,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(1,iglob) + A2 * displ(1,iglob) + &
+ A3 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(2,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(2,iglob) + A2 * displ(2,iglob) + &
+ A3 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(3,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(3,iglob) + A2 * displ(3,iglob) + &
+ A3 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) &
+ )
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ potential_dot_dot_acoustic_CPML(i,j,k,ispec_CPML) = fac4 * 1.0/kappal *jacobianl * &
+ ( A1 * potential_dot_acoustic(iglob) + A2 * potential_acoustic(iglob) + &
+ A3 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1)+ &
+ A4 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2)+ &
+ A5 * rmemory_potential_acoustic(i,j,k,ispec_CPML,3) &
+ )
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 3 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- Z-surface C-PML ---------------------------------
+ !------------------------------------------------------------------------------
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) / bb
+ coef2_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) * exp(-bb * deltat/2.0d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * coef1_1 + displ(1,iglob) * coef2_1
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) = 0.0
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) = 0.0
+
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * coef1_1 + displ(2,iglob) * coef2_1
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) = 0.0
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) = 0.0
+
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * coef1_1 + displ(3,iglob) * coef2_1
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) = 0.0
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) = 0.0
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,1)=coef0_1 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * coef1_1 &
+ + potential_acoustic(iglob) * coef2_1
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,2)=0.0
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,3)=0.0
+ endif
+
+ !---------------------- A0, A1, A2, A3, A4 and A5 --------------------------
+ A0 = k_store_z(i,j,k,ispec_CPML)
+ A1 = d_store_z(i,j,k,ispec_CPML)
+ A2 = - alpha_store(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+ A3 = d_store_z(i,j,k,ispec_CPML) * alpha_store(i,j,k,ispec_CPML) ** 2
+ A4 = 0.d0
+ A5 = 0.d0
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+ fac4 = sqrt(fac1 * fac2 * fac3)
+
+ if( ispec_is_elastic(ispec) ) then
+
+ accel_elastic_CPML(1,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(1,iglob) + A2 * displ(1,iglob) + &
+ A3 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(2,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(2,iglob) + A2 * displ(2,iglob) + &
+ A3 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(3,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(3,iglob) + A2 * displ(3,iglob) + &
+ A3 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) &
+ )
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ potential_dot_dot_acoustic_CPML(i,j,k,ispec_CPML) = fac4 * 1.0/kappal *jacobianl * &
+ ( A1 * potential_dot_acoustic(iglob) + A2 * potential_acoustic(iglob) + &
+ A3 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1)+ &
+ A4 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2)+ &
+ A5 * rmemory_potential_acoustic(i,j,k,ispec_CPML,3) &
+ )
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 4 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- XY-edge C-PML -----------------------------------
+ !------------------------------------------------------------------------------
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) / bb
+ coef2_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) * exp(-bb * deltat/2.0d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ coef0_2 = coef0_1
+ coef1_2 = coef1_1
+ coef2_2 = coef2_1
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * coef1_1 + displ(1,iglob) * coef2_1
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(1,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) = 0.0
+
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * coef1_1 + displ(2,iglob) * coef2_1
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(2,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) = 0.0
+
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * coef1_1 + displ(3,iglob) * coef2_1
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(3,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) = 0.0
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,1)=coef0_1 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * coef1_1 &
+ + potential_acoustic(iglob) * coef2_1
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,2)=coef0_2 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * (it+0.5)*deltat * coef1_2 &
+ + potential_acoustic(iglob) * (it-0.5)*deltat * coef2_2
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,3)=0.0
+ endif
+
+ !---------------------- A0, A1, A2, A3, A4 and A5 --------------------------
+ A0 = k_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML)
+ A1 = d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) &
+ + d_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML)
+ A2 = d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) &
+ - alpha_store(i,j,k,ispec_CPML) * d_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) &
+ - alpha_store(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML)
+ if( ispec_is_elastic(ispec) ) then
+ A3 = -2.0 * alpha_store(i,j,k,ispec_CPML) * d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) &
+ + alpha_store(i,j,k,ispec_CPML)**2 * ( d_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) &
+ + d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) ) + alpha_store(i,j,k,ispec_CPML)**2 &
+ * (it+0.0) * deltat * d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML)
+ elseif( ispec_is_acoustic(ispec) ) then
+ A3 = -2.0 * alpha_store(i,j,k,ispec_CPML) * d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) + &
+ alpha_store(i,j,k,ispec_CPML)**2 * ( d_store_x(i,j,k,ispec_CPML)*k_store_y(i,j,k,ispec_CPML) &
+ + d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) ) + alpha_store(i,j,k,ispec_CPML)**2 &
+ * (it+0.5) * deltat * d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML)
+ endif
+ A4 = -alpha_store(i,j,k,ispec_CPML)**2 * d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML)
+ A5 = 0.0
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+ fac4 = sqrt(fac1 * fac2 * fac3)
+
+ if( ispec_is_elastic(ispec) ) then
+
+ accel_elastic_CPML(1,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(1,iglob) + A2 * displ(1,iglob) + &
+ A3 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(2,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(2,iglob) + A2 * displ(2,iglob) + &
+ A3 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(3,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(3,iglob) + A2 * displ(3,iglob) + &
+ A3 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) &
+ )
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ potential_dot_dot_acoustic_CPML(i,j,k,ispec_CPML) = fac4 * 1.0/kappal *jacobianl * &
+ ( A1 * potential_dot_acoustic(iglob) + A2 * potential_acoustic(iglob) + &
+ A3 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1)+ &
+ A4 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2)+ &
+ A5 * rmemory_potential_acoustic(i,j,k,ispec_CPML,3) &
+ )
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 5 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- XZ-edge C-PML -----------------------------------
+ !------------------------------------------------------------------------------
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) / bb
+ coef2_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) * exp(-bb * deltat/2.0d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ coef0_2 = coef0_1
+ coef1_2 = coef1_1
+ coef2_2 = coef2_1
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * coef1_1 + displ(1,iglob) * coef2_1
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(1,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,3)= 0.0
+
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * coef1_1 + displ(2,iglob) * coef2_1
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(2,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,3)= 0.0
+
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * coef1_1 + displ(3,iglob) * coef2_1
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(3,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,3)= 0.0
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,1)=coef0_1 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * coef1_1 &
+ + potential_acoustic(iglob) * coef2_1
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,2)=coef0_2 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * (it+0.5)*deltat * coef1_2 &
+ + potential_acoustic(iglob) * (it-0.5)*deltat * coef2_2
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,3)= 0.0
+ endif
+
+ !---------------------- A0, A1, A2, A3, A4 and A5 --------------------------
+ A0 = k_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML)
+ A1 = d_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML)&
+ + d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML)
+ A2 = d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) &
+ - alpha_store(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) &
+ - alpha_store(i,j,k,ispec_CPML) * d_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML)
+ if( ispec_is_elastic(ispec) ) then
+ A3 = -2.0 * alpha_store(i,j,k,ispec_CPML) * d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) &
+ + alpha_store(i,j,k,ispec_CPML)**2 * ( d_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) &
+ + d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) ) + alpha_store(i,j,k,ispec_CPML)**2 &
+ * (it+0.0) * deltat * d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+ elseif( ispec_is_acoustic(ispec) ) then
+ A3 = -2.0 * alpha_store(i,j,k,ispec_CPML) * d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) &
+ + alpha_store(i,j,k,ispec_CPML)**2 * ( d_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) &
+ + d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) ) + alpha_store(i,j,k,ispec_CPML)**2 &
+ * (it+0.5) * deltat * d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+ endif
+ A4 = -alpha_store(i,j,k,ispec_CPML)**2 * d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+ A5 = 0.0
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+ fac4 = sqrt(fac1 * fac2 * fac3)
+
+ if( ispec_is_elastic(ispec) ) then
+
+ accel_elastic_CPML(1,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(1,iglob) + A2 * displ(1,iglob) + &
+ A3 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(2,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(2,iglob) + A2 * displ(2,iglob) + &
+ A3 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(3,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(3,iglob) + A2 * displ(3,iglob) + &
+ A3 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) &
+ )
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ potential_dot_dot_acoustic_CPML(i,j,k,ispec_CPML) = fac4 * 1.0/kappal *jacobianl * &
+ ( A1 * potential_dot_acoustic(iglob) + A2 * potential_acoustic(iglob) + &
+ A3 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1)+ &
+ A4 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2)+ &
+ A5 * rmemory_potential_acoustic(i,j,k,ispec_CPML,3) &
+ )
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 6 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- YZ-edge C-PML -----------------------------------
+ !------------------------------------------------------------------------------
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) / bb
+ coef2_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) * exp(-bb * deltat/2.0d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ coef0_2 = coef0_1
+ coef1_2 = coef1_1
+ coef2_2 = coef2_1
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * coef1_1 + displ(1,iglob) * coef2_1
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(1,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,3)=0.d0
+
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * coef1_1 + displ(2,iglob) * coef2_1
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(2,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,3)=0.d0
+
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * coef1_1 + displ(3,iglob) * coef2_1
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(3,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,3)=0.d0
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,1)=coef0_1 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * coef1_1 &
+ + potential_acoustic(iglob) * coef2_1
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,2)=coef0_2 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * (it+0.5)*deltat * coef1_2 &
+ + potential_acoustic(iglob) * (it-0.5)*deltat * coef2_2
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,3)=0.d0
+ endif
+
+ !---------------------- A0, A1, A2, A3, A4 and A5 --------------------------
+ A0 = k_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML)
+ A1 = d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) &
+ + d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML)
+ A2 = d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) &
+ - alpha_store(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) &
+ - alpha_store(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML)
+ if( ispec_is_elastic(ispec) ) then
+ A3 = -2.0 * alpha_store(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) &
+ + alpha_store(i,j,k,ispec_CPML)**2 * ( d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) &
+ + d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) ) + alpha_store(i,j,k,ispec_CPML)**2 &
+ * (it+0.0) * deltat * d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+ elseif( ispec_is_acoustic(ispec) ) then
+ A3 = -2.0 * alpha_store(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) &
+ + alpha_store(i,j,k,ispec_CPML)**2 * ( d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) &
+ + d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) ) + alpha_store(i,j,k,ispec_CPML)**2 &
+ * (it+0.5) * deltat * d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+ endif
+ A4 = -alpha_store(i,j,k,ispec_CPML)**2 * d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+ A5 = 0.0
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+ fac4 = sqrt(fac1 * fac2 * fac3)
+
+ if( ispec_is_elastic(ispec) ) then
+
+ accel_elastic_CPML(1,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(1,iglob) + A2 * displ(1,iglob) + &
+ A3 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(2,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(2,iglob) + A2 * displ(2,iglob) + &
+ A3 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(3,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(3,iglob) + A2 * displ(3,iglob) + &
+ A3 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) &
+ )
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ potential_dot_dot_acoustic_CPML(i,j,k,ispec_CPML) = fac4 * 1.0/kappal *jacobianl * &
+ ( A1 * potential_dot_acoustic(iglob) + A2 * potential_acoustic(iglob) + &
+ A3 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1)+ &
+ A4 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2)+ &
+ A5 * rmemory_potential_acoustic(i,j,k,ispec_CPML,3) &
+ )
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 7 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- XYZ-corner C-PML --------------------------------
+ !------------------------------------------------------------------------------
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) / bb
+ coef2_1 = (1.0d0 - exp(-bb * deltat/2.0d0) ) * exp(-bb * deltat/2.0d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ coef0_2 = coef0_1
+ coef1_2 = coef1_1
+ coef2_2 = coef2_1
+
+ coef0_3 = coef0_1
+ coef1_3 = coef1_1
+ coef2_3 = coef2_1
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * coef1_1 + displ(1,iglob) * coef2_1
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(1,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) = coef0_3 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) &
+ + (displ(1,iglob) + deltat * veloc(1,iglob)) * ((it+0.0) * deltat)**2 * coef1_3 &
+ + displ(1,iglob) * ((it-0.0) * deltat)**2 * coef2_3
+
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * coef1_1 + displ(2,iglob) * coef2_1
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(2,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) = coef0_3 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) &
+ + (displ(2,iglob) + deltat * veloc(2,iglob)) * ((it+0.0) * deltat)**2 * coef1_3 &
+ + displ(2,iglob) * ((it-0.0) * deltat)**2 * coef2_3
+
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) = coef0_1 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * coef1_1 + displ(3,iglob) * coef2_1
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) = coef0_2 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * (it+0.0) * deltat * coef1_2 &
+ + displ(3,iglob) * (it-0.0) * deltat * coef2_2
+ rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) = coef0_3 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) &
+ + (displ(3,iglob) + deltat * veloc(3,iglob)) * ((it+0.0) * deltat)**2 * coef1_3 &
+ + displ(3,iglob) * ((it-0.0) * deltat)**2 * coef2_3
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,1)=coef0_1 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * coef1_1 &
+ + potential_acoustic(iglob) * coef2_1
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,2)=coef0_2 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * (it+0.5)*deltat * coef1_2 &
+ + potential_acoustic(iglob) * (it-0.5)*deltat * coef2_2
+ rmemory_potential_acoustic(i,j,k,ispec_CPML,3)=coef0_3 * rmemory_potential_acoustic(i,j,k,ispec_CPML,3) &
+ + (potential_acoustic(iglob) + deltat*potential_dot_acoustic(iglob)) * ((it+0.5)*deltat)**2 * coef1_3 &
+ + potential_acoustic(iglob) * ((it-0.5)*deltat)**2 * coef2_3
+ endif
+
+ !---------------------- A0, A1, A2, A3, A4 and A5 --------------------------
+ A0 = k_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML)
+ A1 = d_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) + &
+ d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) + &
+ d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML)
+ A2 = k_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) + &
+ k_store_y(i,j,k,ispec_CPML) * d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) + &
+ k_store_z(i,j,k,ispec_CPML) * d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) - &
+ d_store_x(i,j,k,ispec_CPML) * alpha_store(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) * &
+ k_store_z(i,j,k,ispec_CPML) - d_store_y(i,j,k,ispec_CPML) * alpha_store(i,j,k,ispec_CPML) * &
+ k_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) - d_store_z(i,j,k,ispec_CPML) * &
+ alpha_store(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML)
+ temp_A3 = d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) - &
+ 2.0 * alpha_store(i,j,k,ispec_CPML) * ( &
+ d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) + &
+ d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) + &
+ d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) &
+ ) + alpha_store(i,j,k,ispec_CPML)**2 * ( &
+ d_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) + &
+ d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) + &
+ d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) &
+ )
+ temp_A4 = -2.0 * alpha_store(i,j,k,ispec_CPML) * d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) * &
+ d_store_z(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)**2 * ( &
+ d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) + &
+ d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) + &
+ d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) &
+ )
+ temp_A5 = 0.5 * d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+
+ ! A3 = temp_A3 + (it+0.0) * deltat*temp_A4 + ((it+0.0) * deltat)**2*temp_A5
+ ! A4 = -temp_A4-2.0*(it+0.0) * deltat*temp_A5
+ ! A5 = temp_A5
+
+ if( ispec_is_elastic(ispec) ) then
+ A3 = temp_A3 + (it+0.0) * deltat*temp_A4 !+ ((it+0.0) * deltat)**2*temp_A5
+ A4 = -temp_A4 ! -2.0*(it+0.0) * deltat*temp_A5
+ elseif( ispec_is_acoustic(ispec)) then
+ A3 = temp_A3 + (it+0.5)*deltat*temp_A4 !+ ((it+0.5)*deltat)**2*temp_A5
+ A4 = -temp_A4 !-2.0*(it+0.5)*deltat*temp_A5
+ endif
+ A5 = 0.0 ! temp_A5
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+ fac4 = sqrt(fac1 * fac2 * fac3)
+
+ if( ispec_is_elastic(ispec) ) then
+
+ accel_elastic_CPML(1,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(1,iglob) + A2 * displ(1,iglob) + &
+ A3 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(1,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(2,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(2,iglob) + A2 * displ(2,iglob) + &
+ A3 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(2,i,j,k,ispec_CPML,3) &
+ )
+
+ accel_elastic_CPML(3,i,j,k,ispec_CPML) = fac4 * rhol * jacobianl * &
+ ( A1 * veloc(3,iglob) + A2 * displ(3,iglob) + &
+ A3 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,1) + &
+ A4 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,2) + &
+ A5 * rmemory_displ_elastic(3,i,j,k,ispec_CPML,3) &
+ )
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ potential_dot_dot_acoustic_CPML(i,j,k,ispec_CPML) = fac4 * 1.0/kappal *jacobianl * &
+ ( A1 * potential_dot_acoustic(iglob) + A2 * potential_acoustic(iglob) + &
+ A3 * rmemory_potential_acoustic(i,j,k,ispec_CPML,1)+ &
+ A4 * rmemory_potential_acoustic(i,j,k,ispec_CPML,2)+ &
+ A5 * rmemory_potential_acoustic(i,j,k,ispec_CPML,3) &
+ )
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+end subroutine pml_set_accel_contribution
Added: seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_set_memory_variables.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_set_memory_variables.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/pml_set_memory_variables.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -0,0 +1,2128 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 2 . 1
+! ---------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA and CNRS / INRIA / University of Pau
+! (c) Princeton University / California Institute of Technology and CNRS / INRIA / University of Pau
+! July 2012
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+subroutine pml_set_memory_variables(ispec,ispec_CPML,deltat,jacobianl,tempx1,tempy1,tempz1,tempx2,tempy2,tempz2, &
+ tempx3,tempy3,tempz3,sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz, &
+ sigma_yx,sigma_zx,sigma_zy,lambdal,mul,lambdalplus2mul,xixl,xiyl,xizl, &
+ etaxl,etayl,etazl,gammaxl,gammayl,gammazl)
+
+ ! calculates C-PML elastic memory variables and computes stress sigma
+
+ use specfem_par, only: it
+ use specfem_par_elastic, only: ispec_is_elastic
+ use specfem_par_acoustic, only: ispec_is_acoustic
+ use pml_par
+ use constants, only: NGLLX,NGLLY,NGLLZ
+
+ implicit none
+
+ integer, intent(in) :: ispec,ispec_CPML
+
+ real(kind=CUSTOM_REAL), intent(in) :: lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL), intent(in) :: deltat,xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ), intent(out) :: tempx1,tempx2,tempx3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ), intent(out) :: tempy1,tempy2,tempy3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ), intent(out) :: tempz1,tempz2,tempz3
+
+ ! local parameters
+ integer :: i,j,k
+
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz,sigma_yx,sigma_zx,sigma_zy
+ real(kind=CUSTOM_REAL) :: duxdxl_x,duxdyl_x,duxdzl_x,duydxl_x,duydyl_x,duzdxl_x,duzdzl_x
+ real(kind=CUSTOM_REAL) :: duxdxl_y,duxdyl_y,duydxl_y,duydyl_y,duydzl_y,duzdyl_y,duzdzl_y
+ real(kind=CUSTOM_REAL) :: duxdxl_z,duxdzl_z,duydyl_z,duydzl_z,duzdxl_z,duzdyl_z,duzdzl_z
+ real(kind=CUSTOM_REAL) :: dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) :: bb,coef0_1,coef1_1,coef2_1,coef0_2,coef1_2,coef2_2
+ real(kind=CUSTOM_REAL) :: A6,A7,A8,A9,A10,A11,A12,A13,A14,A15,A16,A17 ! for convolution of strain(complex)
+ real(kind=CUSTOM_REAL) :: A18,A19,A20 ! for convolution of strain(simple)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( CPML_regions(ispec_CPML) == 1 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- X-surface C-PML ---------------------------------
+ !------------------------------------------------------------------------------
+
+ !---------------------- A6, A7 and A8 --------------------------
+ A6 = 1.d0 / k_store_x(i,j,k,ispec_CPML)
+ A7 = 0.d0
+ A8 = - d_store_x(i,j,k,ispec_CPML) / (k_store_x(i,j,k,ispec_CPML)**2)
+
+ bb = d_store_x(i,j,k,ispec_CPML) / k_store_x(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_2 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ duxdxl_x = A6 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) + A8 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2)
+ duydxl_y = A6 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) + A8 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2)
+ duzdxl_z = A6 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) + A8 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ dpotentialdxl = A6 * PML_dpotential_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) + A8 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A9, A10 and A11 --------------------------
+ A9 = k_store_x(i,j,k,ispec_CPML)
+ A10 = d_store_x(i,j,k,ispec_CPML)
+ A11 = 0.d0
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdyl_x = A9 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) + A11 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2)
+ duydyl_y = A9 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) + A11 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2)
+ duzdyl_z = A9 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) + A11 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) = 0.d0
+
+ dpotentialdyl = A9 * PML_dpotential_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) + A11 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A12, A13 and A14 --------------------------
+ A12 = k_store_x(i,j,k,ispec_CPML)
+ A13 = d_store_x(i,j,k,ispec_CPML)
+ A14 = 0.d0
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdzl_x = A12 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) + A14 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2)
+ duydzl_y = A12 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) + A14 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2)
+ duzdzl_z = A12 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) + A14 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) = 0.d0
+
+ dpotentialdzl = A12 * PML_dpotential_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) + A14 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2)
+ endif
+
+ if( ispec_is_elastic(ispec) ) then
+ !---------------------- A15 and A16 --------------------------
+ A15 = k_store_x(i,j,k,ispec_CPML)
+ A16 = d_store_x(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_y = A15 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_y(i,j,k,ispec_CPML,2)
+ duzdyl_y = A15 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dyl_y(i,j,k,ispec_CPML,2)
+
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydzl_z = A15 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dzl_z(i,j,k,ispec_CPML,2)
+ duydyl_z = A15 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_z(i,j,k,ispec_CPML,2)
+
+
+ !---------------------- A17 and A18 --------------------------
+ A17 = 1.d0
+ A18 = 0.0
+
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_x = A17 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_x(i,j,k,ispec_CPML,2)
+ duzdxl_x = A17 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdzl_z = A17 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dzl_z(i,j,k,ispec_CPML,2)
+ duxdxl_z = A17 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_z(i,j,k,ispec_CPML,2)
+
+
+ !---------------------- A19 and A20 --------------------------
+ A19 = 1.d0
+ A20 = 0.0
+
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydyl_x = A19 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_x(i,j,k,ispec_CPML,2)
+ duydxl_x = A19 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdyl_y = A19 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dyl_y(i,j,k,ispec_CPML,2)
+ duxdxl_y = A19 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_y(i,j,k,ispec_CPML,2)
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 2 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- Y-surface C-PML ---------------------------------
+ !------------------------------------------------------------------------------
+
+ !---------------------- A6, A7 and A8 --------------------------
+ A6 = k_store_y(i,j,k,ispec_CPML)
+ A7 = d_store_y(i,j,k,ispec_CPML)
+ A8 = 0.d0
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdxl_x = A6 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) + A8 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2)
+ duydxl_y = A6 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) + A8 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2)
+ duzdxl_z = A6 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) + A8 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) = 0.d0
+
+ dpotentialdxl = A6 * PML_dpotential_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) + A8 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A9, A10 and A11 --------------------------
+ A9 = 1.d0/k_store_y(i,j,k,ispec_CPML)
+ A10 = 0.d0
+ A11 = - d_store_y(i,j,k,ispec_CPML) / (k_store_y(i,j,k,ispec_CPML) ** 2)
+
+ bb = d_store_y(i,j,k,ispec_CPML) / k_store_y(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_2 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ duxdyl_x = A9 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) + A11 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2)
+ duydyl_y = A9 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) + A11 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2)
+ duzdyl_z = A9 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) + A11 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ dpotentialdyl = A9 * PML_dpotential_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) + A11 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A12, A13 and A14 --------------------------
+ A12 = k_store_y(i,j,k,ispec_CPML)
+ A13 = d_store_y(i,j,k,ispec_CPML)
+ A14 = 0.d0
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdzl_x = A12 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) + A14 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2)
+ duydzl_y = A12 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) + A14 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2)
+ duzdzl_z = A12 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) + A14 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) = 0.d0
+
+ dpotentialdzl = A12 * PML_dpotential_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) + A14 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2)
+ endif
+
+ if( ispec_is_elastic(ispec) ) then
+ !---------------------- A15 and A16 --------------------------
+ A15 = 1.d0
+ A16 = 0.d0
+
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_y = A15 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_y(i,j,k,ispec_CPML,2)
+ duzdyl_y = A15 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dyl_y(i,j,k,ispec_CPML,2)
+
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydzl_z = A15 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dzl_z(i,j,k,ispec_CPML,2)
+ duydyl_z = A15 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A17 and A18 --------------------------
+ A17 = k_store_y(i,j,k,ispec_CPML)
+ A18 = d_store_y(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_x = A17 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_x(i,j,k,ispec_CPML,2)
+ duzdxl_x = A17 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdzl_z = A17 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dzl_z(i,j,k,ispec_CPML,2)
+ duxdxl_z = A17 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_z(i,j,k,ispec_CPML,2)
+
+
+ !---------------------- A19 and A20--------------------------
+ A19 = 1.d0
+ A20 = 0.0
+
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydyl_x = A19 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_x(i,j,k,ispec_CPML,2)
+ duydxl_x = A19 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdyl_y = A19 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dyl_y(i,j,k,ispec_CPML,2)
+ duxdxl_y = A19 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_y(i,j,k,ispec_CPML,2)
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 3 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- Z-surface C-PML ---------------------------------
+ !------------------------------------------------------------------------------
+
+ !---------------------- A6, A7 and A8 --------------------------
+ A6 = k_store_z(i,j,k,ispec_CPML)
+ A7 = d_store_z(i,j,k,ispec_CPML)
+ A8 = 0.d0
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdxl_x = A6 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) + A8 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2)
+ duydxl_y = A6 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) + A8 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2)
+ duzdxl_z = A6 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) + A8 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) = 0.d0
+
+ dpotentialdxl = A6 * PML_dpotential_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) + A8 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A9, A10 and A11 --------------------------
+ A9 = k_store_z(i,j,k,ispec_CPML)
+ A10 = d_store_z(i,j,k,ispec_CPML)
+ A11 = 0.d0
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdyl_x = A9 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) + A11 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2)
+ duydyl_y = A9 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) + A11 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2)
+ duzdyl_z = A9 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) + A11 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) = 0.d0
+
+ dpotentialdyl = A9 * PML_dpotential_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) + A11 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A12, A13 and A14 --------------------------
+ A12 = 1.0 / k_store_z(i,j,k,ispec_CPML)
+ A13 = 0.d0
+ A14 = - d_store_z(i,j,k,ispec_CPML) / (k_store_z(i,j,k,ispec_CPML) ** 2)
+
+ bb = d_store_z(i,j,k,ispec_CPML) / k_store_z(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_2 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ duxdzl_x = A12 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) + A14 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2)
+ duydzl_y = A12 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) + A14 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2)
+ duzdzl_z = A12 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) + A14 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ dpotentialdzl = A12 * PML_dpotential_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) + A14 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2)
+ endif
+
+ if( ispec_is_elastic(ispec) ) then
+ !---------------------- A15 and A16 --------------------------
+ A15 = 1.d0
+ A16 = 0.d0
+
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_y = A15 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_y(i,j,k,ispec_CPML,2)
+ duzdyl_y = A15 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dyl_y(i,j,k,ispec_CPML,2)
+
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydzl_z = A15 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dzl_z(i,j,k,ispec_CPML,2)
+ duydyl_z = A15 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A17 and A18 --------------------------
+ A17 = 1.d0
+ A18 = 0.d0
+
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_x = A17 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_x(i,j,k,ispec_CPML,2)
+ duzdxl_x = A17 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdzl_z = A17 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dzl_z(i,j,k,ispec_CPML,2)
+ duxdxl_z = A17 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A19 and A20 --------------------------
+ A19 = k_store_z(i,j,k,ispec_CPML)
+ A20 = d_store_z(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydyl_x = A19 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_x(i,j,k,ispec_CPML,2)
+ duydxl_x = A19 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdyl_y = A19 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dyl_y(i,j,k,ispec_CPML,2)
+ duxdxl_y = A19 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_y(i,j,k,ispec_CPML,2)
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 4 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- XY-edge C-PML -----------------------------------
+ !------------------------------------------------------------------------------
+
+ !---------------------- A6, A7 and A8 --------------------------
+ A6 = k_store_y(i,j,k,ispec_CPML) / k_store_x(i,j,k,ispec_CPML)
+ A7 = 0.d0
+ A8 = ( d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) - &
+ d_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) ) / k_store_x(i,j,k,ispec_CPML)**2
+
+ bb = d_store_x(i,j,k,ispec_CPML) / k_store_x(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) / bb
+ coef2_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ duxdxl_x = A6 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) + A8 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2)
+ duydxl_y = A6 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) + A8 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2)
+ duzdxl_z = A6 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) + A8 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ dpotentialdxl = A6 * PML_dpotential_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) + A8 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A9, A10 and A11 --------------------------
+ A9 = k_store_x(i,j,k,ispec_CPML) / k_store_y(i,j,k,ispec_CPML)
+ A10 = 0.d0
+ A11 = ( d_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) - &
+ d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) ) / k_store_y(i,j,k,ispec_CPML)**2
+
+ bb = d_store_y(i,j,k,ispec_CPML) / k_store_y(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) / bb
+ coef2_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ duxdyl_x = A9 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) + A11 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2)
+ duydyl_y = A9 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) + A11 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2)
+ duzdyl_z = A9 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) + A11 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ dpotentialdyl = A9 * PML_dpotential_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) + A11 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A12, A13 and A14 --------------------------
+ A12 = k_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML)
+ if( ispec_is_elastic(ispec) ) then
+ A13 = d_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) &
+ + d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) &
+ + (it+0.0) * deltat * d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML)
+ elseif( ispec_is_acoustic(ispec) ) then
+ A13 = d_store_x(i,j,k,ispec_CPML)*k_store_y(i,j,k,ispec_CPML) &
+ + d_store_y(i,j,k,ispec_CPML)*k_store_x(i,j,k,ispec_CPML) &
+ + (it+0.5)*deltat*d_store_x(i,j,k,ispec_CPML)*d_store_y(i,j,k,ispec_CPML)
+ endif
+ A14 = - d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ coef0_2 = coef0_1
+ coef1_2 = coef1_1
+ coef2_2 = coef2_1
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_dux_dzl(i,j,k,ispec_CPML) * (it-0.0) * deltat * coef2_2
+
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duy_dzl(i,j,k,ispec_CPML) * (it-0.0) * deltat * coef2_2
+
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duz_dzl(i,j,k,ispec_CPML) * (it-0.0) * deltat * coef2_2
+
+ duxdzl_x = A12 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) + A14 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2)
+ duydzl_y = A12 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) + A14 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2)
+ duzdzl_z = A12 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) + A14 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dzl_new(i,j,k,ispec_CPML) *(it+0.5)*deltat * coef1_2 &
+ + PML_dpotential_dzl(i,j,k,ispec_CPML) *(it-0.5)*deltat * coef2_2
+
+ dpotentialdzl = A12 * PML_dpotential_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) + A14 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2)
+ endif
+
+ if( ispec_is_elastic(ispec) ) then
+ !---------------------- A15 and A16 --------------------------
+ A15 = k_store_x(i,j,k,ispec_CPML)
+ A16 = d_store_x(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_y = A15 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_y(i,j,k,ispec_CPML,2)
+ duzdyl_y = A15 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dyl_y(i,j,k,ispec_CPML,2)
+
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydzl_z = A15 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dzl_z(i,j,k,ispec_CPML,2)
+ duydyl_z = A15 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A17 and A18 --------------------------
+ A17 = k_store_y(i,j,k,ispec_CPML)
+ A18 = d_store_y(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_x = A17 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_x(i,j,k,ispec_CPML,2)
+ duzdxl_x = A17 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdzl_z = A17 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dzl_z(i,j,k,ispec_CPML,2)
+ duxdxl_z = A17 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A19 and A20--------------------------
+ A19 = 1.d0
+ A20 = 0.0
+
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydyl_x = A19 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_x(i,j,k,ispec_CPML,2)
+ duydxl_x = A19 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdyl_y = A19 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dyl_y(i,j,k,ispec_CPML,2)
+ duxdxl_y = A19 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_y(i,j,k,ispec_CPML,2)
+ endif
+
+ elseif(CPML_regions(ispec_CPML)==5) then
+ !------------------------------------------------------------------------------
+ !---------------------------- XZ-edge C-PML -----------------------------------
+ !------------------------------------------------------------------------------
+
+ !---------------------- A6, A7 and A8 --------------------------
+ A6 = k_store_z(i,j,k,ispec_CPML) / k_store_x(i,j,k,ispec_CPML)
+ A7 = 0.d0
+ A8 = ( d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) - &
+ d_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) ) / k_store_x(i,j,k,ispec_CPML)**2
+
+ bb = d_store_x(i,j,k,ispec_CPML) / k_store_x(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) / bb
+ coef2_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ duxdxl_x = A6 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) + A8 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2)
+ duydxl_y = A6 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) + A8 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2)
+ duzdxl_z = A6 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) + A8 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dxl(i,j,k,ispec_CPML) * coef2_2
+
+ dpotentialdxl = A6 * PML_dpotential_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) + A8 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A9, A10 and A11 --------------------------
+ A9 = k_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML)
+ if( ispec_is_elastic(ispec) ) then
+ A10 = d_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) &
+ + d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) &
+ + (it+0.0) * deltat * d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+ elseif( ispec_is_acoustic(ispec) ) then
+ A10 = d_store_x(i,j,k,ispec_CPML)*k_store_z(i,j,k,ispec_CPML) &
+ + d_store_z(i,j,k,ispec_CPML)*k_store_x(i,j,k,ispec_CPML) &
+ + (it+0.5)*deltat*d_store_x(i,j,k,ispec_CPML)*d_store_z(i,j,k,ispec_CPML)
+ endif
+ A11 = - d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ coef0_2 = coef0_1
+ coef1_2 = coef1_1
+ coef2_2 = coef2_1
+
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_dux_dyl(i,j,k,ispec_CPML) * (it-0.0) * deltat * coef2_2
+
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duy_dyl(i,j,k,ispec_CPML) * (it-0.0)*deltat * coef2_2
+
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duz_dyl(i,j,k,ispec_CPML) * (it-0.0) * deltat * coef2_2
+
+ duxdyl_x = A9 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) + A11 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2)
+ duydyl_y = A9 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) + A11 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2)
+ duzdyl_z = A9 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) + A11 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dyl_new(i,j,k,ispec_CPML) *(it+0.5)*deltat* coef1_2 &
+ + PML_dpotential_dyl(i,j,k,ispec_CPML) *(it-0.5)*deltat* coef2_2
+
+ dpotentialdyl = A9 * PML_dpotential_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) + A11 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A12, A13 and A14 --------------------------
+ A12 = k_store_x(i,j,k,ispec_CPML) / k_store_z(i,j,k,ispec_CPML)
+ A13 = 0.d0
+ A14 = ( d_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) &
+ - d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) ) / k_store_z(i,j,k,ispec_CPML)**2
+
+ bb = d_store_z(i,j,k,ispec_CPML) / k_store_z(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) / bb
+ coef2_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ duxdzl_x = A12 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) + A14 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2)
+ duydzl_y = A12 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) + A14 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2)
+ duzdzl_z = A12 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) + A14 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ dpotentialdzl = A12 * PML_dpotential_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) + A14 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2)
+ endif
+
+ if( ispec_is_elastic(ispec) ) then
+ !---------------------- A15 and A16 --------------------------
+ A15 = k_store_x(i,j,k,ispec_CPML)
+ A16 = d_store_x(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_y = A15 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_y(i,j,k,ispec_CPML,2)
+ duzdyl_y = A15 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dyl_y(i,j,k,ispec_CPML,2)
+
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydzl_z = A15 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dzl_z(i,j,k,ispec_CPML,2)
+ duydyl_z = A15 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A17 and A18 --------------------------
+ A17 = 1.0d0
+ A18 = 0.d0
+
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_x = A17 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_x(i,j,k,ispec_CPML,2)
+ duzdxl_x = A17 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdzl_z = A17 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dzl_z(i,j,k,ispec_CPML,2)
+ duxdxl_z = A17 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A19 and A20 --------------------------
+ A19 = k_store_z(i,j,k,ispec_CPML)
+ A20 = d_store_z(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydyl_x = A19 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_x(i,j,k,ispec_CPML,2)
+ duydxl_x = A19 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdyl_y = A19 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dyl_y(i,j,k,ispec_CPML,2)
+ duxdxl_y = A19 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_y(i,j,k,ispec_CPML,2)
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 6 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- YZ-edge C-PML -----------------------------------
+ !------------------------------------------------------------------------------
+
+ !---------------------- A6, A7 and A8 --------------------------
+ A6 = k_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML)
+ if( ispec_is_elastic(ispec) ) then
+ A7 = d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) &
+ + d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) &
+ + (it+0.0) * deltat * d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+ elseif( ispec_is_acoustic(ispec) ) then
+ A7 = d_store_y(i,j,k,ispec_CPML)*k_store_z(i,j,k,ispec_CPML) &
+ + d_store_z(i,j,k,ispec_CPML)*k_store_y(i,j,k,ispec_CPML) &
+ + (it+0.5)*deltat*d_store_y(i,j,k,ispec_CPML)*d_store_z(i,j,k,ispec_CPML)
+ endif
+ A8 = - d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ coef0_2 = coef0_1
+ coef1_2 = coef1_1
+ coef2_2 = coef2_1
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_dux_dxl(i,j,k,ispec_CPML) * (it-0.0) * deltat * coef2_2
+
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duy_dxl(i,j,k,ispec_CPML) * (it-0.0) * deltat * coef2_2
+
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duz_dxl(i,j,k,ispec_CPML) * (it-0.0) * deltat * coef2_2
+
+ duxdxl_x = A6 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) + A8 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2)
+ duydxl_y = A6 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) + A8 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2)
+ duzdxl_z = A6 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) + A8 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dxl_new(i,j,k,ispec_CPML) * (it+0.5)*deltat* coef1_2 &
+ + PML_dpotential_dxl(i,j,k,ispec_CPML) *(it-0.5)*deltat* coef2_2
+
+ dpotentialdxl = A6 * PML_dpotential_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) + A8 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A9, A10 and A11 --------------------------
+ A9 = k_store_z(i,j,k,ispec_CPML) / k_store_y(i,j,k,ispec_CPML)
+ A10 = 0.d0
+ A11 = ( d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) -&
+ d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) ) / k_store_y(i,j,k,ispec_CPML)**2
+
+ bb = d_store_y(i,j,k,ispec_CPML) / k_store_y(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) / bb
+ coef2_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ duxdyl_x = A9 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) + A11 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2)
+ duydyl_y = A9 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) + A11 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2)
+ duzdyl_z = A9 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) + A11 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dyl(i,j,k,ispec_CPML) * coef2_2
+
+ dpotentialdyl = A9 * PML_dpotential_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) + A11 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A12, A13 and A14 --------------------------
+ A12 = k_store_y(i,j,k,ispec_CPML) / k_store_z(i,j,k,ispec_CPML)
+ A13 = 0.d0
+ A14 = ( d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) -&
+ d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) ) / k_store_z(i,j,k,ispec_CPML)**2
+
+ bb = d_store_z(i,j,k,ispec_CPML) / k_store_z(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) / bb
+ coef2_2 = ( 1.d0 - exp(-bb * deltat/2.d0) ) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ duxdzl_x = A12 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) + A14 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2)
+ duydzl_y = A12 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) + A14 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2)
+ duzdzl_z = A12 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) + A14 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dzl(i,j,k,ispec_CPML) * coef2_2
+
+ dpotentialdzl = A12 * PML_dpotential_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) + A14 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2)
+ endif
+
+ if( ispec_is_elastic(ispec) ) then
+ !---------------------- A15 and A16 --------------------------
+ A15 = 1.0d0
+ A16 = 0.0d0
+
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_y = A15 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_y(i,j,k,ispec_CPML,2)
+ duzdyl_y = A15 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dyl_y(i,j,k,ispec_CPML,2)
+
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) = 0.d0
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydzl_z = A15 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dzl_z(i,j,k,ispec_CPML,2)
+ duydyl_z = A15 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A17 and A18 --------------------------
+ A17 = k_store_y(i,j,k,ispec_CPML)
+ A18 = d_store_y(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,2) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_x = A17 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_x(i,j,k,ispec_CPML,2)
+ duzdxl_x = A17 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdzl_z = A17 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dzl_z(i,j,k,ispec_CPML,2)
+ duxdxl_z = A17 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A19 and A20--------------------------
+ A19 = k_store_z(i,j,k,ispec_CPML)
+ A20 = d_store_z(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydyl_x = A19 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_x(i,j,k,ispec_CPML,2)
+ duydxl_x = A19 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdyl_y = A19 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dyl_y(i,j,k,ispec_CPML,2)
+ duxdxl_y = A19 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_y(i,j,k,ispec_CPML,2)
+ endif
+
+ elseif( CPML_regions(ispec_CPML) == 7 ) then
+ !------------------------------------------------------------------------------
+ !---------------------------- XYZ-corner C-PML --------------------------------
+ !------------------------------------------------------------------------------
+
+ !---------------------- A6, A7 and A8 --------------------------
+ A6 = k_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) / k_store_x(i,j,k,ispec_CPML)
+ if( abs(d_store_x(i,j,k,ispec_CPML)) .gt. 1.d-5 ) then
+ A7 = d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)/d_store_x(i,j,k,ispec_CPML)
+ A8 = ( d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) - &
+ d_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) ) * &
+ ( d_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) - &
+ d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) ) / &
+ ( d_store_x(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML)**2)
+ else
+ if( ispec_is_elastic(ispec) ) then
+ A7 = ( d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) + &
+ d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) ) / &
+ k_store_x(i,j,k,ispec_CPML) + &
+ (it+0.0)*deltat*d_store_y(i,j,k,ispec_CPML)*d_store_z(i,j,k,ispec_CPML)/k_store_x(i,j,k,ispec_CPML)
+ elseif( ispec_is_acoustic(ispec) ) then
+ A7 = (d_store_z(i,j,k,ispec_CPML)*k_store_y(i,j,k,ispec_CPML)+ &
+ d_store_y(i,j,k,ispec_CPML)*k_store_z(i,j,k,ispec_CPML)) / &
+ k_store_x(i,j,k,ispec_CPML) + &
+ (it+0.5)*deltat*d_store_y(i,j,k,ispec_CPML)*d_store_z(i,j,k,ispec_CPML)/k_store_x(i,j,k,ispec_CPML)
+ endif
+ A8 = - d_store_y(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) / k_store_x(i,j,k,ispec_CPML)
+ endif
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ bb = d_store_x(i,j,k,ispec_CPML) / k_store_x(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_2 = (1.d0 - exp(-bb* deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_1
+
+ if( abs(d_store_x(i,j,k,ispec_CPML)) .gt. 1.d-5 ) then
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_2
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_2
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_2
+ else
+ rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_dux_dxl(i,j,k,ispec_CPML) * (it-0.0)*deltat * coef2_2
+ rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duy_dxl(i,j,k,ispec_CPML) * (it-0.0)*deltat * coef2_2
+ rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duz_dxl(i,j,k,ispec_CPML) * (it-0.0)*deltat * coef2_2
+ endif
+
+ duxdxl_x = A6 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,1) + A8 * rmemory_dux_dxl_x(i,j,k,ispec_CPML,2)
+ duydxl_y = A6 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,1) + A8 * rmemory_duy_dxl_y(i,j,k,ispec_CPML,2)
+ duzdxl_z = A6 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,1) + A8 * rmemory_duz_dxl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dxl(i,j,k,ispec_CPML) * coef2_1
+
+ if(abs(d_store_x(i,j,k,ispec_CPML)).gt. 1.d-5)then
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dxl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dxl(i,j,k,ispec_CPML) * coef2_2
+ else
+ rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dxl_new(i,j,k,ispec_CPML) * (it+0.5)*deltat* coef1_2 &
+ + PML_dpotential_dxl(i,j,k,ispec_CPML) * (it-0.5)*deltat* coef2_2
+ endif
+
+ dpotentialdxl = A6 * PML_dpotential_dxl(i,j,k,ispec_CPML) &
+ + A7 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,1) + A8 * rmemory_dpotential_dxl(i,j,k,ispec_CPML,2)
+ endif
+
+
+ !---------------------- A9, A10 and A11 --------------------------
+ A9 = k_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) / k_store_y(i,j,k,ispec_CPML)
+ if( abs(d_store_y(i,j,k,ispec_CPML)) .gt. 1.d-5 ) then
+ A10 = d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML)/d_store_y(i,j,k,ispec_CPML)
+ A11 = ( d_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) &
+ - d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) ) * &
+ ( d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) &
+ - d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) ) / &
+ ( d_store_y(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML)**2)
+ else
+ if( ispec_is_elastic(ispec) ) then
+ A10 = ( d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) &
+ + d_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) ) / &
+ k_store_y(i,j,k,ispec_CPML) + &
+ (it+0.0)*deltat*d_store_x(i,j,k,ispec_CPML)*d_store_z(i,j,k,ispec_CPML)/k_store_y(i,j,k,ispec_CPML)
+ elseif( ispec_is_acoustic(ispec) ) then
+ A10 = (d_store_z(i,j,k,ispec_CPML)*k_store_x(i,j,k,ispec_CPML) &
+ +d_store_x(i,j,k,ispec_CPML)*k_store_z(i,j,k,ispec_CPML)) / &
+ k_store_y(i,j,k,ispec_CPML) + &
+ (it+0.5)*deltat*d_store_x(i,j,k,ispec_CPML)*d_store_z(i,j,k,ispec_CPML)/k_store_y(i,j,k,ispec_CPML)
+ endif
+ A11 = - d_store_x(i,j,k,ispec_CPML) * d_store_z(i,j,k,ispec_CPML) / k_store_y(i,j,k,ispec_CPML)
+ endif
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ bb = d_store_y(i,j,k,ispec_CPML) / k_store_y(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_2 = (1.d0 - exp(-bb* deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_1
+
+ if( abs(d_store_y(i,j,k,ispec_CPML)) .gt. 1.d-5 ) then
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_2
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_2
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_2
+ else
+ rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_dux_dyl(i,j,k,ispec_CPML) * (it-0.0)*deltat * coef2_2
+ rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duy_dyl(i,j,k,ispec_CPML) * (it-0.0)*deltat * coef2_2
+ rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duz_dyl(i,j,k,ispec_CPML) * (it-0.0)*deltat * coef2_2
+ endif
+
+ duxdyl_x = A9 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,1) + A11 * rmemory_dux_dyl_x(i,j,k,ispec_CPML,2)
+ duydyl_y = A9 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,1) + A11 * rmemory_duy_dyl_y(i,j,k,ispec_CPML,2)
+ duzdyl_z = A9 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,1) + A11 * rmemory_duz_dyl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dyl(i,j,k,ispec_CPML) * coef2_1
+
+ if(abs(d_store_y(i,j,k,ispec_CPML)).gt. 1.d-5)then
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dyl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dyl(i,j,k,ispec_CPML) * coef2_2
+ else
+ rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dyl_new(i,j,k,ispec_CPML) * (it+0.5)*deltat* coef1_2 &
+ + PML_dpotential_dyl(i,j,k,ispec_CPML) * (it-0.5)*deltat* coef2_2
+ endif
+
+ dpotentialdyl = A9 * PML_dpotential_dyl(i,j,k,ispec_CPML) &
+ + A10 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,1) + A11 * rmemory_dpotential_dyl(i,j,k,ispec_CPML,2)
+ endif
+
+ !---------------------- A12, A13 and A14 --------------------------
+ A12 = k_store_x(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) / k_store_z(i,j,k,ispec_CPML)
+ if( abs(d_store_z(i,j,k,ispec_CPML)) .gt. 1.d-5 ) then
+ A13 = d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML)/d_store_z(i,j,k,ispec_CPML)
+ A14 = ( d_store_x(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) &
+ - d_store_z(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) ) * &
+ ( d_store_z(i,j,k,ispec_CPML) * k_store_y(i,j,k,ispec_CPML) &
+ - d_store_y(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML) ) / &
+ ( d_store_z(i,j,k,ispec_CPML) * k_store_z(i,j,k,ispec_CPML)**2)
+ else
+ if( ispec_is_elastic(ispec) ) then
+ A13 = ( d_store_y(i,j,k,ispec_CPML) * k_store_x(i,j,k,ispec_CPML) &
+ + d_store_x(i,j,k,ispec_CPML)*k_store_y(i,j,k,ispec_CPML) ) / &
+ k_store_z(i,j,k,ispec_CPML) + &
+ (it+0.0)*deltat*d_store_x(i,j,k,ispec_CPML)*d_store_y(i,j,k,ispec_CPML)/k_store_z(i,j,k,ispec_CPML)
+ elseif( ispec_is_acoustic(ispec) ) then
+ A13 = (d_store_y(i,j,k,ispec_CPML)*k_store_x(i,j,k,ispec_CPML)&
+ +d_store_x(i,j,k,ispec_CPML)*k_store_y(i,j,k,ispec_CPML)) / &
+ k_store_z(i,j,k,ispec_CPML) + &
+ (it+0.5)*deltat*d_store_x(i,j,k,ispec_CPML)*d_store_y(i,j,k,ispec_CPML)/k_store_z(i,j,k,ispec_CPML)
+ endif
+ A14 = - d_store_x(i,j,k,ispec_CPML) * d_store_y(i,j,k,ispec_CPML) / k_store_z(i,j,k,ispec_CPML)
+ endif
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ bb = d_store_z(i,j,k,ispec_CPML) / k_store_z(i,j,k,ispec_CPML) + alpha_store(i,j,k,ispec_CPML)
+
+ coef0_2 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_2 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_2 = (1.d0 - exp(-bb* deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_2 = deltat/2.0d0
+ coef2_2 = deltat/2.0d0
+ end if
+
+ if( ispec_is_elastic(ispec) ) then
+
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+
+ if( abs(d_store_z(i,j,k,ispec_CPML)) .gt. 1.d-5 ) then
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_2
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_2
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_2
+ else
+ rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_dux_dzl(i,j,k,ispec_CPML) * (it-0.0)*deltat * coef2_2
+ rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duy_dzl(i,j,k,ispec_CPML) * (it-0.0)*deltat * coef2_2
+ rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * (it+0.0) * deltat * coef1_2 &
+ + PML_duz_dzl(i,j,k,ispec_CPML) * (it-0.0)*deltat * coef2_2
+ endif
+
+ duxdzl_x = A12 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,1) + A14 * rmemory_dux_dzl_x(i,j,k,ispec_CPML,2)
+ duydzl_y = A12 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,1) + A14 * rmemory_duy_dzl_y(i,j,k,ispec_CPML,2)
+ duzdzl_z = A12 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,1) + A14 * rmemory_duz_dzl_z(i,j,k,ispec_CPML,2)
+
+ elseif( ispec_is_acoustic(ispec) ) then
+
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) &
+ + PML_dpotential_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dpotential_dzl(i,j,k,ispec_CPML) * coef2_1
+
+ if(abs(d_store_z(i,j,k,ispec_CPML)).gt. 1.d-5)then
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dzl_new(i,j,k,ispec_CPML) * coef1_2 + PML_dpotential_dzl(i,j,k,ispec_CPML) * coef2_2
+ else
+ rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) = coef0_2 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2) &
+ + PML_dpotential_dzl_new(i,j,k,ispec_CPML) * (it+0.5)*deltat* coef1_2 &
+ + PML_dpotential_dzl(i,j,k,ispec_CPML) * (it-0.5)*deltat* coef2_2
+ endif
+
+ dpotentialdzl = A12 * PML_dpotential_dzl(i,j,k,ispec_CPML) &
+ + A13 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,1) + A14 * rmemory_dpotential_dzl(i,j,k,ispec_CPML,2)
+ endif
+
+ if( ispec_is_elastic(ispec) ) then
+ !---------------------- A15 and A16 --------------------------
+ A15 = k_store_x(i,j,k,ispec_CPML)
+ A16 = d_store_x(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_duz_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_y = A15 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dzl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_y(i,j,k,ispec_CPML,2)
+ duzdyl_y = A15 * PML_duz_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duz_dyl_y(i,j,k,ispec_CPML,1) + rmemory_duz_dyl_y(i,j,k,ispec_CPML,2)
+
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_duy_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydzl_z = A15 * PML_duy_dzl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dzl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dzl_z(i,j,k,ispec_CPML,2)
+ duydyl_z = A15 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A16 * rmemory_duy_dyl_z(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A17 and A18 --------------------------
+ A17 = k_store_y(i,j,k,ispec_CPML)
+ A18 = d_store_y(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0)) / bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) &
+ + PML_duz_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dzl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_duz_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duz_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duz_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duzdzl_x = A17 * PML_duz_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dzl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dzl_x(i,j,k,ispec_CPML,2)
+ duzdxl_x = A17 * PML_duz_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_duz_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duz_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) &
+ + PML_dux_dzl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dzl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dzl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_z(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdzl_z = A17 * PML_dux_dzl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dzl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dzl_z(i,j,k,ispec_CPML,2)
+ duxdxl_z = A17 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A18 * rmemory_dux_dxl_z(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_z(i,j,k,ispec_CPML,2)
+
+ !---------------------- A19 and A20 --------------------------
+ A19 = k_store_z(i,j,k,ispec_CPML)
+ A20 = d_store_z(i,j,k,ispec_CPML)
+
+ bb = alpha_store(i,j,k,ispec_CPML)
+
+ coef0_1 = exp(-bb * deltat)
+
+ if( abs(bb) > 1.d-5 ) then
+ coef1_1 = (1.d0 - exp(-bb * deltat/2.d0))/ bb
+ coef2_1 = (1.d0 - exp(-bb * deltat/2.d0)) * exp(-bb * deltat/2.d0) / bb
+ else
+ coef1_1 = deltat/2.0d0
+ coef2_1 = deltat/2.0d0
+ end if
+
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) &
+ + PML_duy_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dyl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) &
+ + PML_duy_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_duy_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_duy_dxl_x(i,j,k,ispec_CPML,2) = 0.d0
+
+ duydyl_x = A19 * PML_duy_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dyl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dyl_x(i,j,k,ispec_CPML,2)
+ duydxl_x = A19 * PML_duy_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_duy_dxl_x(i,j,k,ispec_CPML,1) + rmemory_duy_dxl_x(i,j,k,ispec_CPML,2)
+
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) &
+ + PML_dux_dyl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dyl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dyl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) = coef0_1 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) &
+ + PML_dux_dxl_new(i,j,k,ispec_CPML) * coef1_1 + PML_dux_dxl(i,j,k,ispec_CPML) * coef2_1
+ rmemory_dux_dxl_y(i,j,k,ispec_CPML,2) = 0.d0
+
+ duxdyl_y = A19 * PML_dux_dyl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dyl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dyl_y(i,j,k,ispec_CPML,2)
+ duxdxl_y = A19 * PML_dux_dxl(i,j,k,ispec_CPML) &
+ + A20 * rmemory_dux_dxl_y(i,j,k,ispec_CPML,1) + rmemory_dux_dxl_y(i,j,k,ispec_CPML,2)
+ endif
+
+ endif ! CPML_regions
+
+ if( ispec_is_elastic(ispec) ) then
+ ! compute stress sigma
+ sigma_xx = lambdalplus2mul*duxdxl_x + lambdal*duydyl_x + lambdal*duzdzl_x
+ sigma_yx = mul*duxdyl_x + mul*duydxl_x
+ sigma_zx = mul*duzdxl_x + mul*duxdzl_x
+
+ sigma_xy = mul*duxdyl_y + mul*duydxl_y
+ sigma_yy = lambdal*duxdxl_y + lambdalplus2mul*duydyl_y + lambdal*duzdzl_y
+ sigma_zy = mul*duzdyl_y + mul*duydzl_y
+
+ sigma_xz = mul*duzdxl_z + mul*duxdzl_z
+ sigma_yz = mul*duzdyl_z + mul*duydzl_z
+ sigma_zz = lambdal*duxdxl_z + lambdal*duydyl_z + lambdalplus2mul*duzdzl_z
+
+ ! form dot product with test vector, non-symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl) ! this goes to accel_x
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl) ! this goes to accel_y
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl) ! this goes to accel_z
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl) ! this goes to accel_x
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl) ! this goes to accel_y
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl) ! this goes to accel_z
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl) ! this goes to accel_x
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl) ! this goes to accel_y
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl) ! this goes to accel_z
+ endif
+
+ enddo
+ enddo
+ enddo
+
+end subroutine pml_set_memory_variables
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/prepare_timerun.F90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/prepare_timerun.F90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/prepare_timerun.F90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -35,7 +35,9 @@
use specfem_par_movie
use fault_solver_dynamic, only : BC_DYNFLT_init
use fault_solver_kinematic, only : BC_KINFLT_init
+
implicit none
+
! local parameters
double precision :: tCPU
@@ -65,14 +67,14 @@
! prepares gravity arrays
call prepare_timerun_gravity()
- ! initializes PML arrays
- if( ABSORBING_CONDITIONS ) then
- if (SIMULATION_TYPE /= 1 .and. ABSORB_USE_PML ) then
- write(IMAIN,*) 'NOTE: adjoint simulations and PML not supported yet...'
+ ! prepares C-PML arrays
+ if( PML_CONDITIONS ) then
+ if( SIMULATION_TYPE /= 1 ) then
+ stop 'error: C-PML for adjoint simulations not supported yet'
+ else if( GPU_MODE ) then
+ stop 'error: C-PML only supported in CPU mode'
else
- if( ABSORB_USE_PML ) then
- call PML_initialize()
- endif
+ call prepare_timerun_pml()
endif
endif
@@ -83,7 +85,7 @@
call prepare_timerun_noise()
! prepares GPU arrays
- if(GPU_MODE) call prepare_timerun_GPU()
+ if( GPU_MODE ) call prepare_timerun_GPU()
#ifdef OPENMP_MODE
! prepares arrays for OpenMP
@@ -135,6 +137,7 @@
use specfem_par_elastic
use specfem_par_poroelastic
use specfem_par_movie
+
implicit none
! flag for any movie simulation
@@ -224,6 +227,7 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
+
implicit none
! synchronize all the processes before assembling the mass matrix
@@ -232,7 +236,6 @@
! the mass matrix needs to be assembled with MPI here once and for all
if(ACOUSTIC_SIMULATION) then
-
! adds contributions
if( ABSORBING_CONDITIONS ) then
rmass_acoustic(:) = rmass_acoustic(:) + rmassz_acoustic(:)
@@ -248,11 +251,9 @@
! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
where(rmass_acoustic <= 0._CUSTOM_REAL) rmass_acoustic = 1._CUSTOM_REAL
rmass_acoustic(:) = 1._CUSTOM_REAL / rmass_acoustic(:)
-
endif
if(ELASTIC_SIMULATION) then
-
! switches to three-component mass matrix
if( ABSORBING_CONDITIONS ) then
! adds boundary contributions
@@ -298,7 +299,7 @@
where(rmass_ocean_load <= 0._CUSTOM_REAL) rmass_ocean_load = 1._CUSTOM_REAL
rmass_ocean_load(:) = 1._CUSTOM_REAL / rmass_ocean_load(:)
endif
- endif
+ endif
if(POROELASTIC_SIMULATION) then
call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass_solid_poroelastic, &
@@ -333,6 +334,7 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
+
implicit none
! initialize acoustic arrays to zero
@@ -378,7 +380,9 @@
! precomputes constants for time integration
use specfem_par
+
implicit none
+
! local parameters
character(len=256) :: plot_file
integer :: ier
@@ -449,6 +453,7 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
+
implicit none
! local parameters
@@ -576,6 +581,7 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
+
implicit none
! local parameters
@@ -658,7 +664,98 @@
end subroutine prepare_timerun_gravity
+!
+!-------------------------------------------------------------------------------------------------
+!
+ subroutine prepare_timerun_pml()
+
+ use pml_par
+ use specfem_par, only: NSPEC_AB,NGNOD,ibool,myrank
+ use constants, only: IMAIN,NGNOD_EIGHT_CORNERS
+
+ implicit none
+
+ ! local parameters
+ integer :: ispec,ispec_CPML,NSPEC_CPML_GLOBAL
+
+ ! sets thickness of C-PML layers
+ CPML_width_x = CPML_width
+ CPML_width_y = CPML_width
+ CPML_width_z = CPML_width
+
+ call sum_all_i(NSPEC_CPML,NSPEC_CPML_GLOBAL)
+
+ ! user output
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'incorporating C-PML '
+ write(IMAIN,*)
+ write(IMAIN,*) 'number of C-PML spectral elements in the global mesh: ', NSPEC_CPML_GLOBAL
+ write(IMAIN,*)
+ write(IMAIN,*) 'thickness of C-PML layer in X direction: ', CPML_width_x
+ write(IMAIN,*) 'thickness of C-PML layer in Y direction: ', CPML_width_y
+ write(IMAIN,*) 'thickness of C-PML layer in Z direction: ', CPML_width_z
+ write(IMAIN,*)
+ endif
+ call sync_all()
+
+ ! checks that 8-node mesh elements are used (27-node elements are not supported)
+ if( NGNOD /= NGNOD_EIGHT_CORNERS) &
+ stop 'error: the C-PML code works for 8-node bricks only; should be made more general'
+
+ ! allocates and initializes C-PML arrays
+ if( NSPEC_CPML > 0 ) then
+ call pml_allocate_arrays()
+ else
+ stop 'error: the number of C-PML elements in partition is invalid'
+ endif
+
+ ! defines C-PML spectral elements local indexing
+ ispec_CPML = 0
+ do ispec=1,NSPEC_AB
+ if( CPML_mask_ibool(ispec) ) then
+ ispec_CPML = ispec_CPML + 1
+ spec_to_CPML(ispec) = ispec_CPML
+ endif
+ enddo
+
+ ! defines C-PML element type array: 1 = face, 2 = edge, 3 = corner
+ do ispec_CPML=1,NSPEC_CPML
+
+ ! X_surface C-PML
+ if( CPML_regions(ispec_CPML) == 1 ) then
+ CPML_type(ispec_CPML) = 1
+
+ ! Y_surface C-PML
+ elseif( CPML_regions(ispec_CPML) == 2 ) then
+ CPML_type(ispec_CPML) = 1
+
+ ! Z_surface C-PML
+ elseif( CPML_regions(ispec_CPML) == 3 ) then
+ CPML_type(ispec_CPML) = 1
+
+ ! XY_edge C-PML
+ elseif( CPML_regions(ispec_CPML) == 4 ) then
+ CPML_type(ispec_CPML) = 2
+
+ ! XZ_edge C-PML
+ elseif( CPML_regions(ispec_CPML) == 5 ) then
+ CPML_type(ispec_CPML) = 2
+
+ ! YZ_edge C-PML
+ elseif( CPML_regions(ispec_CPML) == 6 ) then
+ CPML_type(ispec_CPML) = 2
+
+ ! XYZ_corner C-PML
+ elseif( CPML_regions(ispec_CPML) == 7 ) then
+ CPML_type(ispec_CPML) = 3
+ endif
+
+ enddo
+
+ end subroutine prepare_timerun_pml
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -671,7 +768,9 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
+
implicit none
+
! local parameters
integer :: ier
integer(kind=8) :: filesize
@@ -699,10 +798,8 @@
! attenuation backward memories
if( ATTENUATION .and. SIMULATION_TYPE == 3 ) then
-
! precompute Runge-Kutta coefficients if attenuation
call get_attenuation_memory_values(tau_sigma,b_deltat,b_alphaval,b_betaval,b_gammaval)
-
endif
! initializes adjoint kernels and reconstructed/backward wavefields
@@ -1017,7 +1114,9 @@
use specfem_par_elastic
use specfem_par_poroelastic
use specfem_par_movie
+
implicit none
+
! local parameters
integer :: ier
@@ -1085,6 +1184,8 @@
use specfem_par_movie
implicit none
+
+ ! local parameters
real :: free_mb,used_mb,total_mb
! GPU_MODE now defined in Par_file
@@ -1094,6 +1195,7 @@
endif
! prepares general fields on GPU
+ !§!§ JC JC here we will need to add GPU support for the new C-PML routines
call prepare_constants_device(Mesh_pointer, &
NGLLX, NSPEC_AB, NGLOB_AB, &
xix, xiy, xiz, etax,etay,etaz, gammax, gammay, gammaz, &
@@ -1143,6 +1245,7 @@
endif
! prepares fields on GPU for elastic simulations
+ !§!§ JC JC here we will need to add GPU support for the new C-PML routines
if( ELASTIC_SIMULATION ) then
call prepare_fields_elastic_device(Mesh_pointer, NDIM*NGLOB_AB, &
rmassx,rmassy,rmassz, &
@@ -1265,6 +1368,7 @@
use specfem_par
use specfem_par_elastic
+
implicit none
! local parameters
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/read_mesh_databases.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/read_mesh_databases.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -28,15 +28,19 @@
subroutine read_mesh_databases()
+ use pml_par
+
use specfem_par
use specfem_par_elastic
use specfem_par_acoustic
use specfem_par_poroelastic
+
implicit none
+
real(kind=CUSTOM_REAL):: minl,maxl,min_all,max_all
integer :: ier,inum
-! start reading the databasesa
+! start reading the databases
! info about external mesh simulation
call create_name_database(prname,myrank,LOCAL_PATH)
@@ -318,6 +322,43 @@
call exit_mpi(myrank,'error no simulation type defined')
endif
+ ! C-PML absorbing boundary conditions
+ read(27) NSPEC_CPML
+ read(27) CPML_width
+ if( PML_CONDITIONS .and. NSPEC_CPML > 0 ) then
+ allocate(CPML_regions(NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating array CPML_regions'
+ allocate(CPML_to_spec(NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating array CPML_to_spec'
+ allocate(CPML_mask_ibool(NSPEC_AB),stat=ier)
+ if(ier /= 0) stop 'error allocating array CPML_mask_ibool'
+ allocate(d_store_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating array d_store_x'
+ allocate(d_store_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating array d_store_y'
+ allocate(d_store_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating array d_store_z'
+ allocate(K_store_x(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating array K_store_x'
+ allocate(K_store_y(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating array K_store_y'
+ allocate(K_store_z(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating array K_store_z'
+ allocate(alpha_store(NGLLX,NGLLY,NGLLZ,NSPEC_CPML),stat=ier)
+ if(ier /= 0) stop 'error allocating array alpha_store'
+
+ read(27) CPML_regions
+ read(27) CPML_to_spec
+ read(27) CPML_mask_ibool
+ read(27) d_store_x
+ read(27) d_store_y
+ read(27) d_store_z
+ read(27) k_store_x
+ read(27) k_store_y
+ read(27) k_store_z
+ read(27) alpha_store
+ endif
+
! absorbing boundary surface
read(27) num_abs_boundary_faces
allocate(abs_boundary_ispec(num_abs_boundary_faces), &
@@ -341,13 +382,30 @@
endif
endif
+ read(27) nspec2D_xmin
+ read(27) nspec2D_xmax
+ read(27) nspec2D_ymin
+ read(27) nspec2D_ymax
+ read(27) NSPEC2D_BOTTOM
+ read(27) NSPEC2D_TOP
+ allocate(ibelm_xmin(nspec2D_xmin),ibelm_xmax(nspec2D_xmax), &
+ ibelm_ymin(nspec2D_ymin),ibelm_ymax(nspec2D_ymax), &
+ ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP),stat=ier)
+ if(ier /= 0) stop 'error allocating arrays ibelm_xmin,ibelm_xmax etc.'
+ read(27) ibelm_xmin
+ read(27) ibelm_xmax
+ read(27) ibelm_ymin
+ read(27) ibelm_ymax
+ read(27) ibelm_bottom
+ read(27) ibelm_top
+
! free surface
read(27) num_free_surface_faces
allocate(free_surface_ispec(num_free_surface_faces), &
free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces), &
free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces), &
free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces),stat=ier)
- if( ier /= 0 ) stop 'error allocating array free_surface_ispec etc.'
+ if(ier /= 0) stop 'error allocating arrays free_surface_ispec etc.'
if( num_free_surface_faces > 0 ) then
read(27) free_surface_ispec
read(27) free_surface_ijk
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/setup_sources_receivers.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/setup_sources_receivers.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -904,17 +904,9 @@
if( myrank == 0 ) then
! get the 3-D shape functions
- if( USE_FORCE_POINT_SOURCE ) then
- ! note: we switch xi,eta,gamma range to be [-1,1]
- ! uses initial guess in xi, eta and gamma
- xil = xigll(nint(xi_source(isource)))
- etal = yigll(nint(eta_source(isource)))
- gammal = zigll(nint(gamma_source(isource)))
- else
- xil = xi_source(isource)
- etal = eta_source(isource)
- gammal = gamma_source(isource)
- endif
+ xil = xi_source(isource)
+ etal = eta_source(isource)
+ gammal = gamma_source(isource)
call eval_shape3D_single(myrank,shape3D,xil,etal,gammal,NGNOD)
! interpolates source locations
Modified: seismo/3D/SPECFEM3D/trunk/src/specfem3D/specfem3D_par.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/src/specfem3D/specfem3D_par.f90 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/src/specfem3D/specfem3D_par.f90 2013-01-12 21:24:23 UTC (rev 21224)
@@ -73,6 +73,8 @@
integer, dimension(:,:,:), allocatable :: abs_boundary_ijk
integer, dimension(:), allocatable :: abs_boundary_ispec
integer :: num_abs_boundary_faces
+ integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP
+ integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top
! free surface arrays
real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: free_surface_normal
@@ -85,7 +87,6 @@
integer :: NSPEC_ATTENUATION_AB
character(len=256) prname_Q
-
! additional mass matrix for ocean load
real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
@@ -166,11 +167,14 @@
integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE
integer :: IMODEL,NGNOD,NGNOD2D
- double precision :: DT,OLSEN_ATTENUATION_RATIO
+ double precision :: DT,OLSEN_ATTENUATION_RATIO,f0_FOR_PML,PML_WIDTH_MIN,PML_WIDTH_MAX
logical :: ATTENUATION,USE_OLSEN_ATTENUATION, &
OCEANS,TOPOGRAPHY,ABSORBING_CONDITIONS,ANISOTROPY, &
ABSORB_INSTEAD_OF_FREE_SURFACE
+
+ logical :: PML_CONDITIONS,PML_INSTEAD_OF_FREE_SURFACE
+
logical :: GRAVITY
logical :: SAVE_FORWARD,SAVE_MESH_FILES
Modified: seismo/3D/SPECFEM3D/trunk/todo_list_please_dont_remove.txt
===================================================================
--- seismo/3D/SPECFEM3D/trunk/todo_list_please_dont_remove.txt 2013-01-11 07:32:10 UTC (rev 21223)
+++ seismo/3D/SPECFEM3D/trunk/todo_list_please_dont_remove.txt 2013-01-12 21:24:23 UTC (rev 21224)
@@ -62,7 +62,10 @@
See also if the current arrays called isPML() or PML() or something like that in SPECFEM3D need to be suppressed or on the contrary could
be reused. They seem to correspond to an earlier attempt a few years ago that was never finished.
-One thing that we will need to investigate in the specific case of GLOBE is how to make PML work for boundaries that are not aligned with x / y / z (i.e. for one chunk of SPECFEM3D_GLOBE). That should not be a problem but we will get more terms because of products with the three components of the normal vector. We already have the general (tensorial) formulation written in our PML paper of 2003, but I never implemented all the terms.
+One thing that we will need to investigate in the specific case of GLOBE is how to make PML work for boundaries that are not aligned
+with x / y / z (i.e. for one chunk of SPECFEM3D_GLOBE). That should not be a problem but we will get more terms because of products with
+the three components of the normal vector. We already have the general (tensorial) formulation written in our PML paper of 2003,
+but I never implemented all the terms.
The standard logical bit handling functions of Fortran are described for instance at http://www.ews.uiuc.edu/~mrgates2/docs/fortran.html
Thus here is the standard way of using a single array for all the logical flags for CPML in Fortran:
More information about the CIG-COMMITS
mailing list