[cig-commits] r15867 - in seismo/3D/SPECFEM3D_SESAME/trunk: . EXAMPLES/homogeneous_halfspace EXAMPLES/layered_halfspace decompose_mesh_SCOTCH
danielpeter at geodynamics.org
danielpeter at geodynamics.org
Thu Oct 22 14:01:49 PDT 2009
Author: danielpeter
Date: 2009-10-22 14:01:47 -0700 (Thu, 22 Oct 2009)
New Revision: 15867
Added:
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/Makefile
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/README
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/program_decompose_mesh_SCOTCH.f90
seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90
Modified:
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8-nodoubling.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/README
seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_scalar.f90
seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90
seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90
seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90
seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/compile_all.csh
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90
seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_attenuation_model.f90
seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90
seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90
seismo/3D/SPECFEM3D_SESAME/trunk/program_generate_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90
seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90
seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90
seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
Log:
putting back Olsen attenuation for both Deville/no-Deville routines; adding program_decompose_mesh_SCOTCH.f90 for new usage and compilation in directory decompose_mesh_SCOTCH/ (see also new README file in that directory); adding files detect_surface.f90 and compute_forces_elastic.f90; using new header file surface_from_mesher.h created by xgenerate_databases for create_movie_shakemap_AVS_DX_GMT executable to specify number of spectral elements at surface
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README 2009-10-22 21:01:47 UTC (rev 15867)
@@ -18,17 +18,14 @@
2. decompose mesh files:
- - copy to directory OUTPUT_FILES/ in decompose_mesh_SCOTCH directory
-
- - specify number of partitions (nparts, equals number of CPUs to run simulation with)
- in file "constants_decompose_mesh_SCOTCH.h"
-
- run decomposer in directory decompose_mesh_SCOTCH/:
- > ./compile_all.csh
- > ./a.out
+ (example assumes 4 partitions with mesh files in OUTPUT_FILES/)
+
+ > make
+ > ./xdecompose_mesh_SCOTCH 4 ../EXAMPLES/homogeneous_halfspace/MESH/ ../DATABASES_MPI/
- - copy mesh partitions "proc0000***_Database" to directory "LOCAL_PATH"
- specified in "Par_file"
+ which creates mesh partitions "proc0000***_Database" in directory "DATABASES_MPI".
+ you can then specify "DATABASES_MPI" in "Par_file" for your "LOCAL_PATH"
3. generate databases:
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8-nodoubling.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8-nodoubling.py 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8-nodoubling.py 2009-10-22 21:01:47 UTC (rev 15867)
@@ -78,21 +78,21 @@
cubit.cmd('block 1 attribute index 2 2800 ') # vp
cubit.cmd('block 1 attribute index 3 1500 ') # vs
cubit.cmd('block 1 attribute index 4 2300 ') # rho
-cubit.cmd('block 1 attribute index 5 1 ') # Q_flag
+cubit.cmd('block 1 attribute index 5 6 ') # Q_flag
cubit.cmd('block 2 attribute count 5')
cubit.cmd('block 2 attribute index 1 2 ') # volume 2
cubit.cmd('block 2 attribute index 2 7500 ')
cubit.cmd('block 2 attribute index 3 4300 ')
cubit.cmd('block 2 attribute index 4 3200 ')
-cubit.cmd('block 2 attribute index 5 1')
+cubit.cmd('block 2 attribute index 5 6')
cubit.cmd('block 3 attribute count 5')
cubit.cmd('block 3 attribute index 1 2 ') # same material properties as for volume 2
cubit.cmd('block 3 attribute index 2 7500 ')
cubit.cmd('block 3 attribute index 3 4300 ')
cubit.cmd('block 3 attribute index 4 3200 ')
-cubit.cmd('block 3 attribute index 5 1')
+cubit.cmd('block 3 attribute index 5 6')
cubit.cmd('export mesh "top.e" dimension 3 overwrite')
cubit.cmd('save as "meshing.cub" overwrite')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8.py 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8.py 2009-10-22 21:01:47 UTC (rev 15867)
@@ -75,21 +75,21 @@
cubit.cmd('block 1 attribute index 2 2800 ') # vp
cubit.cmd('block 1 attribute index 3 1500 ') # vs
cubit.cmd('block 1 attribute index 4 2300 ') # rho
-cubit.cmd('block 1 attribute index 5 1 ') # Q_flag
+cubit.cmd('block 1 attribute index 5 6 ') # Q_flag
cubit.cmd('block 2 attribute count 5')
cubit.cmd('block 2 attribute index 1 2 ') # volume 2
cubit.cmd('block 2 attribute index 2 7500 ')
cubit.cmd('block 2 attribute index 3 4300 ')
cubit.cmd('block 2 attribute index 4 3200 ')
-cubit.cmd('block 2 attribute index 5 1 ')
+cubit.cmd('block 2 attribute index 5 6 ')
cubit.cmd('block 3 attribute count 5')
cubit.cmd('block 3 attribute index 1 2 ') # same properties as for volume 2
cubit.cmd('block 3 attribute index 2 7500 ')
cubit.cmd('block 3 attribute index 3 4300 ')
cubit.cmd('block 3 attribute index 4 3200 ')
-cubit.cmd('block 3 attribute index 5 1 ')
+cubit.cmd('block 3 attribute index 5 6 ')
cubit.cmd('export mesh "top.e" dimension 3 overwrite')
cubit.cmd('save as "meshing.cub" overwrite')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/README
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/README 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/README 2009-10-22 21:01:47 UTC (rev 15867)
@@ -43,17 +43,14 @@
2. decompose mesh files:
- - copy to directory OUTPUT_FILES/ in decompose_mesh_SCOTCH directory
-
- - specify number of partitions (nparts, equals number of CPUs to run simulation with)
- in file "constants_decompose_mesh_SCOTCH.h"
-
- run decomposer in directory decompose_mesh_SCOTCH/:
- > ./compile_all.csh
- > ./a.out
+ (example assumes 4 partitions with mesh files in OUTPUT_FILES/)
+
+ > make
+ > ./xdecompose_mesh_SCOTCH 4 ../EXAMPLES/layered_halfspace/MESH/ ../DATABASES_MPI/
- - copy mesh partitions "proc0000***_Database" to directory "LOCAL_PATH"
- specified in "Par_file"
+ which creates mesh partitions "proc0000***_Database" in directory "DATABASES_MPI".
+ you can then specify "DATABASES_MPI" in "Par_file" for your "LOCAL_PATH"
3. generate databases:
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2009-10-22 21:01:47 UTC (rev 15867)
@@ -53,9 +53,11 @@
ARFLAGS = cru
RANLIB = ranlib
+
O = obj
libspecfem_a_OBJECTS = \
+ $O/assemble_MPI_scalar.o \
$O/calc_jacobian.o \
$O/check_mesh_resolution.o \
$O/comp_source_time_function.o \
@@ -66,6 +68,7 @@
$O/create_regions_mesh.o \
$O/create_serial_name_database.o \
$O/define_derivation_matrices.o \
+ $O/detect_surface.o \
$O/exit_mpi.o \
$O/get_MPI_cutplanes_eta.o \
$O/get_MPI_cutplanes_xi.o \
@@ -127,6 +130,7 @@
$O/specfem3D_par.o \
$O/compute_forces_no_Deville.o \
$O/compute_forces_with_Deville.o \
+ $O/compute_forces_elastic.o \
$O/initialize_simulation.o \
$O/read_mesh_databases.o \
$O/setup_GLL_points.o \
@@ -138,7 +142,6 @@
$O/iterate_time.o \
$O/finalize_simulation.o \
$O/specfem3D.o \
- $O/assemble_MPI_scalar.o \
$O/assemble_MPI_vector.o \
$(EMPTY_MACRO)
@@ -213,9 +216,15 @@
xcreate_header_file: $O/program_create_header_file.o $(LIBSPECFEM)
${FCCOMPILE_CHECK} -o xcreate_header_file $O/program_create_header_file.o $(LIBSPECFEM)
- at COND_PYRE_FALSE@xcreate_movie_shakemap_AVS_DX_GMT: $O/create_movie_shakemap_AVS_DX_GMT.o $(LIBSPECFEM)
- at COND_PYRE_FALSE@ ${FCCOMPILE_CHECK} -o xcreate_movie_shakemap_AVS_DX_GMT $O/create_movie_shakemap_AVS_DX_GMT.o $(LIBSPECFEM)
+#@COND_PYRE_FALSE at xcreate_movie_shakemap_AVS_DX_GMT: $O/create_movie_shakemap_AVS_DX_GMT.o $(LIBSPECFEM) OUTPUT_FILES/values_from_mesher.h
+#@COND_PYRE_FALSE@ ${FCCOMPILE_CHECK} -o xcreate_movie_shakemap_AVS_DX_GMT $O/create_movie_shakemap_AVS_DX_GMT.o $(LIBSPECFEM)
+ at COND_PYRE_FALSE@xcreate_movie_shakemap_AVS_DX_GMT: $O/create_movie_shakemap_AVS_DX_GMT.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o OUTPUT_FILES/surface_from_mesher.h
+ at COND_PYRE_FALSE@ ${FCCOMPILE_CHECK} -o xcreate_movie_shakemap_AVS_DX_GMT $O/create_movie_shakemap_AVS_DX_GMT.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o
+
+
+
+
xcombine_AVS_DX: $O/combine_AVS_DX.o $(LIBSPECFEM)
${FCCOMPILE_CHECK} -o xcombine_AVS_DX $O/combine_AVS_DX.o $(LIBSPECFEM)
@@ -282,10 +291,10 @@
$O/finalize_simulation.o: constants.h OUTPUT_FILES/values_from_mesher.h finalize_simulation.f90
${FCCOMPILE_NO_CHECK} -c -o $O/finalize_simulation.o finalize_simulation.f90
-$O/assemble_MPI_vector.o: constants.h OUTPUT_FILES/values_from_mesher.h assemble_MPI_vector.f90
+$O/assemble_MPI_vector.o: constants.h assemble_MPI_vector.f90
${FCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_vector.o assemble_MPI_vector.f90
-$O/assemble_MPI_scalar.o: constants.h OUTPUT_FILES/values_from_mesher.h assemble_MPI_scalar.f90
+$O/assemble_MPI_scalar.o: constants.h assemble_MPI_scalar.f90
${FCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_scalar.o assemble_MPI_scalar.f90
###
@@ -362,6 +371,9 @@
$O/check_mesh_resolution.o: constants.h check_mesh_resolution.f90
${FCCOMPILE_CHECK} -c -o $O/check_mesh_resolution.o check_mesh_resolution.f90
+$O/detect_surface.o: constants.h detect_surface.f90
+ ${FCCOMPILE_CHECK} -c -o $O/detect_surface.o detect_surface.f90
+
$O/gll_library.o: constants.h gll_library.f90
${FCCOMPILE_CHECK} -c -o $O/gll_library.o gll_library.f90
@@ -475,7 +487,10 @@
$O/compute_forces_with_Deville.o: constants.h compute_forces_with_Deville.f90
${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_with_Deville.o compute_forces_with_Deville.f90
+$O/compute_forces_elastic.o: constants.h compute_forces_elastic.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_elastic.o compute_forces_elastic.f90
+
###
### all obsolete files ?
###
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_scalar.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_scalar.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_scalar.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -29,7 +29,7 @@
subroutine assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,array_val, &
buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
- ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
@@ -38,7 +38,7 @@
include "constants.h"
! include values created by the mesher
- include "OUTPUT_FILES/values_from_mesher.h"
+! include "OUTPUT_FILES/values_from_mesher.h"
! array to assemble
real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: array_val
@@ -46,13 +46,13 @@
integer :: NPROC
integer :: NGLOB_AB
- real(kind=CUSTOM_REAL), dimension(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh) :: &
+ real(kind=CUSTOM_REAL), dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh
- integer :: ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh
- integer, dimension(ninterfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
- integer, dimension(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh) :: ibool_interfaces_ext_mesh
- integer, dimension(ninterfaces_ext_mesh) :: request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh
+ 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
+ integer, dimension(num_interfaces_ext_mesh) :: request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh
integer ipoin,iinterface
@@ -64,14 +64,14 @@
if(NPROC > 1) then
! partition border copy into the buffer
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
buffer_send_scalar_ext_mesh(ipoin,iinterface) = array_val(ibool_interfaces_ext_mesh(ipoin,iinterface))
enddo
enddo
! send messages
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call issend_cr(buffer_send_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
nibool_interfaces_ext_mesh(iinterface), &
my_neighbours_ext_mesh(iinterface), &
@@ -87,12 +87,12 @@
enddo
! wait for communications completion
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call wait_req(request_recv_scalar_ext_mesh(iinterface))
enddo
! adding contributions of neighbours
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
array_val(ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
array_val(ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_scalar_ext_mesh(ipoin,iinterface)
@@ -109,7 +109,7 @@
subroutine assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,array_val, &
buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
- ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh &
)
@@ -119,7 +119,7 @@
include "constants.h"
! include values created by the mesher
- include "OUTPUT_FILES/values_from_mesher.h"
+! include "OUTPUT_FILES/values_from_mesher.h"
! array to assemble
integer, dimension(NGLOB_AB) :: array_val
@@ -127,13 +127,13 @@
integer :: NPROC
integer :: NGLOB_AB
- integer, dimension(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh) :: &
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh
- integer :: ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh
- integer, dimension(ninterfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
- integer, dimension(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh) :: ibool_interfaces_ext_mesh
- integer, dimension(ninterfaces_ext_mesh) :: request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh
+ 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
+ integer, dimension(num_interfaces_ext_mesh) :: request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh
integer ipoin,iinterface
@@ -145,14 +145,14 @@
if(NPROC > 1) then
! partition border copy into the buffer
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
buffer_send_scalar_ext_mesh(ipoin,iinterface) = array_val(ibool_interfaces_ext_mesh(ipoin,iinterface))
enddo
enddo
! send messages
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call issend_i(buffer_send_scalar_ext_mesh(1,iinterface), &
nibool_interfaces_ext_mesh(iinterface), &
my_neighbours_ext_mesh(iinterface), &
@@ -168,12 +168,12 @@
enddo
! wait for communications completion
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call wait_req(request_recv_scalar_ext_mesh(iinterface))
enddo
! adding contributions of neighbours
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
array_val(ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
array_val(ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_scalar_ext_mesh(ipoin,iinterface)
@@ -181,7 +181,7 @@
enddo
! wait for communications completion (send)
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call wait_req(request_send_scalar_ext_mesh(iinterface))
enddo
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -29,7 +29,7 @@
subroutine assemble_MPI_vector_ext_mesh(NPROC,NGLOB_AB,array_val, &
buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
- ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
@@ -38,7 +38,7 @@
include "constants.h"
! include values created by the mesher
- include "OUTPUT_FILES/values_from_mesher.h"
+! include "OUTPUT_FILES/values_from_mesher.h"
! array to assemble
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
@@ -46,13 +46,13 @@
integer :: NPROC
integer :: NGLOB_AB
- real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh) :: &
+ real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh
- integer :: ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh
- integer, dimension(ninterfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
- integer, dimension(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh) :: ibool_interfaces_ext_mesh
- integer, dimension(ninterfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
+ 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
+ integer, dimension(num_interfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
integer ipoin,iinterface
@@ -64,14 +64,14 @@
if(NPROC > 1) then
! partition border copy into the buffer
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
buffer_send_vector_ext_mesh(:,ipoin,iinterface) = array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface))
enddo
enddo
! send messages
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call issend_cr(buffer_send_vector_ext_mesh(1,1,iinterface), &
NDIM*nibool_interfaces_ext_mesh(iinterface), &
my_neighbours_ext_mesh(iinterface), &
@@ -87,12 +87,12 @@
enddo
! wait for communications completion (recv)
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call wait_req(request_recv_vector_ext_mesh(iinterface))
enddo
! adding contributions of neighbours
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_vector_ext_mesh(:,ipoin,iinterface)
@@ -100,7 +100,7 @@
enddo
! wait for communications completion (send)
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call wait_req(request_send_vector_ext_mesh(iinterface))
enddo
@@ -110,7 +110,7 @@
subroutine assemble_MPI_vector_ext_mesh_s(NPROC,NGLOB_AB,array_val, &
buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
- ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
request_send_vector_ext_mesh,request_recv_vector_ext_mesh &
)
@@ -120,7 +120,7 @@
include "constants.h"
! include values created by the mesher
- include "OUTPUT_FILES/values_from_mesher.h"
+! include "OUTPUT_FILES/values_from_mesher.h"
! array to assemble
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
@@ -128,13 +128,13 @@
integer :: NPROC
integer :: NGLOB_AB
- real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh) :: &
+ real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh
- integer :: ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh
- integer, dimension(ninterfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
- integer, dimension(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh) :: ibool_interfaces_ext_mesh
- integer, dimension(ninterfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
+ 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
+ integer, dimension(num_interfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
integer ipoin,iinterface
@@ -146,14 +146,14 @@
if(NPROC > 1) then
! partition border copy into the buffer
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
buffer_send_vector_ext_mesh(:,ipoin,iinterface) = array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface))
enddo
enddo
! send messages
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call issend_cr(buffer_send_vector_ext_mesh(1,1,iinterface), &
NDIM*nibool_interfaces_ext_mesh(iinterface), &
my_neighbours_ext_mesh(iinterface), &
@@ -174,7 +174,7 @@
subroutine assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,array_val, &
- buffer_recv_vector_ext_mesh,ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
@@ -183,7 +183,7 @@
include "constants.h"
! include values created by the mesher
- include "OUTPUT_FILES/values_from_mesher.h"
+! include "OUTPUT_FILES/values_from_mesher.h"
! array to assemble
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
@@ -191,13 +191,13 @@
integer :: NPROC
integer :: NGLOB_AB
- real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh) :: &
+ real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
buffer_recv_vector_ext_mesh
- integer :: ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh
- integer, dimension(ninterfaces_ext_mesh) :: nibool_interfaces_ext_mesh
- integer, dimension(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh) :: ibool_interfaces_ext_mesh
- integer, dimension(ninterfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
integer ipoin,iinterface
@@ -209,12 +209,12 @@
if(NPROC > 1) then
! wait for communications completion (recv)
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call wait_req(request_recv_vector_ext_mesh(iinterface))
enddo
! adding contributions of neighbours
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_vector_ext_mesh(:,ipoin,iinterface)
@@ -222,7 +222,7 @@
enddo
! wait for communications completion (send)
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
call wait_req(request_send_vector_ext_mesh(iinterface))
enddo
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -0,0 +1,714 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! 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.
+!
+!=====================================================================
+
+! elastic solver
+
+subroutine compute_forces_elastic()
+
+ use specfem_par
+ use specfem_par_elastic
+ implicit none
+
+ integer:: iphase
+ logical:: phase_is_inner
+
+! distinguishes two runs: for points on MPI interfaces, and points within the partitions
+ do iphase=1,2
+
+ !first for points on MPI interfaces
+ if( iphase == 1 ) then
+ phase_is_inner = .false.
+ else
+ phase_is_inner = .true.
+ endif
+
+! elastic term
+ if(USE_DEVILLE_PRODUCTS) then
+ call compute_forces_with_Deville(phase_is_inner, NSPEC_AB,NGLOB_AB, &
+ displ,accel, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool, &
+ ispec_is_inner_ext_mesh, &
+ ATTENUATION,USE_OLSEN_ATTENUATION, &
+ 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_xz,epsilondev_yz,iflag_attenuation_store, &
+ rho_vs )
+
+ !call compute_forces_with_Deville( phase_is_inner ,NSPEC_AB,NGLOB_AB,&
+ ! ATTENUATION,USE_OLSEN_ATTENUATION,displ,accel,&
+ ! xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ ! kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh, &
+ ! NSOURCES,myrank,it,islice_selected_source,ispec_selected_source, &
+ ! xi_source,eta_source,gamma_source,nu_source, &
+ ! hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
+ ! 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_xz,epsilondev_yz,iflag_attenuation_store,&
+ ! ABSORBING_CONDITIONS, &
+ ! absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ ! absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ ! num_absorbing_boundary_faces, &
+ ! veloc,rho_vp,rho_vs)
+ else
+ call compute_forces_no_Deville( phase_is_inner, NSPEC_AB,NGLOB_AB, &
+ displ,accel, &
+ 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, &
+ kappastore,mustore,jacobian,ibool, &
+ ispec_is_inner_ext_mesh, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,&
+ 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_xz,epsilondev_yz,iflag_attenuation_store,&
+ rho_vs)
+ endif
+
+! adds elastic absorbing boundary term to acceleration (Stacey conditions)
+ if(ABSORBING_CONDITIONS) then
+ call compute_forces_elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner_ext_mesh,phase_is_inner, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces, &
+ veloc,rho_vp,rho_vs)
+ endif
+
+! adds source term (single-force/moment-tensor solution)
+ call compute_forces_elastic_source_term( NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner_ext_mesh,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source,nu_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays )
+
+
+! assemble all the contributions between slices using MPI
+ if( phase_is_inner .eqv. .false. ) then
+ call assemble_MPI_vector_ext_mesh_s(NPROC,NGLOB_AB,accel, &
+ buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh, &
+ request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+ else
+ call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,accel, &
+ buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,&
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+ endif
+
+ enddo
+
+! update acceleration
+! points inside processor's partition only
+! if(USE_DEVILLE_PRODUCTS) then
+! call compute_forces_with_Deville( .true., NSPEC_AB,NGLOB_AB,&
+! ATTENUATION,USE_OLSEN_ATTENUATION,displ,accel,&
+! xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+! kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh, &
+! NSOURCES,myrank,it,islice_selected_source,ispec_selected_source, &
+! xi_source,eta_source,gamma_source,nu_source, &
+! hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
+! 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_xz,epsilondev_yz,iflag_attenuation_store,&
+! ABSORBING_CONDITIONS, &
+! absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+! absorbing_boundary_ijk,absorbing_boundary_ispec, &
+! num_absorbing_boundary_faces, &
+! veloc,rho_vp,rho_vs)
+! else
+! call compute_forces_no_Deville(NSPEC_AB,NGLOB_AB,displ,accel,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, &
+! kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.true., &
+! NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source,hdur,dt)
+! endif
+!
+!! assemble all the contributions between slices using MPI
+! call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,accel, &
+! buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,&
+! max_nibool_interfaces_ext_mesh, &
+! nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+! request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+
+!! DK DK May 2009: removed this because now each slice of a CUBIT + SCOTCH mesh
+!! DK DK May 2009: has a different number of spectral elements and therefore
+!! DK DK May 2009: only the general non-blocking MPI routines assemble_MPI_vector_ext_mesh_s
+!! DK DK May 2009: and assemble_MPI_vector_ext_mesh_w above can be used.
+!! DK DK May 2009: For adjoint runs below (SIMULATION_TYPE == 3) they should be used as well.
+! if (SIMULATION_TYPE == 3) call assemble_MPI_vector(b_accel,iproc_xi,iproc_eta,addressing, &
+! iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
+! buffer_send_faces_vector,buffer_received_faces_vector,npoin2D_xi,npoin2D_eta, &
+! NPROC_XI,NPROC_ETA,NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NPOIN2DMAX_XY)
+
+end subroutine compute_forces_elastic
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! absorbing boundary term for elastic media (Stacey conditions)
+
+subroutine compute_forces_elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces, &
+ veloc,rho_vp,rho_vs)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! array with derivatives of Lagrange polynomials and precalculated products
+! 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
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! Stacey conditions
+! integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,nspec2D_top
+! integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
+! 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 indices i,j,k of all GLL points on xmin boundary in the element
+! integer :: ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin),ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax), &
+! ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin),ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax), &
+! ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom),ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top)
+
+! integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_ext) :: nimin,nimax,nkmin_eta
+! integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_ext) :: njmin,njmax,nkmin_xi
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
+
+! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmin) :: jacobian2D_xmin
+! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmax) :: jacobian2D_xmax
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymin) :: jacobian2D_ymin
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymax) :: jacobian2D_ymax
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_top) :: jacobian2D_top
+!
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmin) :: normal_xmin
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmax) :: normal_xmax
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymin) :: normal_ymin
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymax) :: normal_ymax
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM) :: normal_bottom
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_top) :: normal_top
+
+ integer :: num_absorbing_boundary_faces
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_jacobian2D
+ integer, dimension(3,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_ijk
+ integer, dimension(num_absorbing_boundary_faces) :: absorbing_boundary_ispec
+
+
+! local parameters
+ real(kind=CUSTOM_REAL) vx,vy,vz,nx,ny,nz,tx,ty,tz,vn,jacobianw !weight,jacobianl
+ integer :: ispec,iglob,i,j,k,iface,igll
+ !integer :: num_gll !,igll_i,igll_j,ispec2D
+
+
+! absorbs absorbing-boundary surface using Stacey condition (Clayton & Enquist)
+ do iface=1,num_absorbing_boundary_faces
+
+ ispec = absorbing_boundary_ispec(iface)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ ! reference gll points on boundary face
+ do igll = 1,NGLLSQUARE
+
+ ! gets local indices for GLL point
+ i = absorbing_boundary_ijk(1,igll,iface)
+ j = absorbing_boundary_ijk(2,igll,iface)
+ k = absorbing_boundary_ijk(3,igll,iface)
+
+ ! gets velocity
+ iglob=ibool(i,j,k,ispec)
+ vx=veloc(1,iglob)
+ vy=veloc(2,iglob)
+ vz=veloc(3,iglob)
+
+ ! gets associated normal
+ nx = absorbing_boundary_normal(1,igll,iface)
+ ny = absorbing_boundary_normal(2,igll,iface)
+ nz = absorbing_boundary_normal(3,igll,iface)
+
+ ! velocity component in normal direction (normal points out of element)
+ vn = vx*nx + vy*ny + vz*nz
+
+ ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+
+ ! gets associated, weighted jacobian
+ jacobianw = absorbing_boundary_jacobian2D(igll,iface)
+
+ ! adds stacey term (weak form)
+ accel(1,iglob) = accel(1,iglob) - tx*jacobianw
+ accel(2,iglob) = accel(2,iglob) - ty*jacobianw
+ accel(3,iglob) = accel(3,iglob) - tz*jacobianw
+
+ enddo
+
+ endif
+ enddo
+!
+!! old way: assumes box model with absorbing-boundary faces oriented with x,y,z planes
+!! xmin
+! do ispec2D=1,nspec2D_xmin
+!
+! ispec=ibelm_xmin(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+!! old regular mesh
+!! ! exclude elements that are not on absorbing edges
+!! if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
+!!
+!! i=1
+!! do k=nkmin_xi(1,ispec2D),NGLLZ
+!! do j=njmin(1,ispec2D),njmax(1,ispec2D)
+!
+!! new way, unregular element orientation
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLZ
+! do igll_i = 1,NGLLY
+! ! gets local indices for GLL point
+! i = ibelm_gll_xmin(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_xmin(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_xmin(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_xmin(1,igll_i,igll_j,ispec2D)
+! ny = normal_xmin(2,igll_i,igll_j,ispec2D)
+! nz = normal_xmin(3,igll_i,igll_j,ispec2D)
+! ! nx = normal_xmin(1,j,k,ispec2D)
+! ! ny = normal_xmin(2,j,k,ispec2D)
+! ! nz = normal_xmin(3,j,k,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_xmin(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_yz(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+!
+! enddo
+! enddo
+! end if
+! enddo
+!
+!! xmax
+! do ispec2D=1,nspec2D_xmax
+!
+! ispec=ibelm_xmax(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLZ
+! do igll_i = 1,NGLLY
+! ! gets local indices for GLL point
+! i = ibelm_gll_xmax(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_xmax(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_xmax(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_xmax(1,igll_i,igll_j,ispec2D)
+! ny = normal_xmax(2,igll_i,igll_j,ispec2D)
+! nz = normal_xmax(3,igll_i,igll_j,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_xmax(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_yz(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+!
+! enddo
+! enddo
+! end if
+! enddo
+!
+!! ymin
+! do ispec2D=1,nspec2D_ymin
+!
+! ispec=ibelm_ymin(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLZ
+! do igll_i = 1,NGLLX
+! ! gets local indices for GLL point
+! i = ibelm_gll_ymin(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_ymin(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_ymin(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_ymin(1,igll_i,igll_j,ispec2D)
+! ny = normal_ymin(2,igll_i,igll_j,ispec2D)
+! nz = normal_ymin(3,igll_i,igll_j,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_ymin(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_xz(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+!
+! enddo
+! enddo
+!
+! endif
+! enddo
+!
+!! ymax
+! do ispec2D=1,nspec2D_ymax
+!
+! ispec=ibelm_ymax(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLZ
+! do igll_i = 1,NGLLX
+! ! gets local indices for GLL point
+! i = ibelm_gll_ymax(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_ymax(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_ymax(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_ymax(1,igll_i,igll_j,ispec2D)
+! ny = normal_ymax(2,igll_i,igll_j,ispec2D)
+! nz = normal_ymax(3,igll_i,igll_j,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_ymax(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_xz(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+! enddo
+! enddo
+!
+! endif
+! enddo
+!
+!! bottom (zmin)
+! do ispec2D=1,NSPEC2D_BOTTOM
+!
+! ispec=ibelm_bottom(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLY
+! do igll_i = 1,NGLLX
+! ! gets local indices for GLL point
+! i = ibelm_gll_bottom(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_bottom(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_bottom(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_bottom(1,igll_i,igll_j,ispec2D)
+! ny = normal_bottom(2,igll_i,igll_j,ispec2D)
+! nz = normal_bottom(3,igll_i,igll_j,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_bottom(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_xy(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+!
+! enddo
+! enddo
+!
+! endif
+! enddo
+!
+!! absorbing at top surface - no free-surface?
+! if( ABSORB_TOP_SURFACE ) then
+! do ispec2D=1,NSPEC2D_TOP
+!
+! ispec=ibelm_top(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLY
+! do igll_i = 1,NGLLX
+! ! gets local indices for GLL point
+! i = ibelm_gll_top(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_top(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_top(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_top(1,igll_i,igll_j,ispec2D)
+! ny = normal_top(2,igll_i,igll_j,ispec2D)
+! nz = normal_top(3,igll_i,igll_j,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_top(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_xy(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+!
+! enddo
+! enddo
+!
+! endif
+! enddo
+! endif
+
+end subroutine compute_forces_elastic_absorbing_boundaries
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_forces_elastic_source_term( NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source,nu_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays )
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! source
+ integer :: NSOURCES,myrank,it
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(3,3,NSOURCES) :: nu_source
+ double precision, dimension(NSOURCES) :: hdur,hdur_gaussian,t_cmt
+ double precision :: dt
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
+
+ double precision, external :: comp_source_time_function
+
+! local parameters
+ double precision :: t0,f0
+ double precision :: stf
+ real(kind=CUSTOM_REAL) stf_used
+ integer :: isource,iglob,i,j,k
+
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+ if (ispec_is_inner(ispec_selected_source(isource)) .eqv. phase_is_inner) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ iglob = ibool(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec_selected_source(isource))
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+ t0 = 1.2d0/f0
+
+ if (it == 1 .and. myrank == 0) then
+ print *,'using a source of dominant frequency ',f0
+ print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ endif
+
+ ! we use nu_source(:,3) here because we want a source normal to the surface.
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ !accel(:,iglob) = accel(:,iglob) + &
+ ! sngl(nu_source(:,3,isource) * 10000000.d0 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
+ ! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
+ accel(:,iglob) = accel(:,iglob) + &
+ sngl(nu_source(:,3,isource) * 1.d10 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
+ exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
+
+ else
+
+ stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+ ! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec_selected_source(isource))
+ accel(:,iglob) = accel(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+ endif ! ispec_is_inner
+ endif ! myrank
+
+ enddo ! NSOURCES
+
+end subroutine compute_forces_elastic_source_term
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -23,10 +23,25 @@
!
!=====================================================================
-subroutine compute_forces_no_Deville(NSPEC_AB,NGLOB_AB,displ,accel,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, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner,phase_is_inner, &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source,hdur,dt)
+subroutine compute_forces_no_Deville( phase_is_inner, &
+ NSPEC_AB,NGLOB_AB,displ,accel,&
+ 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, &
+ kappastore,mustore,jacobian,ibool,&
+ ispec_is_inner,&
+ ATTENUATION,USE_OLSEN_ATTENUATION,&
+ 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_xz,epsilondev_yz,iflag_attenuation_store,&
+ rho_vs)
+
+! NSOURCES,myrank,islice_selected_source,&
+! ispec_selected_source,xi_source,eta_source,&
+! gamma_source,nu_source,hdur,dt)
+
implicit none
@@ -56,14 +71,30 @@
logical, dimension(NSPEC_AB) :: ispec_is_inner
logical :: phase_is_inner
+! memory variables and standard linear solids for attenuation
+ logical :: ATTENUATION,USE_OLSEN_ATTENUATION
+ integer :: NSPEC_ATTENUATION_AB
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
+ R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vs
+
! source
- integer :: NSOURCES,myrank,it
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision, dimension(3,3,NSOURCES) :: nu_source
- double precision, dimension(NSOURCES) :: hdur
- double precision :: dt
+! integer :: NSOURCES,myrank,it
+! integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+! double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+! double precision, dimension(3,3,NSOURCES) :: nu_source
+! double precision, dimension(NSOURCES) :: hdur
+! double precision :: dt
+! integer :: isource
+! double precision :: t0,f0
+! local parameters
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
@@ -88,213 +119,371 @@
real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
real(kind=CUSTOM_REAL) kappal
- integer :: isource
- double precision :: t0,f0
+! 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) epsilon_trace_over_3
+ real(kind=CUSTOM_REAL) vs_val
+ integer i_SLS,iselected
+
do ispec = 1,NSPEC_AB
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
- 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.
+ tempx2l = 0.
+ tempx3l = 0.
- tempy1l = 0.
- tempy2l = 0.
- tempy3l = 0.
+ tempy1l = 0.
+ tempy2l = 0.
+ tempy3l = 0.
- tempz1l = 0.
- tempz2l = 0.
- tempz3l = 0.
+ tempz1l = 0.
+ tempz2l = 0.
+ tempz3l = 0.
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l = tempx1l + displ(1,iglob)*hp1
- tempy1l = tempy1l + displ(2,iglob)*hp1
- tempz1l = tempz1l + displ(3,iglob)*hp1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + displ(1,iglob)*hp1
+ tempy1l = tempy1l + displ(2,iglob)*hp1
+ tempz1l = tempz1l + displ(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 = tempx2l + displ(1,iglob)*hp2
- tempy2l = tempy2l + displ(2,iglob)*hp2
- tempz2l = tempz2l + displ(3,iglob)*hp2
-!!! 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 = tempx2l + displ(1,iglob)*hp2
+ tempy2l = tempy2l + displ(2,iglob)*hp2
+ tempz2l = tempz2l + displ(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 = tempx3l + displ(1,iglob)*hp3
- tempy3l = tempy3l + displ(2,iglob)*hp3
- tempz3l = tempz3l + displ(3,iglob)*hp3
- 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 = tempx3l + displ(1,iglob)*hp3
+ tempy3l = tempy3l + displ(2,iglob)*hp3
+ tempz3l = tempz3l + displ(3,iglob)*hp3
+ enddo
-! get derivatives of ux, uy and uz 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)
+ ! get derivatives of ux, uy and uz 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)
- duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+ duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
- duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
- duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
- duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+ duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
- duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
- duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
- duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+ duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
-! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
+ ! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
- kappal = kappastore(i,j,k,ispec)
- mul = mustore(i,j,k,ispec)
+ kappal = kappastore(i,j,k,ispec)
+ mul = mustore(i,j,k,ispec)
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
+ if(ATTENUATION) then
+ ! compute deviatoric strain
+ epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_xx_loc(i,j,k) = duxdxl - epsilon_trace_over_3
+ epsilondev_yy_loc(i,j,k) = duydyl - epsilon_trace_over_3
+ epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl
+
+ !if (SIMULATION_TYPE == 3) then
+ ! b_epsilon_trace_over_3 = ONE_THIRD * (b_duxdxl + b_duydyl + b_duzdzl)
+ ! b_epsilondev_xx_loc(i,j,k) = b_duxdxl - b_epsilon_trace_over_3
+ ! b_epsilondev_yy_loc(i,j,k) = b_duydyl - b_epsilon_trace_over_3
+ ! b_epsilondev_xy_loc(i,j,k) = 0.5 * b_duxdyl_plus_duydxl
+ ! b_epsilondev_xz_loc(i,j,k) = 0.5 * b_duzdxl_plus_duxdzl
+ ! b_epsilondev_yz_loc(i,j,k) = 0.5 * b_duzdyl_plus_duydzl
+ !endif
-! compute stress sigma
- sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+ ! uses scaling rule similar to Olsen et al. (2003) or mesh flag
+ if(USE_OLSEN_ATTENUATION) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_Olsen_sediment( vs_val, iselected )
+ else
+ ! iflag from (CUBIT) mesh
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
+ ! use unrelaxed parameters if attenuation
+ mul = mul * one_minus_sum_beta(iselected)
+
+ endif
-! form dot product with test vector, symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+ ! compute stress sigma
+ sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
+ ! subtract memory variables if attenuation
+ if(ATTENUATION) then
+ do i_sls = 1,N_SLS
+ R_xx_val = R_xx(i,j,k,ispec,i_sls)
+ R_yy_val = R_yy(i,j,k,ispec,i_sls)
+ sigma_xx = sigma_xx - R_xx_val
+ sigma_yy = sigma_yy - R_yy_val
+ sigma_zz = sigma_zz + R_xx_val + R_yy_val
+ sigma_xy = sigma_xy - R_xy(i,j,k,ispec,i_sls)
+ sigma_xz = sigma_xz - R_xz(i,j,k,ispec,i_sls)
+ sigma_yz = sigma_yz - R_yz(i,j,k,ispec,i_sls)
+ enddo
+ endif
+
+ ! form dot product with test vector, symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
enddo
enddo
- enddo
- 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.
- tempy1l = 0.
- tempz1l = 0.
+ tempx1l = 0.
+ tempy1l = 0.
+ tempz1l = 0.
- tempx2l = 0.
- tempy2l = 0.
- tempz2l = 0.
+ tempx2l = 0.
+ tempy2l = 0.
+ tempz2l = 0.
- tempx3l = 0.
- tempy3l = 0.
- tempz3l = 0.
+ tempx3l = 0.
+ tempy3l = 0.
+ tempz3l = 0.
- do l=1,NGLLX
- fac1 = hprimewgll_xx(l,i)
- tempx1l = tempx1l + tempx1(l,j,k)*fac1
- tempy1l = tempy1l + tempy1(l,j,k)*fac1
- tempz1l = tempz1l + tempz1(l,j,k)*fac1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ do l=1,NGLLX
+ fac1 = hprimewgll_xx(l,i)
+ tempx1l = tempx1l + tempx1(l,j,k)*fac1
+ tempy1l = tempy1l + tempy1(l,j,k)*fac1
+ tempz1l = tempz1l + tempz1(l,j,k)*fac1
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- fac2 = hprimewgll_yy(l,j)
- tempx2l = tempx2l + tempx2(i,l,k)*fac2
- tempy2l = tempy2l + tempy2(i,l,k)*fac2
- tempz2l = tempz2l + tempz2(i,l,k)*fac2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ fac2 = hprimewgll_yy(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- fac3 = hprimewgll_zz(l,k)
- tempx3l = tempx3l + tempx3(i,j,l)*fac3
- tempy3l = tempy3l + tempy3(i,j,l)*fac3
- tempz3l = tempz3l + tempz3(i,j,l)*fac3
- enddo
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ fac3 = hprimewgll_zz(l,k)
+ tempx3l = tempx3l + tempx3(i,j,l)*fac3
+ tempy3l = tempy3l + tempy3(i,j,l)*fac3
+ tempz3l = tempz3l + tempz3(i,j,l)*fac3
+ enddo
- fac1 = wgllwgll_yz(j,k)
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
-! sum contributions from each element to the global mesh
+ ! sum contributions from each element to the global mesh
- iglob = ibool(i,j,k,ispec)
+ iglob = ibool(i,j,k,ispec)
- accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
- accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
- accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+ accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
- enddo
- enddo
- enddo
+ ! update memory variables based upon the Runge-Kutta scheme
+ if(ATTENUATION) then
+
+ ! use Runge-Kutta scheme to march in time
+ do i_sls = 1,N_SLS
- endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
+ ! get coefficients for that standard linear solid
+ if( USE_OLSEN_ATTENUATION ) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_Olsen_sediment( vs_val, iselected )
+ else
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ factor_loc = mustore(i,j,k,ispec) * factor_common(iselected,i_sls)
+ alphaval_loc = alphaval(iselected,i_sls)
+ betaval_loc = betaval(iselected,i_sls)
+ gammaval_loc = gammaval(iselected,i_sls)
+
+ ! term in xx
+ Sn = factor_loc * epsilondev_xx(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xx_loc(i,j,k)
+ R_xx(i,j,k,ispec,i_sls) = alphaval_loc * R_xx(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+
+ ! term in yy
+ Sn = factor_loc * epsilondev_yy(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_yy_loc(i,j,k)
+ R_yy(i,j,k,ispec,i_sls) = alphaval_loc * R_yy(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
- enddo ! spectral element loop
+ ! term in zz not computed since zero trace
+
+ ! term in xy
+ Sn = factor_loc * epsilondev_xy(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xy_loc(i,j,k)
+ R_xy(i,j,k,ispec,i_sls) = alphaval_loc * R_xy(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+
+ ! term in xz
+ Sn = factor_loc * epsilondev_xz(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xz_loc(i,j,k)
+ R_xz(i,j,k,ispec,i_sls) = alphaval_loc * R_xz(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
-! adding source
- do isource = 1,NSOURCES
+ ! term in yz
+ Sn = factor_loc * epsilondev_yz(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_yz_loc(i,j,k)
+ R_yz(i,j,k,ispec,i_sls) = alphaval_loc * R_yz(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+
+ !if (SIMULATION_TYPE == 3) then
+ ! b_alphaval_loc = b_alphaval(iselected,i_sls)
+ ! b_betaval_loc = b_betaval(iselected,i_sls)
+ ! b_gammaval_loc = b_gammaval(iselected,i_sls)
+ ! ! term in xx
+ ! b_Sn = factor_loc * b_epsilondev_xx(i,j,k,ispec)
+ ! b_Snp1 = factor_loc * b_epsilondev_xx_loc(i,j,k)
+ ! b_R_xx(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xx(i,j,k,ispec,i_sls) + &
+ ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! ! term in yy
+ ! b_Sn = factor_loc * b_epsilondev_yy(i,j,k,ispec)
+ ! b_Snp1 = factor_loc * b_epsilondev_yy_loc(i,j,k)
+ ! b_R_yy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yy(i,j,k,ispec,i_sls) + &
+ ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! ! term in zz not computed since zero trace
+ ! ! term in xy
+ ! b_Sn = factor_loc * b_epsilondev_xy(i,j,k,ispec)
+ ! b_Snp1 = factor_loc * b_epsilondev_xy_loc(i,j,k)
+ ! b_R_xy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xy(i,j,k,ispec,i_sls) + &
+ ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! ! term in xz
+ ! b_Sn = factor_loc * b_epsilondev_xz(i,j,k,ispec)
+ ! b_Snp1 = factor_loc * b_epsilondev_xz_loc(i,j,k)
+ ! b_R_xz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xz(i,j,k,ispec,i_sls) + &
+ ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! ! term in yz
+ ! b_Sn = factor_loc * b_epsilondev_yz(i,j,k,ispec)
+ ! b_Snp1 = factor_loc * b_epsilondev_yz_loc(i,j,k)
+ ! b_R_yz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yz(i,j,k,ispec,i_sls) + &
+ ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ !endif
- if (ispec_is_inner(ispec_selected_source(isource)) .eqv. phase_is_inner) then
+ enddo ! end of loop on memory variables
- if(USE_FORCE_POINT_SOURCE) then
+ endif ! end attenuation
-! add the source (only if this proc carries the source)
- if(myrank == islice_selected_source(isource)) then
- iglob = ibool(nint(xi_source(isource)), &
- nint(eta_source(isource)), &
- nint(gamma_source(isource)), &
- ispec_selected_source(isource))
- f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
- t0 = 1.2d0/f0
+ enddo
+ enddo
+ enddo
- if (it == 1 .and. myrank == 0) then
- print *,'using a source of dominant frequency ',f0
- print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
- print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
- endif
+ ! save deviatoric strain for Runge-Kutta scheme
+ if(ATTENUATION) then
+ epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:)
+ epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:)
+ epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:)
+ epsilondev_xz(:,:,:,ispec) = epsilondev_xz_loc(:,:,:)
+ epsilondev_yz(:,:,:,ispec) = epsilondev_yz_loc(:,:,:)
+ !if (SIMULATION_TYPE == 3) then
+ ! b_epsilondev_xx(:,:,:,ispec) = b_epsilondev_xx_loc(:,:,:)
+ ! b_epsilondev_yy(:,:,:,ispec) = b_epsilondev_yy_loc(:,:,:)
+ ! b_epsilondev_xy(:,:,:,ispec) = b_epsilondev_xy_loc(:,:,:)
+ ! b_epsilondev_xz(:,:,:,ispec) = b_epsilondev_xz_loc(:,:,:)
+ ! b_epsilondev_yz(:,:,:,ispec) = b_epsilondev_yz_loc(:,:,:)
+ !endif
+ endif
- ! we use nu_source(:,3) here because we want a source normal to the surface.
- ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
- !accel(:,iglob) = accel(:,iglob) + &
- ! sngl(nu_source(:,3,isource) * 10000000.d0 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
- ! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
- accel(:,iglob) = accel(:,iglob) + &
- sngl(nu_source(:,3,isource) * 1.d10 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
- exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
+ endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
- endif
- endif
+ enddo ! spectral element loop
- endif
+! forces in elastic media calculated in compute_forces_elastic...
+!! adding source
+! do isource = 1,NSOURCES
+!
+! if (ispec_is_inner(ispec_selected_source(isource)) .eqv. phase_is_inner) then
+!
+! if(USE_FORCE_POINT_SOURCE) then
+!
+!! add the source (only if this proc carries the source)
+! if(myrank == islice_selected_source(isource)) then
+!
+! iglob = ibool(nint(xi_source(isource)), &
+! nint(eta_source(isource)), &
+! nint(gamma_source(isource)), &
+! ispec_selected_source(isource))
+! f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+! t0 = 1.2d0/f0
+!
+! if (it == 1 .and. myrank == 0) then
+! print *,'using a source of dominant frequency ',f0
+! print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+! print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+! endif
+!
+! ! we use nu_source(:,3) here because we want a source normal to the surface.
+! ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+! !accel(:,iglob) = accel(:,iglob) + &
+! ! sngl(nu_source(:,3,isource) * 10000000.d0 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
+! ! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
+! accel(:,iglob) = accel(:,iglob) + &
+! sngl(nu_source(:,3,isource) * 1.d10 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
+! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
+!
+! endif
+! endif
+!
+! endif
+!
+! enddo
- enddo
-
end subroutine compute_forces_no_Deville
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -23,157 +23,24 @@
!
!=====================================================================
-subroutine compute_forces_with_Deville(phase_is_inner,NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner, &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source, &
- xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
- 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_xz,epsilondev_yz,iflag_attenuation_store, &
- ABSORBING_CONDITIONS, &
- absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
- absorbing_boundary_ijk,absorbing_boundary_ispec, &
- num_absorbing_boundary_faces, &
- veloc,rho_vp,rho_vs)
- implicit none
-
- include "constants.h"
-! include values created by the mesher
-! include "OUTPUT_FILES/values_from_mesher.h"
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ,accel
-
-! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
- kappastore,mustore,jacobian
-
-! array with derivatives of Lagrange polynomials and precalculated products
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
- 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
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
-! source
- integer :: NSOURCES,myrank,it
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision, dimension(3,3,NSOURCES) :: nu_source
- double precision, dimension(NSOURCES) :: hdur,hdur_gaussian,t_cmt
- double precision :: dt
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
-
-! integer :: isource
- double precision :: t0
- double precision :: stf
-
-! memory variables and standard linear solids for attenuation
- logical :: ATTENUATION
- integer :: NSPEC_ATTENUATION_AB
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
- R_xx,R_yy,R_xy,R_xz,R_yz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
-
-! Stacey conditions
- logical :: ABSORBING_CONDITIONS
-! integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,nspec2D_top
-! integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
-! 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
-! integer :: ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin),ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax), &
-! ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin),ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax), &
-! ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom),ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top)
-! integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_ext) :: nimin,nimax,nkmin_eta
-! integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_ext) :: njmin,njmax,nkmin_xi
-
-
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
-
-! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmin) :: jacobian2D_xmin
-! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmax) :: jacobian2D_xmax
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymin) :: jacobian2D_ymin
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymax) :: jacobian2D_ymax
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_top) :: jacobian2D_top
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmin) :: normal_xmin
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmax) :: normal_xmax
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymin) :: normal_ymin
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymax) :: normal_ymax
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM) :: normal_bottom
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_top) :: normal_top
-
- integer :: num_absorbing_boundary_faces
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_normal
- real(kind=CUSTOM_REAL), dimension(NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_jacobian2D
- integer, dimension(3,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_ijk
- integer, dimension(num_absorbing_boundary_faces) :: absorbing_boundary_ispec
-
-
-! computes elastic stiffness term
- call compute_forces_add_elastic_term(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner,phase_is_inner, &
- 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_xz,epsilondev_yz,iflag_attenuation_store )
-
-! adds absorbing boundary term to acceleration (Stacey conditions)
- if(ABSORBING_CONDITIONS) then
- call compute_forces_add_elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
- ibool,ispec_is_inner,phase_is_inner, &
- absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
- absorbing_boundary_ijk,absorbing_boundary_ispec, &
- num_absorbing_boundary_faces, &
- veloc,rho_vp,rho_vs)
- endif
-
-! adds source term
- call compute_forces_add_source_term( NSPEC_AB,NGLOB_AB,accel, &
- ibool,ispec_is_inner,phase_is_inner, &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
- xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays )
-
-end subroutine compute_forces_with_Deville
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-! elastic term
-
-subroutine compute_forces_add_elastic_term(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel, &
+subroutine compute_forces_with_Deville( phase_is_inner ,NSPEC_AB,NGLOB_AB, &
+ displ,accel, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner,phase_is_inner, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool, &
+ ispec_is_inner, &
+ ATTENUATION,USE_OLSEN_ATTENUATION, &
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_xz,epsilondev_yz,iflag_attenuation_store )
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
+ epsilondev_xz,epsilondev_yz,iflag_attenuation_store, &
+ rho_vs )
+! computes elastic tensor term
+
implicit none
include "constants.h"
@@ -203,7 +70,7 @@
logical :: phase_is_inner
! memory variables and standard linear solids for attenuation
- logical :: ATTENUATION
+ logical :: ATTENUATION,USE_OLSEN_ATTENUATION
integer :: NSPEC_ATTENUATION_AB
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
@@ -213,6 +80,8 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vs
+
! local parameters
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
@@ -249,11 +118,13 @@
equivalence(newtempy3,E2_mxm_m2_m1_5points)
equivalence(newtempz3,E3_mxm_m2_m1_5points)
+! 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) epsilon_trace_over_3
+ real(kind=CUSTOM_REAL) vs_val
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
@@ -267,7 +138,7 @@
real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
real(kind=CUSTOM_REAL) kappal
-
+
integer i_SLS,iselected
integer ispec,iglob
@@ -293,77 +164,77 @@
! for incompressible fluid flow, Cambridge University Press (2002),
! pages 386 and 389 and Figure 8.3.1
! call mxm_m1_m2_5points(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
- do j=1,m2
- do i=1,m1
- C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
+ do j=1,m2
+ do i=1,m1
+ C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
hprime_xx(i,5)*B1_m1_m2_5points(5,j)
- C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
+ C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
hprime_xx(i,5)*B2_m1_m2_5points(5,j)
- C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
+ C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
hprime_xx(i,5)*B3_m1_m2_5points(5,j)
+ enddo
enddo
- enddo
! call mxm_m1_m1_5points(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k), &
! hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
- do j=1,m1
- do i=1,m1
+ do j=1,m1
+ do i=1,m1
! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ do k = 1,NGLLX
+ tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
dummyx_loc(i,5,k)*hprime_xxT(5,j)
- tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
dummyy_loc(i,5,k)*hprime_xxT(5,j)
- tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ enddo
enddo
enddo
- enddo
! call mxm_m2_m1_5points(dummyx_loc,dummyy_loc,dummyz_loc,tempx3,tempy3,tempz3)
- do j=1,m1
- do i=1,m2
- C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ do j=1,m1
+ do i=1,m2
+ C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ enddo
enddo
- enddo
do k=1,NGLLZ
do j=1,NGLLY
@@ -405,16 +276,35 @@
mul = mustore(i,j,k,ispec)
if(ATTENUATION) then
- ! compute deviatoric strain
- epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_xx_loc(i,j,k) = duxdxl - epsilon_trace_over_3
- epsilondev_yy_loc(i,j,k) = duydyl - epsilon_trace_over_3
- epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl
+ ! compute deviatoric strain
+ epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_xx_loc(i,j,k) = duxdxl - epsilon_trace_over_3
+ epsilondev_yy_loc(i,j,k) = duydyl - epsilon_trace_over_3
+ epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl
+
+ !if (SIMULATION_TYPE == 3) then
+ ! b_epsilon_trace_over_3 = ONE_THIRD * (b_duxdxl + b_duydyl + b_duzdzl)
+ ! b_epsilondev_xx_loc(i,j,k) = b_duxdxl - b_epsilon_trace_over_3
+ ! b_epsilondev_yy_loc(i,j,k) = b_duydyl - b_epsilon_trace_over_3
+ ! b_epsilondev_xy_loc(i,j,k) = 0.5 * b_duxdyl_plus_duydxl
+ ! b_epsilondev_xz_loc(i,j,k) = 0.5 * b_duzdxl_plus_duxdzl
+ ! b_epsilondev_yz_loc(i,j,k) = 0.5 * b_duzdyl_plus_duydzl
+ !endif
+
+ ! uses scaling rule similar to Olsen et al. (2003) or mesh flag
+ if(USE_OLSEN_ATTENUATION) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_Olsen_sediment( vs_val, iselected )
+ else
+ ! iflag from (CUBIT) mesh
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ ! use unrelaxed parameters if attenuation
+ mul = mul * one_minus_sum_beta(iselected)
- ! use unrelaxed parameters if attenuation
- mul = mul * one_minus_sum_beta(iflag_attenuation_store(i,j,k,ispec))
endif
lambdalplus2mul = kappal + FOUR_THIRDS * mul
@@ -443,8 +333,6 @@
enddo
endif
-
-
! form dot product with test vector, symmetric form
tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
@@ -466,77 +354,77 @@
! for incompressible fluid flow, Cambridge University Press (2002),
! pages 386 and 389 and Figure 8.3.1
! call mxm_m1_m2_5points(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
- do j=1,m2
- do i=1,m1
- E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
+ do j=1,m2
+ do i=1,m1
+ E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
- E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
+ E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
- E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
+ E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
+ enddo
enddo
- enddo
! call mxm_m1_m1_5points(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k), &
! hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
- do i=1,m1
- do j=1,m1
+ do i=1,m1
+ do j=1,m1
! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
+ do k = 1,NGLLX
+ newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
tempx2(i,2,k)*hprimewgll_xx(2,j) + &
tempx2(i,3,k)*hprimewgll_xx(3,j) + &
tempx2(i,4,k)*hprimewgll_xx(4,j) + &
tempx2(i,5,k)*hprimewgll_xx(5,j)
- newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
+ newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
tempy2(i,2,k)*hprimewgll_xx(2,j) + &
tempy2(i,3,k)*hprimewgll_xx(3,j) + &
tempy2(i,4,k)*hprimewgll_xx(4,j) + &
tempy2(i,5,k)*hprimewgll_xx(5,j)
- newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
+ newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
tempz2(i,2,k)*hprimewgll_xx(2,j) + &
tempz2(i,3,k)*hprimewgll_xx(3,j) + &
tempz2(i,4,k)*hprimewgll_xx(4,j) + &
tempz2(i,5,k)*hprimewgll_xx(5,j)
+ enddo
enddo
enddo
- enddo
! call mxm_m2_m1_5points(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
- do j=1,m1
- do i=1,m2
- E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ do j=1,m1
+ do i=1,m2
+ E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
- E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
- E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ enddo
enddo
- enddo
do k=1,NGLLZ
do j=1,NGLLY
@@ -548,18 +436,27 @@
! sum contributions from each element to the global mesh using indirect addressing
iglob = ibool(i,j,k,ispec)
- accel(1,iglob) = accel(1,iglob) - fac1*newtempx1(i,j,k) - fac2*newtempx2(i,j,k) - fac3*newtempx3(i,j,k)
- accel(2,iglob) = accel(2,iglob) - fac1*newtempy1(i,j,k) - fac2*newtempy2(i,j,k) - fac3*newtempy3(i,j,k)
- accel(3,iglob) = accel(3,iglob) - fac1*newtempz1(i,j,k) - fac2*newtempz2(i,j,k) - fac3*newtempz3(i,j,k)
+ accel(1,iglob) = accel(1,iglob) - fac1*newtempx1(i,j,k) - &
+ fac2*newtempx2(i,j,k) - fac3*newtempx3(i,j,k)
+ accel(2,iglob) = accel(2,iglob) - fac1*newtempy1(i,j,k) - &
+ fac2*newtempy2(i,j,k) - fac3*newtempy3(i,j,k)
+ accel(3,iglob) = accel(3,iglob) - fac1*newtempz1(i,j,k) - &
+ fac2*newtempz2(i,j,k) - fac3*newtempz3(i,j,k)
- ! update memory variables based upon the Runge-Kutta scheme
+ ! update memory variables based upon the Runge-Kutta scheme
if(ATTENUATION) then
! use Runge-Kutta scheme to march in time
do i_sls = 1,N_SLS
! get coefficients for that standard linear solid
- iselected = iflag_attenuation_store(i,j,k,ispec)
+ if( USE_OLSEN_ATTENUATION ) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_Olsen_sediment( vs_val, iselected )
+ else
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
factor_loc = mustore(i,j,k,ispec) * factor_common(iselected,i_sls)
alphaval_loc = alphaval(iselected,i_sls)
betaval_loc = betaval(iselected,i_sls)
@@ -568,29 +465,66 @@
! term in xx
Sn = factor_loc * epsilondev_xx(i,j,k,ispec)
Snp1 = factor_loc * epsilondev_xx_loc(i,j,k)
- R_xx(i,j,k,ispec,i_sls) = alphaval_loc * R_xx(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
+ R_xx(i,j,k,ispec,i_sls) = alphaval_loc * R_xx(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
! term in yy
Sn = factor_loc * epsilondev_yy(i,j,k,ispec)
Snp1 = factor_loc * epsilondev_yy_loc(i,j,k)
- R_yy(i,j,k,ispec,i_sls) = alphaval_loc * R_yy(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
+ R_yy(i,j,k,ispec,i_sls) = alphaval_loc * R_yy(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
! term in zz not computed since zero trace
! term in xy
Sn = factor_loc * epsilondev_xy(i,j,k,ispec)
Snp1 = factor_loc * epsilondev_xy_loc(i,j,k)
- R_xy(i,j,k,ispec,i_sls) = alphaval_loc * R_xy(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
+ R_xy(i,j,k,ispec,i_sls) = alphaval_loc * R_xy(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
! term in xz
Sn = factor_loc * epsilondev_xz(i,j,k,ispec)
Snp1 = factor_loc * epsilondev_xz_loc(i,j,k)
- R_xz(i,j,k,ispec,i_sls) = alphaval_loc * R_xz(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
+ R_xz(i,j,k,ispec,i_sls) = alphaval_loc * R_xz(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
! term in yz
Sn = factor_loc * epsilondev_yz(i,j,k,ispec)
Snp1 = factor_loc * epsilondev_yz_loc(i,j,k)
- R_yz(i,j,k,ispec,i_sls) = alphaval_loc * R_yz(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
+ R_yz(i,j,k,ispec,i_sls) = alphaval_loc * R_yz(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+
+ !if (SIMULATION_TYPE == 3) then
+ ! b_alphaval_loc = b_alphaval(iselected,i_sls)
+ ! b_betaval_loc = b_betaval(iselected,i_sls)
+ ! b_gammaval_loc = b_gammaval(iselected,i_sls)
+ ! ! term in xx
+ ! b_Sn = factor_loc * b_epsilondev_xx(i,j,k,ispec)
+ ! b_Snp1 = factor_loc * b_epsilondev_xx_loc(i,j,k)
+ ! b_R_xx(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xx(i,j,k,ispec,i_sls) + &
+ ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! ! term in yy
+ ! b_Sn = factor_loc * b_epsilondev_yy(i,j,k,ispec)
+ ! b_Snp1 = factor_loc * b_epsilondev_yy_loc(i,j,k)
+ ! b_R_yy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yy(i,j,k,ispec,i_sls) + &
+ ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! ! term in zz not computed since zero trace
+ ! ! term in xy
+ ! b_Sn = factor_loc * b_epsilondev_xy(i,j,k,ispec)
+ ! b_Snp1 = factor_loc * b_epsilondev_xy_loc(i,j,k)
+ ! b_R_xy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xy(i,j,k,ispec,i_sls) + &
+ ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! ! term in xz
+ ! b_Sn = factor_loc * b_epsilondev_xz(i,j,k,ispec)
+ ! b_Snp1 = factor_loc * b_epsilondev_xz_loc(i,j,k)
+ ! b_R_xz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xz(i,j,k,ispec,i_sls) + &
+ ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! ! term in yz
+ ! b_Sn = factor_loc * b_epsilondev_yz(i,j,k,ispec)
+ ! b_Snp1 = factor_loc * b_epsilondev_yz_loc(i,j,k)
+ ! b_R_yz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yz(i,j,k,ispec,i_sls) + &
+ ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ !endif
enddo ! end of loop on memory variables
@@ -602,558 +536,28 @@
! save deviatoric strain for Runge-Kutta scheme
if(ATTENUATION) then
- epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:)
- epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:)
- epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:)
- epsilondev_xz(:,:,:,ispec) = epsilondev_xz_loc(:,:,:)
- epsilondev_yz(:,:,:,ispec) = epsilondev_yz_loc(:,:,:)
+ epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:)
+ epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:)
+ epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:)
+ epsilondev_xz(:,:,:,ispec) = epsilondev_xz_loc(:,:,:)
+ epsilondev_yz(:,:,:,ispec) = epsilondev_yz_loc(:,:,:)
+ !if (SIMULATION_TYPE == 3) then
+ ! b_epsilondev_xx(:,:,:,ispec) = b_epsilondev_xx_loc(:,:,:)
+ ! b_epsilondev_yy(:,:,:,ispec) = b_epsilondev_yy_loc(:,:,:)
+ ! b_epsilondev_xy(:,:,:,ispec) = b_epsilondev_xy_loc(:,:,:)
+ ! b_epsilondev_xz(:,:,:,ispec) = b_epsilondev_xz_loc(:,:,:)
+ ! b_epsilondev_yz(:,:,:,ispec) = b_epsilondev_yz_loc(:,:,:)
+ !endif
endif
endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
enddo ! spectral element loop
-end subroutine compute_forces_add_elastic_term
+end subroutine compute_forces_with_Deville
-!
-!-------------------------------------------------------------------------------------------------
-!
-! absorbing boundary term for elastic media (Stacey conditions)
-
-subroutine compute_forces_add_elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
- ibool,ispec_is_inner,phase_is_inner, &
- absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
- absorbing_boundary_ijk,absorbing_boundary_ispec, &
- num_absorbing_boundary_faces, &
- veloc,rho_vp,rho_vs)
-
- implicit none
-
- include "constants.h"
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
-! array with derivatives of Lagrange polynomials and precalculated products
-! 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
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
-! Stacey conditions
-! integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,nspec2D_top
-! integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
-! 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 indices i,j,k of all GLL points on xmin boundary in the element
-! integer :: ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin),ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax), &
-! ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin),ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax), &
-! ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom),ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top)
-
-! integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_ext) :: nimin,nimax,nkmin_eta
-! integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_ext) :: njmin,njmax,nkmin_xi
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
-
-! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmin) :: jacobian2D_xmin
-! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmax) :: jacobian2D_xmax
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymin) :: jacobian2D_ymin
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymax) :: jacobian2D_ymax
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_top) :: jacobian2D_top
-!
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmin) :: normal_xmin
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmax) :: normal_xmax
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymin) :: normal_ymin
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymax) :: normal_ymax
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM) :: normal_bottom
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_top) :: normal_top
-
- integer :: num_absorbing_boundary_faces
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_normal
- real(kind=CUSTOM_REAL), dimension(NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_jacobian2D
- integer, dimension(3,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_ijk
- integer, dimension(num_absorbing_boundary_faces) :: absorbing_boundary_ispec
-
-
-! local parameters
- real(kind=CUSTOM_REAL) vx,vy,vz,nx,ny,nz,tx,ty,tz,vn,jacobianw !weight,jacobianl
- integer :: ispec,iglob,i,j,k,iface,igll
- !integer :: num_gll !,igll_i,igll_j,ispec2D
-
-
-! absorbs absorbing-boundary surface using Stacey condition (Clayton & Enquist)
- do iface=1,num_absorbing_boundary_faces
-
- ispec = absorbing_boundary_ispec(iface)
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- ! reference gll points on boundary face
- do igll = 1,NGLLSQUARE
-
- ! gets local indices for GLL point
- i = absorbing_boundary_ijk(1,igll,iface)
- j = absorbing_boundary_ijk(2,igll,iface)
- k = absorbing_boundary_ijk(3,igll,iface)
-
- ! gets velocity
- iglob=ibool(i,j,k,ispec)
- vx=veloc(1,iglob)
- vy=veloc(2,iglob)
- vz=veloc(3,iglob)
-
- ! gets associated normal
- nx = absorbing_boundary_normal(1,igll,iface)
- ny = absorbing_boundary_normal(2,igll,iface)
- nz = absorbing_boundary_normal(3,igll,iface)
-
- ! velocity component in normal direction (normal points out of element)
- vn = vx*nx + vy*ny + vz*nz
-
- ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
- tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
- ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
- tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
-
- ! gets associated, weighted jacobian
- jacobianw = absorbing_boundary_jacobian2D(igll,iface)
-
- ! adds stacey term (weak form)
- accel(1,iglob) = accel(1,iglob) - tx*jacobianw
- accel(2,iglob) = accel(2,iglob) - ty*jacobianw
- accel(3,iglob) = accel(3,iglob) - tz*jacobianw
-
- enddo
-
- endif
- enddo
-!
-!! old way: assumes box model with absorbing-boundary faces oriented with x,y,z planes
-!! xmin
-! do ispec2D=1,nspec2D_xmin
-!
-! ispec=ibelm_xmin(ispec2D)
-!
-! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-!
-!! old regular mesh
-!! ! exclude elements that are not on absorbing edges
-!! if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
-!!
-!! i=1
-!! do k=nkmin_xi(1,ispec2D),NGLLZ
-!! do j=njmin(1,ispec2D),njmax(1,ispec2D)
-!
-!! new way, unregular element orientation
-! ! reference gll points on boundary face
-! do igll_j = 1,NGLLZ
-! do igll_i = 1,NGLLY
-! ! gets local indices for GLL point
-! i = ibelm_gll_xmin(1,igll_i,igll_j,ispec2D)
-! j = ibelm_gll_xmin(2,igll_i,igll_j,ispec2D)
-! k = ibelm_gll_xmin(3,igll_i,igll_j,ispec2D)
-!
-! ! gets velocity
-! iglob=ibool(i,j,k,ispec)
-! vx=veloc(1,iglob)
-! vy=veloc(2,iglob)
-! vz=veloc(3,iglob)
-!
-! ! gets associated normal
-! nx = normal_xmin(1,igll_i,igll_j,ispec2D)
-! ny = normal_xmin(2,igll_i,igll_j,ispec2D)
-! nz = normal_xmin(3,igll_i,igll_j,ispec2D)
-! ! nx = normal_xmin(1,j,k,ispec2D)
-! ! ny = normal_xmin(2,j,k,ispec2D)
-! ! nz = normal_xmin(3,j,k,ispec2D)
-!
-! ! velocity component in normal direction (normal points out of element)
-! vn = vx*nx + vy*ny + vz*nz
-!
-! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
-! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
-! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
-! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
-!
-! ! gets associated jacobian and 2D weights
-! jacobianl = jacobian2D_xmin(igll_i,igll_j,ispec2D)
-! weight = jacobianl*wgllwgll_yz(igll_i,igll_j)
-!
-! ! adds stacey term (weak form)
-! accel(1,iglob) = accel(1,iglob) - tx*weight
-! accel(2,iglob) = accel(2,iglob) - ty*weight
-! accel(3,iglob) = accel(3,iglob) - tz*weight
-!
-! enddo
-! enddo
-! end if
-! enddo
-!
-!! xmax
-! do ispec2D=1,nspec2D_xmax
-!
-! ispec=ibelm_xmax(ispec2D)
-!
-! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-!
-! ! reference gll points on boundary face
-! do igll_j = 1,NGLLZ
-! do igll_i = 1,NGLLY
-! ! gets local indices for GLL point
-! i = ibelm_gll_xmax(1,igll_i,igll_j,ispec2D)
-! j = ibelm_gll_xmax(2,igll_i,igll_j,ispec2D)
-! k = ibelm_gll_xmax(3,igll_i,igll_j,ispec2D)
-!
-! ! gets velocity
-! iglob=ibool(i,j,k,ispec)
-! vx=veloc(1,iglob)
-! vy=veloc(2,iglob)
-! vz=veloc(3,iglob)
-!
-! ! gets associated normal
-! nx = normal_xmax(1,igll_i,igll_j,ispec2D)
-! ny = normal_xmax(2,igll_i,igll_j,ispec2D)
-! nz = normal_xmax(3,igll_i,igll_j,ispec2D)
-!
-! ! velocity component in normal direction (normal points out of element)
-! vn = vx*nx + vy*ny + vz*nz
-!
-! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
-! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
-! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
-! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
-!
-! ! gets associated jacobian and 2D weights
-! jacobianl = jacobian2D_xmax(igll_i,igll_j,ispec2D)
-! weight = jacobianl*wgllwgll_yz(igll_i,igll_j)
-!
-! ! adds stacey term (weak form)
-! accel(1,iglob) = accel(1,iglob) - tx*weight
-! accel(2,iglob) = accel(2,iglob) - ty*weight
-! accel(3,iglob) = accel(3,iglob) - tz*weight
-!
-! enddo
-! enddo
-! end if
-! enddo
-!
-!! ymin
-! do ispec2D=1,nspec2D_ymin
-!
-! ispec=ibelm_ymin(ispec2D)
-!
-! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-!
-! ! reference gll points on boundary face
-! do igll_j = 1,NGLLZ
-! do igll_i = 1,NGLLX
-! ! gets local indices for GLL point
-! i = ibelm_gll_ymin(1,igll_i,igll_j,ispec2D)
-! j = ibelm_gll_ymin(2,igll_i,igll_j,ispec2D)
-! k = ibelm_gll_ymin(3,igll_i,igll_j,ispec2D)
-!
-! ! gets velocity
-! iglob=ibool(i,j,k,ispec)
-! vx=veloc(1,iglob)
-! vy=veloc(2,iglob)
-! vz=veloc(3,iglob)
-!
-! ! gets associated normal
-! nx = normal_ymin(1,igll_i,igll_j,ispec2D)
-! ny = normal_ymin(2,igll_i,igll_j,ispec2D)
-! nz = normal_ymin(3,igll_i,igll_j,ispec2D)
-!
-! ! velocity component in normal direction (normal points out of element)
-! vn = vx*nx + vy*ny + vz*nz
-!
-! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
-! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
-! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
-! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
-!
-! ! gets associated jacobian and 2D weights
-! jacobianl = jacobian2D_ymin(igll_i,igll_j,ispec2D)
-! weight = jacobianl*wgllwgll_xz(igll_i,igll_j)
-!
-! ! adds stacey term (weak form)
-! accel(1,iglob) = accel(1,iglob) - tx*weight
-! accel(2,iglob) = accel(2,iglob) - ty*weight
-! accel(3,iglob) = accel(3,iglob) - tz*weight
-!
-! enddo
-! enddo
-!
-! endif
-! enddo
-!
-!! ymax
-! do ispec2D=1,nspec2D_ymax
-!
-! ispec=ibelm_ymax(ispec2D)
-!
-! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-!
-! ! reference gll points on boundary face
-! do igll_j = 1,NGLLZ
-! do igll_i = 1,NGLLX
-! ! gets local indices for GLL point
-! i = ibelm_gll_ymax(1,igll_i,igll_j,ispec2D)
-! j = ibelm_gll_ymax(2,igll_i,igll_j,ispec2D)
-! k = ibelm_gll_ymax(3,igll_i,igll_j,ispec2D)
-!
-! ! gets velocity
-! iglob=ibool(i,j,k,ispec)
-! vx=veloc(1,iglob)
-! vy=veloc(2,iglob)
-! vz=veloc(3,iglob)
-!
-! ! gets associated normal
-! nx = normal_ymax(1,igll_i,igll_j,ispec2D)
-! ny = normal_ymax(2,igll_i,igll_j,ispec2D)
-! nz = normal_ymax(3,igll_i,igll_j,ispec2D)
-!
-! ! velocity component in normal direction (normal points out of element)
-! vn = vx*nx + vy*ny + vz*nz
-!
-! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
-! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
-! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
-! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
-!
-! ! gets associated jacobian and 2D weights
-! jacobianl = jacobian2D_ymax(igll_i,igll_j,ispec2D)
-! weight = jacobianl*wgllwgll_xz(igll_i,igll_j)
-!
-! ! adds stacey term (weak form)
-! accel(1,iglob) = accel(1,iglob) - tx*weight
-! accel(2,iglob) = accel(2,iglob) - ty*weight
-! accel(3,iglob) = accel(3,iglob) - tz*weight
-! enddo
-! enddo
-!
-! endif
-! enddo
-!
-!! bottom (zmin)
-! do ispec2D=1,NSPEC2D_BOTTOM
-!
-! ispec=ibelm_bottom(ispec2D)
-!
-! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-!
-! ! reference gll points on boundary face
-! do igll_j = 1,NGLLY
-! do igll_i = 1,NGLLX
-! ! gets local indices for GLL point
-! i = ibelm_gll_bottom(1,igll_i,igll_j,ispec2D)
-! j = ibelm_gll_bottom(2,igll_i,igll_j,ispec2D)
-! k = ibelm_gll_bottom(3,igll_i,igll_j,ispec2D)
-!
-! ! gets velocity
-! iglob=ibool(i,j,k,ispec)
-! vx=veloc(1,iglob)
-! vy=veloc(2,iglob)
-! vz=veloc(3,iglob)
-!
-! ! gets associated normal
-! nx = normal_bottom(1,igll_i,igll_j,ispec2D)
-! ny = normal_bottom(2,igll_i,igll_j,ispec2D)
-! nz = normal_bottom(3,igll_i,igll_j,ispec2D)
-!
-! ! velocity component in normal direction (normal points out of element)
-! vn = vx*nx + vy*ny + vz*nz
-!
-! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
-! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
-! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
-! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
-!
-! ! gets associated jacobian and 2D weights
-! jacobianl = jacobian2D_bottom(igll_i,igll_j,ispec2D)
-! weight = jacobianl*wgllwgll_xy(igll_i,igll_j)
-!
-! ! adds stacey term (weak form)
-! accel(1,iglob) = accel(1,iglob) - tx*weight
-! accel(2,iglob) = accel(2,iglob) - ty*weight
-! accel(3,iglob) = accel(3,iglob) - tz*weight
-!
-! enddo
-! enddo
-!
-! endif
-! enddo
-!
-!! absorbing at top surface - no free-surface?
-! if( ABSORB_TOP_SURFACE ) then
-! do ispec2D=1,NSPEC2D_TOP
-!
-! ispec=ibelm_top(ispec2D)
-!
-! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-!
-! ! reference gll points on boundary face
-! do igll_j = 1,NGLLY
-! do igll_i = 1,NGLLX
-! ! gets local indices for GLL point
-! i = ibelm_gll_top(1,igll_i,igll_j,ispec2D)
-! j = ibelm_gll_top(2,igll_i,igll_j,ispec2D)
-! k = ibelm_gll_top(3,igll_i,igll_j,ispec2D)
-!
-! ! gets velocity
-! iglob=ibool(i,j,k,ispec)
-! vx=veloc(1,iglob)
-! vy=veloc(2,iglob)
-! vz=veloc(3,iglob)
-!
-! ! gets associated normal
-! nx = normal_top(1,igll_i,igll_j,ispec2D)
-! ny = normal_top(2,igll_i,igll_j,ispec2D)
-! nz = normal_top(3,igll_i,igll_j,ispec2D)
-!
-! ! velocity component in normal direction (normal points out of element)
-! vn = vx*nx + vy*ny + vz*nz
-!
-! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
-! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
-! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
-! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
-!
-! ! gets associated jacobian and 2D weights
-! jacobianl = jacobian2D_top(igll_i,igll_j,ispec2D)
-! weight = jacobianl*wgllwgll_xy(igll_i,igll_j)
-!
-! ! adds stacey term (weak form)
-! accel(1,iglob) = accel(1,iglob) - tx*weight
-! accel(2,iglob) = accel(2,iglob) - ty*weight
-! accel(3,iglob) = accel(3,iglob) - tz*weight
-!
-! enddo
-! enddo
-!
-! endif
-! enddo
-! endif
-
-end subroutine compute_forces_add_elastic_absorbing_boundaries
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine compute_forces_add_source_term( NSPEC_AB,NGLOB_AB,accel, &
- ibool,ispec_is_inner,phase_is_inner, &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
- xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays )
-
- implicit none
-
- include "constants.h"
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
-
-! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
-! source
- integer :: NSOURCES,myrank,it
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision, dimension(3,3,NSOURCES) :: nu_source
- double precision, dimension(NSOURCES) :: hdur,hdur_gaussian,t_cmt
- double precision :: dt
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
-
- double precision, external :: comp_source_time_function
-
-! local parameters
- double precision :: t0,f0
- double precision :: stf
- real(kind=CUSTOM_REAL) stf_used
- integer :: isource,iglob,i,j,k
-
- do isource = 1,NSOURCES
-
- ! add the source (only if this proc carries the source)
- if(myrank == islice_selected_source(isource)) then
-
- if (ispec_is_inner(ispec_selected_source(isource)) .eqv. phase_is_inner) then
-
- if(USE_FORCE_POINT_SOURCE) then
-
- iglob = ibool(nint(xi_source(isource)), &
- nint(eta_source(isource)), &
- nint(gamma_source(isource)), &
- ispec_selected_source(isource))
- f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
- t0 = 1.2d0/f0
-
- if (it == 1 .and. myrank == 0) then
- print *,'using a source of dominant frequency ',f0
- print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
- print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
- endif
-
- ! we use nu_source(:,3) here because we want a source normal to the surface.
- ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
- !accel(:,iglob) = accel(:,iglob) + &
- ! sngl(nu_source(:,3,isource) * 10000000.d0 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
- ! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
- accel(:,iglob) = accel(:,iglob) + &
- sngl(nu_source(:,3,isource) * 1.d10 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
- exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
-
- else
-
- stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- stf_used = sngl(stf)
- else
- stf_used = stf
- endif
-
- ! add source array
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec_selected_source(isource))
- accel(:,iglob) = accel(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
- enddo
- enddo
- enddo
-
- endif ! USE_FORCE_POINT_SOURCE
- endif ! ispec_is_inner
- endif ! myrank
-
- enddo ! NSOURCES
-
-end subroutine compute_forces_add_source_term
-
!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -1280,3 +684,136 @@
!
! end subroutine old_mxm_m2_m1_5points
!
+
+
+!subroutine compute_forces_with_Deville(phase_is_inner,NSPEC_AB,NGLOB_AB,&
+! ATTENUATION,USE_OLSEN_ATTENUATION,displ,accel, &
+! xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+! kappastore,mustore,jacobian,ibool,ispec_is_inner, &
+! NSOURCES,myrank,it,islice_selected_source,ispec_selected_source, &
+! xi_source,eta_source,gamma_source,nu_source, &
+! hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
+! 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_xz,epsilondev_yz,iflag_attenuation_store, &
+! ABSORBING_CONDITIONS, &
+! absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+! absorbing_boundary_ijk,absorbing_boundary_ispec, &
+! num_absorbing_boundary_faces, &
+! veloc,rho_vp,rho_vs)
+!
+! implicit none
+!
+! include "constants.h"
+!! include values created by the mesher
+!! include "OUTPUT_FILES/values_from_mesher.h"
+!
+! integer :: NSPEC_AB,NGLOB_AB
+!
+!! displacement and acceleration
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ,accel
+!
+!! arrays with mesh parameters per slice
+! integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+! xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+! kappastore,mustore,jacobian
+!
+!! array with derivatives of Lagrange polynomials and precalculated products
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
+! 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
+!
+!! communication overlap
+! logical, dimension(NSPEC_AB) :: ispec_is_inner
+! logical :: phase_is_inner
+!
+!! source
+! integer :: NSOURCES,myrank,it
+! integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+! double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+! double precision, dimension(3,3,NSOURCES) :: nu_source
+! double precision, dimension(NSOURCES) :: hdur,hdur_gaussian,t_cmt
+! double precision :: dt
+! real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
+!
+!! integer :: isource
+! double precision :: t0
+! double precision :: stf
+!
+!! memory variables and standard linear solids for attenuation
+! logical :: ATTENUATION,USE_OLSEN_ATTENUATION
+! integer :: NSPEC_ATTENUATION_AB
+! integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
+! real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
+! real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
+! R_xx,R_yy,R_xy,R_xz,R_yz
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
+! epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+!
+!! Stacey conditions
+! logical :: ABSORBING_CONDITIONS
+!! integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,nspec2D_top
+!! integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
+!! 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
+!! integer :: ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin),ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax), &
+!! ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin),ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax), &
+!! ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom),ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top)
+!! integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_ext) :: nimin,nimax,nkmin_eta
+!! integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_ext) :: njmin,njmax,nkmin_xi
+!
+!
+!
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
+!
+!! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmin) :: jacobian2D_xmin
+!! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmax) :: jacobian2D_xmax
+!! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymin) :: jacobian2D_ymin
+!! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymax) :: jacobian2D_ymax
+!! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
+!! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_top) :: jacobian2D_top
+!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmin) :: normal_xmin
+!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmax) :: normal_xmax
+!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymin) :: normal_ymin
+!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymax) :: normal_ymax
+!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM) :: normal_bottom
+!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_top) :: normal_top
+!
+! integer :: num_absorbing_boundary_faces
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_normal
+! real(kind=CUSTOM_REAL), dimension(NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_jacobian2D
+! integer, dimension(3,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_ijk
+! integer, dimension(num_absorbing_boundary_faces) :: absorbing_boundary_ispec
+!
+!
+!! computes elastic stiffness term
+! call compute_forces_add_elastic_term(NSPEC_AB,NGLOB_AB,&
+! ATTENUATION,USE_OLSEN_ATTENUATION,displ,accel, &
+! xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+! hprime_xx,hprime_xxT,&
+! hprimewgll_xx,hprimewgll_xxT,&
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+! kappastore,mustore,jacobian,ibool,ispec_is_inner,phase_is_inner, &
+! 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_xz,epsilondev_yz,iflag_attenuation_store,&
+! rho_vs )
+!
+!
+!end subroutine compute_forces_with_Deville
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -73,7 +73,7 @@
! create include file for the solver
call save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
ATTENUATION,ANISOTROPY,NSTEP,DT, &
- SIMULATION_TYPE,0.d0)
+ SIMULATION_TYPE,0.d0,0)
print *
print *,'edit file OUTPUT_FILES/values_from_mesher.h to see some statistics about the mesh'
print *
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -33,7 +33,8 @@
implicit none
include "constants.h"
-
+ include "OUTPUT_FILES/surface_from_mesher.h"
+
! number of points in each AVS or OpenDX quadrangular cell for movies
integer, parameter :: NGNOD2D_AVS_DX = 4
@@ -125,19 +126,18 @@
real(kind=CUSTOM_REAL), parameter :: X_SOURCE_EXT_MESH = -9023.021484375
real(kind=CUSTOM_REAL), parameter :: Y_SOURCE_EXT_MESH = 6123.611328125
real(kind=CUSTOM_REAL), parameter :: Z_SOURCE_EXT_MESH = 17.96331405639648
-
- ! movie arrays (store_val_x_all_external_mesh) size
-! integer, parameter :: NSPEC_SURFACE_EXT_MESH = 15808*4
-
- ! total number of spectral elements at surface
- integer, parameter :: NSPEC_SURFACE_EXT_MESH = 7650 ! movie: nfaces_surface_glob_ext_mesh
+!--------------------------------------------
+!!!! NL NL
! order of points representing the 2D square element
integer,dimension(NGNOD2D_AVS_DX),parameter :: iorder = (/1,3,2,4/)
- integer,dimension(NGNOD2D_AVS_DX),parameter :: iorder2 = (/1,3,4,2/)
+
+! obsolete, should be defined in OUTPUT_FILES/surface_from_mesher.h...
+! movie arrays (store_val_x_all_external_mesh) size
+! integer, parameter :: NSPEC_SURFACE_EXT_MESH = 15808*4
+! total number of spectral elements at surface
+! integer, parameter :: NSPEC_SURFACE_EXT_MESH = 7650 ! movie: nfaces_surface_glob_ext_mesh
-!--------------------------------------------
-!!!! NL NL
! ************** PROGRAM STARTS HERE **************
@@ -173,7 +173,6 @@
SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
-
! compute other parameters based upon values read
! if( .not. USE_EXTERNAL_MESH ) then
! call compute_parameters(NER,NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -30,7 +30,7 @@
nodes_coords_ext_mesh, elmnts_ext_mesh, &
max_static_memory_size, mat_ext_mesh, materials_ext_mesh, &
nmat_ext_mesh, undef_mat_prop, nundefMat_ext_mesh, &
- ninterface_ext_mesh, max_interface_size_ext_mesh, &
+ num_interfaces_ext_mesh, max_interface_size_ext_mesh, &
my_neighbours_ext_mesh, my_nelmnts_neighbours_ext_mesh, &
my_interfaces_ext_mesh, &
ibool_interfaces_ext_mesh, nibool_interfaces_ext_mesh, &
@@ -77,12 +77,12 @@
character (len=30), dimension(5,nundefMat_ext_mesh):: undef_mat_prop
! double precision, external :: materials_ext_mesh
- integer :: ninterface_ext_mesh,max_interface_size_ext_mesh
- integer, dimension(ninterface_ext_mesh) :: my_neighbours_ext_mesh
- integer, dimension(ninterface_ext_mesh) :: my_nelmnts_neighbours_ext_mesh
- integer, dimension(6,max_interface_size_ext_mesh,ninterface_ext_mesh) :: my_interfaces_ext_mesh
- integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,ninterface_ext_mesh) :: ibool_interfaces_ext_mesh
- integer, dimension(ninterface_ext_mesh) :: nibool_interfaces_ext_mesh
+ integer :: num_interfaces_ext_mesh,max_interface_size_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: my_nelmnts_neighbours_ext_mesh
+ integer, dimension(6,max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: my_interfaces_ext_mesh
+ integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
! absorbing boundaries
integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, NSPEC2D_BOTTOM, NSPEC2D_TOP
@@ -457,7 +457,7 @@
my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
ibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh, &
- ninterface_ext_mesh,max_interface_size_ext_mesh, &
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
xstore_dummy,ystore_dummy,zstore_dummy)
! saves the binary files
@@ -477,12 +477,12 @@
absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
absorbing_boundary_ijk,absorbing_boundary_ispec, &
num_absorbing_boundary_faces, &
- ninterface_ext_mesh,my_neighbours_ext_mesh,nibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,my_neighbours_ext_mesh,nibool_interfaces_ext_mesh, &
max_interface_size_ext_mesh,ibool_interfaces_ext_mesh, &
prname,SAVE_MESH_FILES)
! computes the approximate amount of static memory needed to run the solver
- call memory_eval(nspec,nglob,maxval(nibool_interfaces_ext_mesh),ninterface_ext_mesh,static_memory_size)
+ call memory_eval(nspec,nglob,maxval(nibool_interfaces_ext_mesh),num_interfaces_ext_mesh,static_memory_size)
call max_all_dp(static_memory_size, max_static_memory_size)
@@ -1839,7 +1839,7 @@
write(IMAIN,*) ' absorbing boundary:'
write(IMAIN,*) ' total number of faces = ',iabs
if( ABSORB_FREE_SURFACE ) then
- write(IMAIN,*) 'absorbing boundary includes free surface'
+ write(IMAIN,*) ' absorbing boundary includes free surface'
endif
endif
@@ -1876,7 +1876,7 @@
my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
ibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh, &
- ninterface_ext_mesh,max_interface_size_ext_mesh, &
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
xstore_dummy,ystore_dummy,zstore_dummy)
! sets up the MPI interface for communication between partitions
@@ -1892,13 +1892,13 @@
integer :: nelmnts_ext_mesh
integer, dimension(ESIZE,nelmnts_ext_mesh) :: elmnts_ext_mesh
- integer :: ninterface_ext_mesh,max_interface_size_ext_mesh
+ integer :: num_interfaces_ext_mesh,max_interface_size_ext_mesh
- integer, dimension(ninterface_ext_mesh) :: my_nelmnts_neighbours_ext_mesh
- integer, dimension(6,max_interface_size_ext_mesh,ninterface_ext_mesh) :: my_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: my_nelmnts_neighbours_ext_mesh
+ integer, dimension(6,max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: my_interfaces_ext_mesh
- integer, dimension(ninterface_ext_mesh) :: nibool_interfaces_ext_mesh
- integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,ninterface_ext_mesh) :: ibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
+ integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
@@ -1922,16 +1922,16 @@
call prepare_assemble_MPI (nelmnts_ext_mesh,ibool, &
elmnts_ext_mesh, ESIZE, &
nglob, &
- ninterface_ext_mesh, max_interface_size_ext_mesh, &
+ num_interfaces_ext_mesh, max_interface_size_ext_mesh, &
my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
ibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh &
)
- allocate(nibool_interfaces_ext_mesh_true(ninterface_ext_mesh))
+ allocate(nibool_interfaces_ext_mesh_true(num_interfaces_ext_mesh))
! sort ibool comm buffers lexicographically
- do iinterface = 1, ninterface_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
allocate(xp(nibool_interfaces_ext_mesh(iinterface)))
allocate(yp(nibool_interfaces_ext_mesh(iinterface)))
Added: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/Makefile
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/Makefile (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/Makefile 2009-10-22 21:01:47 UTC (rev 15867)
@@ -0,0 +1,29 @@
+# Makefile
+
+F90 = gfortran
+
+SCOTCH_LIBS = /data2/tarje/SCOTCH/lib/libscotch.a /data2/tarje/SCOTCH/lib/libscotcherr.a
+#SCOTCH_LIBS = /scratch/network/SCOTCH/lib/libscotch.a /scratch/network/SCOTCH/lib/libscotcherr.a
+
+LIBS = part_decompose_mesh_SCOTCH.o \
+ decompose_mesh_SCOTCH.o \
+ program_decompose_mesh_SCOTCH.o
+
+# targets
+all: xdecompose_mesh_SCOTCH
+
+xdecompose_mesh_SCOTCH: $(LIBS)
+ ${F90} -Wall -o xdecompose_mesh_SCOTCH $(LIBS) $(SCOTCH_LIBS)
+
+
+part_decompose_mesh_SCOTCH.o: part_decompose_mesh_SCOTCH.f90
+ ${F90} -Wall -c part_decompose_mesh_SCOTCH.f90
+
+decompose_mesh_SCOTCH.o: decompose_mesh_SCOTCH.f90 part_decompose_mesh_SCOTCH.f90
+ ${F90} -Wall -c decompose_mesh_SCOTCH.f90
+
+program_decompose_mesh_SCOTCH.o: program_decompose_mesh_SCOTCH.f90
+ ${F90} -Wall -c program_decompose_mesh_SCOTCH.f90
+
+clean:
+ rm -f *.o *.mod a.out xdecompose_mesh_SCOTCH
Added: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/README
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/README (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/README 2009-10-22 21:01:47 UTC (rev 15867)
@@ -0,0 +1,41 @@
+----------------------------------------------------------------------
+README
+----------------------------------------------------------------------
+
+
+decompose mesh files:
+
+
+****
+you will need SCOTCH libraries to be installed on your system
+(http://gforge.inria.fr/projects/scotch/)
+
+to compile this executable xdecompose_mesh_SCOTCH for partitioning your mesh files
+****
+
+ 1. create mesh using CUBIT and scripts boundary_definity.py and
+ cubit2specfem3D.py to generate all mesh files
+
+ 2. compile executable "xdecompose_mesh_SCOTCH" in this directory decompose_mesh_SCOTCH/:
+
+ make sure, you have the right location of your SCOTCH library defined
+ in the Makefile (SCOTCH_LIBS), then type:
+
+ > make
+
+ 3. create Database files for the number of partitions/processes you want SPECFEM
+ to run on. These Database files will be needed later for the "xgenerate_databases" executable:
+
+ > ./xdecompose_mesh_SCOTCH n input_dir output_dir
+
+ where
+ - n is the number of partitions (i.e. parallel processes),
+ - input_dir is the directory containing the mesh files (i.e. "nodes_coord_file","mesh_file",...)
+ - output_dir is the directory to hold the new "proc****_Database" files
+
+ for example, a call could look like:
+
+ > ./xdecompose_mesh_SCOTCH 4 ../EXAMPLES/homogeneous_halfspace/MESH/ ../DATABASES_MPI/
+
+
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/compile_all.csh
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/compile_all.csh 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/compile_all.csh 2009-10-22 21:01:47 UTC (rev 15867)
@@ -3,13 +3,22 @@
#. /opt/intel/fce/10.0.026/bin/ifortvars.sh
# export FCFLAGS="-g -traceback -implicitnone -warn stderrors -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -assume byterecl -C"
-rm *.o *.mod ./a.out
+rm -f *.o *.mod ./a.out ./xdecompose_mesh_SCOTCH
+
gfortran -Wall -c part_decompose_mesh_SCOTCH.f90
+
#gfortran -c decompose_mesh_SCOTCH.f90
gfortran -Wall -c decompose_mesh_SCOTCH.f90
+
+gfortran -Wall -c program_decompose_mesh_SCOTCH.f90
+
#gfortran decompose_mesh_SCOTCH.o part_decompose_mesh_SCOTCH.o ~/utils/metis-4.0/libmetis.a
#gfortran decompose_mesh_SCOTCH.o part_decompose_mesh_SCOTCH.o ~/utils/scotch_5.1/lib/libscotchmetis.a ~/utils/scotch_5.1/lib/libscotch.a ~/utils/scotch_5.1/lib/libscotcherr.a
#gfortran decompose_mesh_SCOTCH.o part_decompose_mesh_SCOTCH.o ~/utils/scotch_5.1/lib/libscotch.a ~/utils/scotch_5.1/lib/libscotcherr.a
-gfortran -Wall decompose_mesh_SCOTCH.o part_decompose_mesh_SCOTCH.o /scratch/network/SCOTCH/lib/libscotch.a /scratch/network/SCOTCH/lib/libscotcherr.a
-
+gfortran -Wall -o xdecompose_mesh_SCOTCH \
+ decompose_mesh_SCOTCH.o \
+ part_decompose_mesh_SCOTCH.o \
+ program_decompose_mesh_SCOTCH.o \
+ /scratch/network/SCOTCH/lib/libscotch.a \
+ /scratch/network/SCOTCH/lib/libscotcherr.a
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -1,11 +1,18 @@
-program pre_meshfem3D
+!program pre_meshfem3D
+module decompose_mesh_SCOTCH
+
use part_decompose_mesh_SCOTCH
+
implicit none
- include './constants_decompose_mesh_SCOTCH.h'
include './scotchf.h'
+! number of partitions
+! integer, parameter :: nparts = 4
+ integer :: nparts != 4
+
+! mesh arrays
integer(long) :: nspec
integer, dimension(:,:), allocatable :: elmnts
integer, dimension(:,:), allocatable :: mat
@@ -64,360 +71,459 @@
integer :: count_def_mat,count_undef_mat,imat
character (len=30), dimension(:,:), allocatable :: undef_mat_prop
+! default mesh file directory
+ character(len=256) :: localpath_name ! './OUTPUT_FILES'
+ character(len=256) :: outputpath_name ! './OUTPUT_FILES'
-! sets number of nodes per element
- ngnod = esize
+ contains
+
+ !----------------------------------------------------------------------------------------------
+ ! reads in mesh files
+ !----------------------------------------------------------------------------------------------
+ subroutine read_mesh_files
-! reads node coordinates
- open(unit=98, file='./OUTPUT_FILES/nodes_coords_file', status='old', form='formatted')
- read(98,*) nnodes
- allocate(nodes_coords(3,nnodes))
- do inode = 1, nnodes
+ ! sets number of nodes per element
+ ngnod = esize
+
+ ! reads node coordinates
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/nodes_coords_file',&
+ status='old', form='formatted', iostat = ierr)
+ if( ierr /= 0 ) then
+ print*,'could not open file:',localpath_name(1:len_trim(localpath_name))//'/nodes_coords_file'
+ stop 'error file open'
+ endif
+ read(98,*) nnodes
+ allocate(nodes_coords(3,nnodes))
+ do inode = 1, nnodes
! format: #id_node #x_coordinate #y_coordinate #z_coordinate
- read(98,*) num_node, nodes_coords(1,num_node), nodes_coords(2,num_node), nodes_coords(3,num_node)
+ read(98,*) num_node, nodes_coords(1,num_node), nodes_coords(2,num_node), nodes_coords(3,num_node)
!if(num_node /= inode) stop "ERROR : Invalid nodes_coords file."
- end do
- close(98)
- print*, 'total number of nodes: '
- print*, ' nnodes = ', nnodes
+ end do
+ close(98)
+ print*, 'total number of nodes: '
+ print*, ' nnodes = ', nnodes
-! reads mesh elements indexing
-!(CUBIT calls this the connectivity, guess in the sense that it connects with the points index in
-! the global coordinate file "nodes_coords_file"; it doesn't tell you which point is connected with others)
- open(unit=98, file='./OUTPUT_FILES/mesh_file', status='old', form='formatted')
- read(98,*) nspec
- allocate(elmnts(esize,nspec))
- do ispec = 1, nspec
- ! format: # element_id #id_node1 ... #id_node8
+ ! reads mesh elements indexing
+ !(CUBIT calls this the connectivity, guess in the sense that it connects with the points index in
+ ! the global coordinate file "nodes_coords_file"; it doesn't tell you which point is connected with others)
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/mesh_file', &
+ status='old', form='formatted')
+ read(98,*) nspec
+ allocate(elmnts(esize,nspec))
+ do ispec = 1, nspec
+ ! format: # element_id #id_node1 ... #id_node8
- ! note: be aware that here we can have different node ordering for a cube element;
- ! the ordering from Cubit files might not be consistent for multiple volumes, or uneven, unstructured grids
- !
- ! guess here it assumes that spectral elements ordering is like first at the bottom of the element, anticlock-wise, i.e.
- ! point 1 = (0,0,0), point 2 = (0,1,0), point 3 = (1,1,0), point 4 = (1,0,0)
- ! then top (positive z-direction) of element
- ! point 5 = (0,0,1), point 6 = (0,1,1), point 7 = (1,1,1), point 8 = (1,0,1)
- read(98,*) num_elmnt, elmnts(5,num_elmnt), elmnts(1,num_elmnt),elmnts(4,num_elmnt), elmnts(8,num_elmnt), &
- elmnts(6,num_elmnt), elmnts(2,num_elmnt), elmnts(3,num_elmnt), elmnts(7,num_elmnt)
+ ! note: be aware that here we can have different node ordering for a cube element;
+ ! the ordering from Cubit files might not be consistent for multiple volumes, or uneven, unstructured grids
+ !
+ ! guess here it assumes that spectral elements ordering is like first at the bottom of the element, anticlock-wise, i.e.
+ ! point 1 = (0,0,0), point 2 = (0,1,0), point 3 = (1,1,0), point 4 = (1,0,0)
+ ! then top (positive z-direction) of element
+ ! point 5 = (0,0,1), point 6 = (0,1,1), point 7 = (1,1,1), point 8 = (1,0,1)
+ read(98,*) num_elmnt, elmnts(5,num_elmnt), elmnts(1,num_elmnt),elmnts(4,num_elmnt), elmnts(8,num_elmnt), &
+ elmnts(6,num_elmnt), elmnts(2,num_elmnt), elmnts(3,num_elmnt), elmnts(7,num_elmnt)
- ! read(98,*) num_elmnt, elmnts(1,num_elmnt), elmnts(2,num_elmnt),elmnts(3,num_elmnt), elmnts(4,num_elmnt), &
- ! elmnts(5,num_elmnt), elmnts(6,num_elmnt), elmnts(7,num_elmnt), elmnts(8,num_elmnt)
+ ! read(98,*) num_elmnt, elmnts(1,num_elmnt), elmnts(2,num_elmnt),elmnts(3,num_elmnt), elmnts(4,num_elmnt), &
+ ! elmnts(5,num_elmnt), elmnts(6,num_elmnt), elmnts(7,num_elmnt), elmnts(8,num_elmnt)
- if((num_elmnt > nspec) .or. (num_elmnt < 1) ) stop "ERROR : Invalid mesh file."
+ if((num_elmnt > nspec) .or. (num_elmnt < 1) ) stop "ERROR : Invalid mesh file."
-
- !outputs info for each element to see ordering
- !print*,'ispec: ',ispec
- !print*,' ',num_elmnt, elmnts(5,num_elmnt), elmnts(1,num_elmnt),elmnts(4,num_elmnt), elmnts(8,num_elmnt), &
- ! elmnts(6,num_elmnt), elmnts(2,num_elmnt), elmnts(3,num_elmnt), elmnts(7,num_elmnt)
- !print*,'elem:',num_elmnt
- !do i=1,8
- ! print*,' i ',i,'val :',elmnts(i,num_elmnt),&
- ! nodes_coords(1,elmnts(i,num_elmnt)),nodes_coords(2,elmnts(i,num_elmnt)),nodes_coords(3,elmnts(i,num_elmnt))
- !enddo
- !print*
- end do
- close(98)
- print*, 'total number of spectral elements:'
- print*, ' nspec = ', nspec
+ !outputs info for each element to see ordering
+ !print*,'ispec: ',ispec
+ !print*,' ',num_elmnt, elmnts(5,num_elmnt), elmnts(1,num_elmnt),elmnts(4,num_elmnt), elmnts(8,num_elmnt), &
+ ! elmnts(6,num_elmnt), elmnts(2,num_elmnt), elmnts(3,num_elmnt), elmnts(7,num_elmnt)
+ !print*,'elem:',num_elmnt
+ !do i=1,8
+ ! print*,' i ',i,'val :',elmnts(i,num_elmnt),&
+ ! nodes_coords(1,elmnts(i,num_elmnt)),nodes_coords(2,elmnts(i,num_elmnt)),nodes_coords(3,elmnts(i,num_elmnt))
+ !enddo
+ !print*
+
+ end do
+ close(98)
+ print*, 'total number of spectral elements:'
+ print*, ' nspec = ', nspec
-! reads material associations
- open(unit=98, file='./OUTPUT_FILES/materials_file', status='old', form='formatted')
- allocate(mat(2,nspec))
- do ispec = 1, nspec
- ! format: # id_element #flag
- ! note: be aware that elements may not be sorted in materials_file
- read(98,*) num_mat,mat(1,num_mat) !mat(1,ispec)!, mat(2,ispec)
- if((num_mat > nspec) .or. (num_mat < 1) ) stop "ERROR : Invalid mat file."
- end do
- close(98)
+ ! reads material associations
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/materials_file', &
+ status='old', form='formatted')
+ allocate(mat(2,nspec))
+ do ispec = 1, nspec
+ ! format: # id_element #flag
+ ! note: be aware that elements may not be sorted in materials_file
+ read(98,*) num_mat,mat(1,num_mat) !mat(1,ispec)!, mat(2,ispec)
+ if((num_mat > nspec) .or. (num_mat < 1) ) stop "ERROR : Invalid mat file."
+ end do
+ close(98)
-! TODO:
-! must be changed, if mat(1,i) < 0 1 == interface , 2 == tomography
- mat(2,:) = 1
-
-! reads material definitions
- count_def_mat = 0
- count_undef_mat = 0
- open(unit=98, file='./OUTPUT_FILES/nummaterial_velocity_file', status='old', form='formatted')
- read(98,*,iostat=ierr) num_mat
- print *,'materials:'
- ! counts materials (defined/undefined)
- do while (ierr == 0)
- print*, ' num_mat = ',num_mat
- if(num_mat /= -1) then
- count_def_mat = count_def_mat + 1
- else
- count_undef_mat = count_undef_mat + 1
- end if
- read(98,*,iostat=ierr) num_mat
- end do
- close(98)
- print*, ' defined = ',count_def_mat, 'undefined = ',count_undef_mat
- ! check with material flags
- if( count_def_mat > 0 .and. maxval(mat(1,:)) > count_def_mat ) then
- print*,'error material definitions:'
- print*,' materials associated in materials_file:',maxval(mat(1,:))
- print*,' bigger than defined materials in nummaterial_velocity_file:',count_def_mat
- stop 'error materials'
- endif
- allocate(mat_prop(5,count_def_mat))
- allocate(undef_mat_prop(5,count_undef_mat))
- ! reads in defined material properties
- open(unit=98, file='./OUTPUT_FILES/nummaterial_velocity_file', status='old', form='formatted')
- do imat=1,count_def_mat
- ! format:# material_id # rho # vp # vs # Q_flag # 0
- read(98,*) num_mat, mat_prop(1,num_mat),mat_prop(2,num_mat),mat_prop(3,num_mat),mat_prop(4,num_mat),mat_prop(5,num_mat)
- if(num_mat < 0 .or. num_mat > count_def_mat) stop "ERROR : Invalid nummaterial_velocity_file file."
+ ! TODO:
+ ! must be changed, if mat(1,i) < 0 1 == interface , 2 == tomography
+ mat(2,:) = 1
+
+ ! reads material definitions
+ count_def_mat = 0
+ count_undef_mat = 0
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/nummaterial_velocity_file',&
+ status='old', form='formatted')
+ read(98,*,iostat=ierr) num_mat
+ print *,'materials:'
+ ! counts materials (defined/undefined)
+ do while (ierr == 0)
+ print*, ' num_mat = ',num_mat
+ if(num_mat /= -1) then
+ count_def_mat = count_def_mat + 1
+ else
+ count_undef_mat = count_undef_mat + 1
+ end if
+ read(98,*,iostat=ierr) num_mat
+ end do
+ close(98)
+ print*, ' defined = ',count_def_mat, 'undefined = ',count_undef_mat
+ ! check with material flags
+ if( count_def_mat > 0 .and. maxval(mat(1,:)) > count_def_mat ) then
+ print*,'error material definitions:'
+ print*,' materials associated in materials_file:',maxval(mat(1,:))
+ print*,' bigger than defined materials in nummaterial_velocity_file:',count_def_mat
+ stop 'error materials'
+ endif
+ allocate(mat_prop(5,count_def_mat))
+ allocate(undef_mat_prop(5,count_undef_mat))
+ ! reads in defined material properties
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/nummaterial_velocity_file', &
+ status='old', form='formatted')
+ do imat=1,count_def_mat
+ ! format:#(0) material_id #(1) rho #(2) vp #(3) vs #(4) Q_flag #(5) 0
+ read(98,*) num_mat, mat_prop(1,num_mat),mat_prop(2,num_mat),&
+ mat_prop(3,num_mat),mat_prop(4,num_mat),mat_prop(5,num_mat)
+ if(num_mat < 0 .or. num_mat > count_def_mat) stop "ERROR : Invalid nummaterial_velocity_file file."
- !checks attenuation flag with integer range as defined in constants.h like IATTENUATION_SEDIMENTS_40, ....
- if( int(mat_prop(4,num_mat)) > 13 ) then
- stop 'wrong attenuation flag in mesh: too large, not supported yet - check with constants.h'
- endif
- end do
- ! reads in undefined material properties
- do imat=1,count_undef_mat
- read(98,'(5A30)') 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)
- end do
- close(98)
+ !checks attenuation flag with integer range as defined in constants.h like IATTENUATION_SEDIMENTS_40, ....
+ if( int(mat_prop(4,num_mat)) > 13 ) then
+ stop 'wrong attenuation flag in mesh: too large, not supported yet - check with constants.h'
+ endif
+ end do
+ ! reads in undefined material properties
+ do imat=1,count_undef_mat
+ read(98,'(5A30)') 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)
+ end do
+ close(98)
-! reads in absorbing boundary files
- open(unit=98, file='./OUTPUT_FILES/absorbing_surface_file_xmin', status='old', form='formatted')
- read(98,*) nspec2D_xmin
- allocate(ibelm_xmin(nspec2D_xmin))
- allocate(nodes_ibelm_xmin(4,nspec2D_xmin))
- do ispec2D = 1,nspec2D_xmin
- ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
- ! note: ordering for CUBIT seems such that the normal of the face points outward of the element the face belongs to;
- ! in other words, nodes are in increasing order such that when looking from within the element outwards,
- ! they are ordered clockwise
- !
- ! doesn't necessarily have to start on top-rear, then bottom-rear, bottom-front, and finally top-front i.e.:
- ! point 1 = (0,1,1), point 2 = (0,1,0), point 3 = (0,0,0), point 4 = (0,0,1)
- read(98,*) ibelm_xmin(ispec2D), nodes_ibelm_xmin(1,ispec2D), nodes_ibelm_xmin(2,ispec2D), &
- nodes_ibelm_xmin(3,ispec2D), nodes_ibelm_xmin(4,ispec2D)
+ ! reads in absorbing boundary files
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/absorbing_surface_file_xmin', &
+ status='old', form='formatted',iostat=ierr)
+ if( ierr /= 0 ) then
+ nspec2D_xmin = 0
+ else
+ read(98,*) nspec2D_xmin
+ endif
+ allocate(ibelm_xmin(nspec2D_xmin))
+ allocate(nodes_ibelm_xmin(4,nspec2D_xmin))
+ do ispec2D = 1,nspec2D_xmin
+ ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
+ ! note: ordering for CUBIT seems such that the normal of the face points outward of the element the face belongs to;
+ ! in other words, nodes are in increasing order such that when looking from within the element outwards,
+ ! they are ordered clockwise
+ !
+ ! doesn't necessarily have to start on top-rear, then bottom-rear, bottom-front, and finally top-front i.e.:
+ ! point 1 = (0,1,1), point 2 = (0,1,0), point 3 = (0,0,0), point 4 = (0,0,1)
+ read(98,*) ibelm_xmin(ispec2D), nodes_ibelm_xmin(1,ispec2D), nodes_ibelm_xmin(2,ispec2D), &
+ nodes_ibelm_xmin(3,ispec2D), nodes_ibelm_xmin(4,ispec2D)
- !outputs info for each element for check of ordering
- !print*,'ispec2d:',ispec2d
- !print*,' xmin:', ibelm_xmin(ispec2D), nodes_ibelm_xmin(1,ispec2D), nodes_ibelm_xmin(2,ispec2D), &
- ! nodes_ibelm_xmin(3,ispec2D), nodes_ibelm_xmin(4,ispec2D)
- !do i=1,4
- ! print*,'i',i,'val:',ibelm_xmin(ispec2d),nodes_coords(1,nodes_ibelm_xmin(i,ispec2D)), &
- ! nodes_coords(2,nodes_ibelm_xmin(i,ispec2D)),nodes_coords(3,nodes_ibelm_xmin(i,ispec2D))
- !enddo
- !print*
- end do
- close(98)
- print*, 'absorbing boundaries:'
- print*, ' nspec2D_xmin = ', nspec2D_xmin
+ !outputs info for each element for check of ordering
+ !print*,'ispec2d:',ispec2d
+ !print*,' xmin:', ibelm_xmin(ispec2D), nodes_ibelm_xmin(1,ispec2D), nodes_ibelm_xmin(2,ispec2D), &
+ ! nodes_ibelm_xmin(3,ispec2D), nodes_ibelm_xmin(4,ispec2D)
+ !do i=1,4
+ ! print*,'i',i,'val:',ibelm_xmin(ispec2d),nodes_coords(1,nodes_ibelm_xmin(i,ispec2D)), &
+ ! nodes_coords(2,nodes_ibelm_xmin(i,ispec2D)),nodes_coords(3,nodes_ibelm_xmin(i,ispec2D))
+ !enddo
+ !print*
+ end do
+ close(98)
+ print*, 'absorbing boundaries:'
+ print*, ' nspec2D_xmin = ', nspec2D_xmin
-! reads in absorbing boundary files
- open(unit=98, file='./OUTPUT_FILES/absorbing_surface_file_xmax', status='old', form='formatted')
- read(98,*) nspec2D_xmax
- allocate(ibelm_xmax(nspec2D_xmax))
- allocate(nodes_ibelm_xmax(4,nspec2D_xmax))
- do ispec2D = 1,nspec2D_xmax
- ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
- read(98,*) ibelm_xmax(ispec2D), nodes_ibelm_xmax(1,ispec2D), nodes_ibelm_xmax(2,ispec2D), &
- nodes_ibelm_xmax(3,ispec2D), nodes_ibelm_xmax(4,ispec2D)
- end do
- close(98)
- print*, ' nspec2D_xmax = ', nspec2D_xmax
+ ! reads in absorbing boundary files
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/absorbing_surface_file_xmax', &
+ status='old', form='formatted',iostat=ierr)
+ if( ierr /= 0 ) then
+ nspec2D_xmax = 0
+ else
+ read(98,*) nspec2D_xmax
+ endif
+ allocate(ibelm_xmax(nspec2D_xmax))
+ allocate(nodes_ibelm_xmax(4,nspec2D_xmax))
+ do ispec2D = 1,nspec2D_xmax
+ ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
+ read(98,*) ibelm_xmax(ispec2D), nodes_ibelm_xmax(1,ispec2D), nodes_ibelm_xmax(2,ispec2D), &
+ nodes_ibelm_xmax(3,ispec2D), nodes_ibelm_xmax(4,ispec2D)
+ end do
+ close(98)
+ print*, ' nspec2D_xmax = ', nspec2D_xmax
-! reads in absorbing boundary files
- open(unit=98, file='./OUTPUT_FILES/absorbing_surface_file_ymin', status='old', form='formatted')
- read(98,*) nspec2D_ymin
- allocate(ibelm_ymin(nspec2D_ymin))
- allocate(nodes_ibelm_ymin(4,nspec2D_ymin))
- do ispec2D = 1,nspec2D_ymin
- ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
- read(98,*) ibelm_ymin(ispec2D), nodes_ibelm_ymin(1,ispec2D), nodes_ibelm_ymin(2,ispec2D), &
- nodes_ibelm_ymin(3,ispec2D), nodes_ibelm_ymin(4,ispec2D)
- end do
- close(98)
- print*, ' nspec2D_ymin = ', nspec2D_ymin
+ ! reads in absorbing boundary files
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/absorbing_surface_file_ymin', &
+ status='old', form='formatted',iostat=ierr)
+ if( ierr /= 0 ) then
+ nspec2D_ymin = 0
+ else
+ read(98,*) nspec2D_ymin
+ endif
+ allocate(ibelm_ymin(nspec2D_ymin))
+ allocate(nodes_ibelm_ymin(4,nspec2D_ymin))
+ do ispec2D = 1,nspec2D_ymin
+ ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
+ read(98,*) ibelm_ymin(ispec2D), nodes_ibelm_ymin(1,ispec2D), nodes_ibelm_ymin(2,ispec2D), &
+ nodes_ibelm_ymin(3,ispec2D), nodes_ibelm_ymin(4,ispec2D)
+ end do
+ close(98)
+ print*, ' nspec2D_ymin = ', nspec2D_ymin
-! reads in absorbing boundary files
- open(unit=98, file='./OUTPUT_FILES/absorbing_surface_file_ymax', status='old', form='formatted')
- read(98,*) nspec2D_ymax
- allocate(ibelm_ymax(nspec2D_ymax))
- allocate(nodes_ibelm_ymax(4,nspec2D_ymax))
- do ispec2D = 1,nspec2D_ymax
- ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
- read(98,*) ibelm_ymax(ispec2D), nodes_ibelm_ymax(1,ispec2D), nodes_ibelm_ymax(2,ispec2D), &
- nodes_ibelm_ymax(3,ispec2D), nodes_ibelm_ymax(4,ispec2D)
- end do
- close(98)
- print*, ' nspec2D_ymax = ', nspec2D_ymax
+ ! reads in absorbing boundary files
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/absorbing_surface_file_ymax', &
+ status='old', form='formatted',iostat=ierr)
+ if( ierr /= 0 ) then
+ nspec2D_ymax = 0
+ else
+ read(98,*) nspec2D_ymax
+ endif
+ allocate(ibelm_ymax(nspec2D_ymax))
+ allocate(nodes_ibelm_ymax(4,nspec2D_ymax))
+ do ispec2D = 1,nspec2D_ymax
+ ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
+ read(98,*) ibelm_ymax(ispec2D), nodes_ibelm_ymax(1,ispec2D), nodes_ibelm_ymax(2,ispec2D), &
+ nodes_ibelm_ymax(3,ispec2D), nodes_ibelm_ymax(4,ispec2D)
+ end do
+ close(98)
+ print*, ' nspec2D_ymax = ', nspec2D_ymax
-! reads in absorbing boundary files
- open(unit=98, file='./OUTPUT_FILES/absorbing_surface_file_bottom', status='old', form='formatted')
- read(98,*) nspec2D_bottom
- allocate(ibelm_bottom(nspec2D_bottom))
- allocate(nodes_ibelm_bottom(4,nspec2D_bottom))
- do ispec2D = 1,nspec2D_bottom
- ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
- read(98,*) ibelm_bottom(ispec2D), nodes_ibelm_bottom(1,ispec2D), nodes_ibelm_bottom(2,ispec2D), &
- nodes_ibelm_bottom(3,ispec2D), nodes_ibelm_bottom(4,ispec2D)
- end do
- close(98)
- print*, ' nspec2D_bottom = ', nspec2D_bottom
+ ! reads in absorbing boundary files
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/absorbing_surface_file_bottom', &
+ status='old', form='formatted',iostat=ierr)
+ if( ierr /= 0 ) then
+ nspec2D_bottom = 0
+ else
+ read(98,*) nspec2D_bottom
+ endif
+ allocate(ibelm_bottom(nspec2D_bottom))
+ allocate(nodes_ibelm_bottom(4,nspec2D_bottom))
+ do ispec2D = 1,nspec2D_bottom
+ ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
+ read(98,*) ibelm_bottom(ispec2D), nodes_ibelm_bottom(1,ispec2D), nodes_ibelm_bottom(2,ispec2D), &
+ nodes_ibelm_bottom(3,ispec2D), nodes_ibelm_bottom(4,ispec2D)
+ end do
+ close(98)
+ print*, ' nspec2D_bottom = ', nspec2D_bottom
-! reads in free_surface boundary files
- open(unit=98, file='./OUTPUT_FILES/free_surface_file', status='old', form='formatted')
- read(98,*) nspec2D_top
- allocate(ibelm_top(nspec2D_top))
- allocate(nodes_ibelm_top(4,nspec2D_top))
- do ispec2D = 1,nspec2D_top
- ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
- read(98,*) ibelm_top(ispec2D), nodes_ibelm_top(1,ispec2D), nodes_ibelm_top(2,ispec2D), &
- nodes_ibelm_top(3,ispec2D), nodes_ibelm_top(4,ispec2D)
- end do
- close(98)
- print*, ' nspec2D_top = ', nspec2D_top
+ ! reads in free_surface boundary files
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/free_surface_file', &
+ status='old', form='formatted',iostat=ierr)
+ if( ierr /= 0 ) then
+ nspec2D_top = 0
+ else
+ read(98,*) nspec2D_top
+ endif
+ allocate(ibelm_top(nspec2D_top))
+ allocate(nodes_ibelm_top(4,nspec2D_top))
+ do ispec2D = 1,nspec2D_top
+ ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
+ read(98,*) ibelm_top(ispec2D), nodes_ibelm_top(1,ispec2D), nodes_ibelm_top(2,ispec2D), &
+ nodes_ibelm_top(3,ispec2D), nodes_ibelm_top(4,ispec2D)
+ end do
+ close(98)
+ print*, ' nspec2D_top = ', nspec2D_top
-! checks valence of nodes
- allocate(mask_nodes_elmnts(nnodes))
- allocate(used_nodes_elmnts(nnodes))
- mask_nodes_elmnts(:) = .false.
- used_nodes_elmnts(:) = 0
- do ispec = 1, nspec
- do inode = 1, ESIZE
- mask_nodes_elmnts(elmnts(inode,ispec)) = .true.
- used_nodes_elmnts(elmnts(inode,ispec)) = used_nodes_elmnts(elmnts(inode,ispec)) + 1
+ end subroutine read_mesh_files
+
+ !----------------------------------------------------------------------------------------------
+ ! checks valence of nodes
+ !----------------------------------------------------------------------------------------------
+
+ subroutine check_valence
+
+ allocate(mask_nodes_elmnts(nnodes))
+ allocate(used_nodes_elmnts(nnodes))
+ mask_nodes_elmnts(:) = .false.
+ used_nodes_elmnts(:) = 0
+ do ispec = 1, nspec
+ do inode = 1, ESIZE
+ mask_nodes_elmnts(elmnts(inode,ispec)) = .true.
+ used_nodes_elmnts(elmnts(inode,ispec)) = used_nodes_elmnts(elmnts(inode,ispec)) + 1
+ enddo
enddo
- enddo
- print *, 'nodes valence: '
- print *, ' min = ',minval(used_nodes_elmnts(:)),'max = ', maxval(used_nodes_elmnts(:))
- do inode = 1, nnodes
- if (.not. mask_nodes_elmnts(inode)) then
- stop 'ERROR : nodes not used.'
- endif
- enddo
- nsize = maxval(used_nodes_elmnts(:))
- sup_neighbour = ngnod * nsize - (ngnod + (ngnod/2 - 1)*nfaces)
- print*, ' nsize = ',nsize, 'sup_neighbour = ', sup_neighbour
+ print *, 'nodes valence: '
+ print *, ' min = ',minval(used_nodes_elmnts(:)),'max = ', maxval(used_nodes_elmnts(:))
+ do inode = 1, nnodes
+ if (.not. mask_nodes_elmnts(inode)) then
+ stop 'ERROR : nodes not used.'
+ endif
+ enddo
+ nsize = maxval(used_nodes_elmnts(:))
+ sup_neighbour = ngnod * nsize - (ngnod + (ngnod/2 - 1)*nfaces)
+ print*, ' nsize = ',nsize, 'sup_neighbour = ', sup_neighbour
- elmnts(:,:) = elmnts(:,:) - 1
+ end subroutine check_valence
- allocate(xadj(1:nspec+1))
- allocate(adjncy(1:sup_neighbour*nspec))
- allocate(nnodes_elmnts(1:nnodes))
- allocate(nodes_elmnts(1:nsize*nnodes))
+ !----------------------------------------------------------------------------------------------
+ ! divides model into partitions using scotch library functions
+ !----------------------------------------------------------------------------------------------
- call mesh2dual_ncommonnodes(nspec, nnodes, nsize, sup_neighbour, elmnts, xadj, adjncy, nnodes_elmnts, &
- nodes_elmnts, max_neighbour, 1)
- print*, 'mesh2dual: '
- print*, ' max_neighbour = ',max_neighbour
+ subroutine scotch_partitioning
+
+ elmnts(:,:) = elmnts(:,:) - 1
- nb_edges = xadj(nspec+1)
+ allocate(xadj(1:nspec+1))
+ allocate(adjncy(1:sup_neighbour*nspec))
+ allocate(nnodes_elmnts(1:nnodes))
+ allocate(nodes_elmnts(1:nsize*nnodes))
+
+ call mesh2dual_ncommonnodes(nspec, nnodes, nsize, sup_neighbour, elmnts, xadj, adjncy, nnodes_elmnts, &
+ nodes_elmnts, max_neighbour, 1)
+ print*, 'mesh2dual: '
+ print*, ' max_neighbour = ',max_neighbour
-! allocates & initializes partioning of elements
- allocate(part(1:nspec))
- part(:) = -1
+ nb_edges = xadj(nspec+1)
+ ! allocates & initializes partioning of elements
+ allocate(part(1:nspec))
+ part(:) = -1
-! SCOTCH partitioning
- call scotchfstratinit (scotchstrat(1), ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Cannot initialize strat'
- endif
- call scotchfstratgraphmap (scotchstrat(1), trim(scotch_strategy), ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Cannot build strat'
- endif
+ ! SCOTCH partitioning
+ call scotchfstratinit (scotchstrat(1), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot initialize strat'
+ endif
- call scotchfgraphinit (scotchgraph (1), ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Cannot initialize graph'
- endif
+ call scotchfstratgraphmap (scotchstrat(1), trim(scotch_strategy), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot build strat'
+ endif
- call scotchfgraphbuild (scotchgraph (1), 0, nspec, xadj (1), xadj (1), &
- xadj (1), xadj (1), nb_edges, adjncy (1), adjncy (1), ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Cannot build graph'
- endif
+ call scotchfgraphinit (scotchgraph (1), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot initialize graph'
+ endif
- call scotchfgraphcheck (scotchgraph (1), ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Invalid check'
- endif
+ call scotchfgraphbuild (scotchgraph (1), 0, nspec, xadj (1), xadj (1), &
+ xadj (1), xadj (1), nb_edges, adjncy (1), adjncy (1), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot build graph'
+ endif
- call scotchfgraphpart (scotchgraph (1), nparts, scotchstrat(1),part(1),ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Cannot part graph'
- endif
+ call scotchfgraphcheck (scotchgraph (1), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Invalid check'
+ endif
- call scotchfgraphexit (scotchgraph (1), ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Cannot destroy graph'
- endif
+ call scotchfgraphpart (scotchgraph (1), nparts, scotchstrat(1),part(1),ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot part graph'
+ endif
- call scotchfstratexit (scotchstrat(1), ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Cannot destroy strat'
- endif
-
-! local number of each element for each partition
- call Construct_glob2loc_elmnts(nspec, part, glob2loc_elmnts)
+ call scotchfgraphexit (scotchgraph (1), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot destroy graph'
+ endif
-! local number of each node for each partition
- call Construct_glob2loc_nodes(nspec, nnodes,nsize, nnodes_elmnts, nodes_elmnts, part, &
- glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes)
+ call scotchfstratexit (scotchstrat(1), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot destroy strat'
+ endif
+
+ ! local number of each element for each partition
+ call Construct_glob2loc_elmnts(nspec, part, glob2loc_elmnts,nparts)
- call Construct_interfaces(nspec, sup_neighbour, part, elmnts, xadj, adjncy, tab_interfaces, &
- tab_size_interfaces, ninterfaces, count_def_mat, mat_prop(3,:), mat(1,:))
+ ! local number of each node for each partition
+ call Construct_glob2loc_nodes(nspec, nnodes,nsize, nnodes_elmnts, nodes_elmnts, part, &
+ glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes, nparts)
- allocate(my_interfaces(0:ninterfaces-1))
- allocate(my_nb_interfaces(0:ninterfaces-1))
+ call Construct_interfaces(nspec, sup_neighbour, part, elmnts, xadj, adjncy, tab_interfaces, &
+ tab_size_interfaces, ninterfaces, &
+ count_def_mat, mat_prop(3,:), mat(1,:), nparts)
- do ipart = 0, nparts-1
+ end subroutine scotch_partitioning
+
+ !----------------------------------------------------------------------------------------------
+ ! writes out new Databases files for each partition
+ !----------------------------------------------------------------------------------------------
+
+ subroutine write_mesh_databases
- write(prname, "(i6.6,'_Database')") ipart
- open(unit=15,file='./OUTPUT_FILES/proc'//prname,status='unknown', action='write', form='formatted')
-
- call write_glob2loc_nodes_database(15, ipart, nnodes_loc, nodes_coords, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
- glob2loc_nodes, nnodes, 1)
- call write_partition_database(15, ipart, nspec_loc, nspec, elmnts, glob2loc_elmnts, glob2loc_nodes_nparts, &
- glob2loc_nodes_parts, glob2loc_nodes, part, mat, ngnod, 1)
+ allocate(my_interfaces(0:ninterfaces-1))
+ allocate(my_nb_interfaces(0:ninterfaces-1))
- write(15,*) nnodes_loc
- call write_glob2loc_nodes_database(15, ipart, nnodes_loc, nodes_coords, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
- glob2loc_nodes, nnodes, 2)
+ do ipart = 0, nparts-1
- call write_material_properties_database(15,count_def_mat,count_undef_mat, mat_prop, undef_mat_prop)
+ write(prname, "(i6.6,'_Database')") ipart
+ open(unit=15,file=outputpath_name(1:len_trim(outputpath_name))//'/proc'//prname,&
+ status='unknown', action='write', form='formatted', iostat = ierr)
+ if( ierr /= 0 ) then
+ print*,'error file open:',outputpath_name(1:len_trim(outputpath_name))//'/proc'//prname
+ print*
+ print*,'check if path exists:',outputpath_name(1:len_trim(outputpath_name))
+ stop 'error file open Database'
+ endif
+
+ call write_glob2loc_nodes_database(15, ipart, nnodes_loc, nodes_coords, &
+ glob2loc_nodes_nparts, glob2loc_nodes_parts, &
+ glob2loc_nodes, nnodes, 1)
+ call write_partition_database(15, ipart, nspec_loc, nspec, elmnts, &
+ glob2loc_elmnts, glob2loc_nodes_nparts, &
+ glob2loc_nodes_parts, glob2loc_nodes, part, mat, ngnod, 1)
- write(15,*) nspec_loc
- call write_partition_database(15, ipart, nspec_loc, nspec, elmnts, glob2loc_elmnts, glob2loc_nodes_nparts, &
- glob2loc_nodes_parts, glob2loc_nodes, part, mat, ngnod, 2)
+ write(15,*) nnodes_loc
+
+ call write_glob2loc_nodes_database(15, ipart, nnodes_loc, nodes_coords,&
+ glob2loc_nodes_nparts, glob2loc_nodes_parts, &
+ glob2loc_nodes, nnodes, 2)
- call write_boundaries_database(15, ipart, nspec, nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, &
- nspec2D_ymax, nspec2D_bottom, nspec2D_top, 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, &
- glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes, part)
+ call write_material_properties_database(15,count_def_mat,count_undef_mat, &
+ mat_prop, undef_mat_prop)
- call Write_interfaces_database(15, tab_interfaces, tab_size_interfaces, ipart, ninterfaces, &
- my_ninterface, my_interfaces, my_nb_interfaces, glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
- glob2loc_nodes, 1)
- write(15,*) my_ninterface, maxval(my_nb_interfaces)
- call Write_interfaces_database(15, tab_interfaces, tab_size_interfaces, ipart, ninterfaces, &
- my_ninterface, my_interfaces, my_nb_interfaces, glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
- glob2loc_nodes, 2)
-
-
- close(15)
-
- end do
- print*, 'partitions: '
- print*, ' num = ',nparts
- print*
- print*, 'files in directory: OUTPUT_FILES/'
- print*, 'finished successfully'
- print*
+ write(15,*) nspec_loc
+
+ call write_partition_database(15, ipart, nspec_loc, nspec, elmnts, &
+ glob2loc_elmnts, glob2loc_nodes_nparts, &
+ glob2loc_nodes_parts, glob2loc_nodes, part, mat, ngnod, 2)
+
+ call write_boundaries_database(15, ipart, nspec, nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, &
+ nspec2D_ymax, nspec2D_bottom, nspec2D_top, &
+ 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, &
+ glob2loc_elmnts, glob2loc_nodes_nparts, &
+ glob2loc_nodes_parts, glob2loc_nodes, part)
+
+ call Write_interfaces_database(15, tab_interfaces, tab_size_interfaces, ipart, ninterfaces, &
+ my_ninterface, my_interfaces, my_nb_interfaces, &
+ glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
+ glob2loc_nodes, 1, nparts)
+
+ write(15,*) my_ninterface, maxval(my_nb_interfaces)
+
+ call Write_interfaces_database(15, tab_interfaces, tab_size_interfaces, ipart, ninterfaces, &
+ my_ninterface, my_interfaces, my_nb_interfaces, &
+ glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
+ glob2loc_nodes, 2, nparts)
+
+ close(15)
+
+ end do
+ print*, 'partitions: '
+ print*, ' num = ',nparts
+ print*
+ print*, 'Databases files in directory: ',outputpath_name(1:len_trim(outputpath_name))
+ print*, 'finished successfully'
+ print*
+
+ end subroutine write_mesh_databases
-end program pre_meshfem3D
+!end program pre_meshfem3D
+end module decompose_mesh_SCOTCH
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -2,6 +2,20 @@
implicit none
+! Useful kind types
+ integer ,parameter :: short = SELECTED_INT_KIND(4), long = SELECTED_INT_KIND(18)
+
+! Number of nodes per elements.
+ integer, parameter :: ESIZE = 8
+
+! Number of faces per element.
+ integer, parameter :: nfaces = 6
+
+! very large and very small values
+ double precision, parameter :: HUGEVAL = 1.d+30,TINYVAL = 1.d-9
+
+! include './constants_decompose_mesh_SCOTCH.h'
+
contains
!-----------------------------------------------
@@ -10,7 +24,7 @@
subroutine mesh2dual_ncommonnodes(nelmnts, nnodes, nsize, sup_neighbour, elmnts, xadj, adjncy, &
nnodes_elmnts, nodes_elmnts, max_neighbour, ncommonnodes)
- include './constants_decompose_mesh_SCOTCH.h'
+! include './constants_decompose_mesh_SCOTCH.h'
integer(long), intent(in) :: nelmnts
integer, intent(in) :: nnodes
@@ -109,15 +123,15 @@
!--------------------------------------------------
! construct local numbering for the elements in each partition
!--------------------------------------------------
- subroutine Construct_glob2loc_elmnts(nelmnts, part, glob2loc_elmnts)
+ subroutine Construct_glob2loc_elmnts(nelmnts, part, glob2loc_elmnts,nparts)
- include './constants_decompose_mesh_SCOTCH.h'
+! include './constants_decompose_mesh_SCOTCH.h'
integer(long), intent(in) :: nelmnts
integer, dimension(0:nelmnts-1), intent(in) :: part
integer, dimension(:), pointer :: glob2loc_elmnts
-
- integer :: num_glob, num_part
+
+ integer :: num_glob, num_part, nparts
integer, dimension(0:nparts-1) :: num_loc
! allocates local numbering array
@@ -146,9 +160,9 @@
! construct local numbering for the nodes in each partition
!--------------------------------------------------
subroutine Construct_glob2loc_nodes(nelmnts, nnodes, nsize, nnodes_elmnts, nodes_elmnts, part, &
- glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes)
+ glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes,nparts)
- include './constants_decompose_mesh_SCOTCH.h'
+! include './constants_decompose_mesh_SCOTCH.h'
integer(long), intent(in) :: nelmnts, nsize
integer, intent(in) :: nnodes
@@ -162,7 +176,7 @@
integer :: num_node
integer :: el
integer :: num_part
- integer :: size_glob2loc_nodes
+ integer :: size_glob2loc_nodes,nparts
integer, dimension(0:nparts-1) :: parts_node
integer, dimension(0:nparts-1) :: num_parts
@@ -232,9 +246,10 @@
! Elements with undefined material are considered as elastic elements.
!--------------------------------------------------
subroutine Construct_interfaces(nelmnts, sup_neighbour, part, elmnts, xadj, adjncy, &
- tab_interfaces, tab_size_interfaces, ninterfaces, nb_materials, cs_material, num_material)
+ tab_interfaces, tab_size_interfaces, ninterfaces, &
+ nb_materials, cs_material, num_material,nparts)
- include './constants_decompose_mesh_SCOTCH.h'
+! include './constants_decompose_mesh_SCOTCH.h'
integer(long), intent(in) :: nelmnts, sup_neighbour
integer, dimension(0:nelmnts-1), intent(in) :: part
@@ -245,7 +260,7 @@
integer, intent(out) :: ninterfaces
integer, dimension(1:nelmnts), intent(in) :: num_material
double precision, dimension(1:nb_materials), intent(in) :: cs_material
- integer, intent(in) :: nb_materials
+ integer, intent(in) :: nb_materials,nparts
integer :: num_part, num_part_bis, el, el_adj, num_interface, num_edge, ncommon_nodes, &
@@ -441,7 +456,7 @@
nodes_ibelm_xmin, nodes_ibelm_xmax, nodes_ibelm_ymin, nodes_ibelm_ymax, nodes_ibelm_bottom, nodes_ibelm_top, &
glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes, part)
- include './constants_decompose_mesh_SCOTCH.h'
+! include './constants_decompose_mesh_SCOTCH.h'
integer, intent(in) :: IIN_database
integer, intent(in) :: iproc
@@ -684,10 +699,12 @@
!--------------------------------------------------
! Write elements (their nodes) pertaining to iproc partition in the corresponding Database
!--------------------------------------------------
- subroutine write_partition_database(IIN_database, iproc, nspec, nelmnts, elmnts, glob2loc_elmnts, glob2loc_nodes_nparts, &
- glob2loc_nodes_parts, glob2loc_nodes, part, num_modele, ngnod, num_phase)
+ subroutine write_partition_database(IIN_database, iproc, nspec, nelmnts, elmnts, &
+ glob2loc_elmnts, glob2loc_nodes_nparts, &
+ glob2loc_nodes_parts, glob2loc_nodes, &
+ part, num_modele, ngnod, num_phase)
- include './constants_decompose_mesh_SCOTCH.h'
+! include './constants_decompose_mesh_SCOTCH.h'
integer, intent(in) :: IIN_database
integer, intent(in) :: num_phase, iproc
@@ -744,13 +761,13 @@
!--------------------------------------------------
subroutine write_interfaces_database(IIN_database, tab_interfaces, tab_size_interfaces, iproc, ninterfaces, &
my_ninterface, my_interfaces, my_nb_interfaces, glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
- glob2loc_nodes, num_phase)
+ glob2loc_nodes, num_phase, nparts)
- include './constants_decompose_mesh_SCOTCH.h'
+! include './constants_decompose_mesh_SCOTCH.h'
integer, intent(in) :: IIN_database
integer, intent(in) :: iproc
- integer, intent(in) :: ninterfaces
+ integer, intent(in) :: ninterfaces, nparts
integer, intent(inout) :: my_ninterface
integer, dimension(:), pointer :: tab_size_interfaces
integer, dimension(:), pointer :: tab_interfaces
Added: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/program_decompose_mesh_SCOTCH.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/program_decompose_mesh_SCOTCH.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/program_decompose_mesh_SCOTCH.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -0,0 +1,46 @@
+program pre_meshfem3D
+
+ use decompose_mesh_SCOTCH,only: nparts,localpath_name, outputpath_name,&
+ read_mesh_files, &
+ check_valence, &
+ scotch_partitioning, &
+ write_mesh_databases
+ implicit none
+ integer :: i
+ character(len=256) :: arg(3)
+
+! include './constants_decompose_mesh_SCOTCH.h'
+
+! check usage
+ do i=1,3
+ call getarg(i,arg(i))
+ if (i <= 3 .and. trim(arg(i)) == "") then
+ print *, 'Usage: ./decompose_mesh_SCOTCH nparts input_directory output_directory'
+ print *
+ print *, ' where'
+ print *, ' nparts = number of partitons'
+ print *, ' input_directory = directory containing mesh files mesh_file,nodes_coords_file,..'
+ print *, ' output_directory = directory for output files proc***_Databases'
+ print *
+ stop ' Reenter command line options'
+ endif
+ enddo
+
+ read(arg(1),*) nparts
+ localpath_name = arg(2)
+ outputpath_name = arg(3)
+
+! reads in (CUBIT) mesh files: mesh_file,nodes_coord_file, ...
+ call read_mesh_files()
+
+! checks valence of nodes
+ call check_valence()
+
+! partitions mesh
+ call scotch_partitioning()
+
+! writes out database files
+ call write_mesh_databases()
+
+end program pre_meshfem3D
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -28,85 +28,102 @@
subroutine detect_mesh_surfaces()
use specfem_par
+ implicit none
! detecting surface points/elements (based on valence check on NGLL points) for external mesh
- allocate(valence_external_mesh(NGLOB_AB))
+
+
allocate(ispec_is_surface_external_mesh(NSPEC_AB))
allocate(iglob_is_surface_external_mesh(NGLOB_AB))
+! allocate(valence_external_mesh(NGLOB_AB))
if (.not. RECVS_CAN_BE_BURIED_EXT_MESH .or. EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) then
- valence_external_mesh(:) = 0
- ispec_is_surface_external_mesh(:) = .false.
- iglob_is_surface_external_mesh(:) = .false.
- do ispec = 1, NSPEC_AB
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool(i,j,k,ispec)
- valence_external_mesh(iglob) = valence_external_mesh(iglob) + 1
- enddo
- enddo
- enddo
- enddo
- allocate(buffer_send_scalar_i_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- allocate(buffer_recv_scalar_i_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
+ ! returns surace points/elements
+ call detect_surface(NPROC,NGLOB_AB,NSPEC_AB,ibool,&
+ ispec_is_surface_external_mesh, &
+ iglob_is_surface_external_mesh, &
+ nfaces_surface_external_mesh, &
+ num_interfaces_ext_mesh, &
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh)
- call assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,valence_external_mesh, &
- buffer_send_scalar_i_ext_mesh,buffer_recv_scalar_i_ext_mesh, &
- ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
- request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
-
- do ispec = 1, NSPEC_AB
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- if ( &
- (k == 1 .or. k == NGLLZ) .and. (j /= 1 .and. j /= NGLLY) .and. (i /= 1 .and. i /= NGLLX) .or. &
- (j == 1 .or. j == NGLLY) .and. (k /= 1 .and. k /= NGLLZ) .and. (i /= 1 .and. i /= NGLLX) .or. &
- (i == 1 .or. i == NGLLX) .and. (k /= 1 .and. k /= NGLLZ) .and. (j /= 1 .and. j /= NGLLY) &
- ) then
- iglob = ibool(i,j,k,ispec)
- if (valence_external_mesh(iglob) == 1) then
- ispec_is_surface_external_mesh(ispec) = .true.
-
- if (k == 1 .or. k == NGLLZ) then
- do jj = 1, NGLLY
- do ii = 1, NGLLX
- iglob_is_surface_external_mesh(ibool(ii,jj,k,ispec)) = .true.
- enddo
- enddo
- endif
- if (j == 1 .or. j == NGLLY) then
- do kk = 1, NGLLZ
- do ii = 1, NGLLX
- iglob_is_surface_external_mesh(ibool(ii,j,kk,ispec)) = .true.
- enddo
- enddo
- endif
- if (i == 1 .or. i == NGLLX) then
- do kk = 1, NGLLZ
- do jj = 1, NGLLY
- iglob_is_surface_external_mesh(ibool(i,jj,kk,ispec)) = .true.
- enddo
- enddo
- endif
- endif
-
- endif
- enddo
- enddo
- enddo
-
- enddo ! nspec
-
- ! handles movies and shakemaps
- if (EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) then
- call setup_movie_meshes()
- endif
+!
+! valence_external_mesh(:) = 0
+! ispec_is_surface_external_mesh(:) = .false.
+! iglob_is_surface_external_mesh(:) = .false.
+! do ispec = 1, NSPEC_AB
+! do k = 1, NGLLZ
+! do j = 1, NGLLY
+! do i = 1, NGLLX
+! iglob = ibool(i,j,k,ispec)
+! valence_external_mesh(iglob) = valence_external_mesh(iglob) + 1
+! enddo
+! enddo
+! enddo
+! enddo
+!
+! allocate(buffer_send_scalar_i_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+! allocate(buffer_recv_scalar_i_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+!
+! ! adds contributions from different partitions to valence_external_mesh
+! call assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,valence_external_mesh, &
+! buffer_send_scalar_i_ext_mesh,buffer_recv_scalar_i_ext_mesh, &
+! num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+! nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
+! request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+!
+! do ispec = 1, NSPEC_AB
+! do k = 1, NGLLZ
+! do j = 1, NGLLY
+! do i = 1, NGLLX
+! if ( &
+! (k == 1 .or. k == NGLLZ) .and. (j /= 1 .and. j /= NGLLY) .and. (i /= 1 .and. i /= NGLLX) .or. &
+! (j == 1 .or. j == NGLLY) .and. (k /= 1 .and. k /= NGLLZ) .and. (i /= 1 .and. i /= NGLLX) .or. &
+! (i == 1 .or. i == NGLLX) .and. (k /= 1 .and. k /= NGLLZ) .and. (j /= 1 .and. j /= NGLLY) &
+! ) then
+! iglob = ibool(i,j,k,ispec)
+! if (valence_external_mesh(iglob) == 1) then
+! ispec_is_surface_external_mesh(ispec) = .true.
+!
+! if (k == 1 .or. k == NGLLZ) then
+! do jj = 1, NGLLY
+! do ii = 1, NGLLX
+! iglob_is_surface_external_mesh(ibool(ii,jj,k,ispec)) = .true.
+! enddo
+! enddo
+! endif
+! if (j == 1 .or. j == NGLLY) then
+! do kk = 1, NGLLZ
+! do ii = 1, NGLLX
+! iglob_is_surface_external_mesh(ibool(ii,j,kk,ispec)) = .true.
+! enddo
+! enddo
+! endif
+! if (i == 1 .or. i == NGLLX) then
+! do kk = 1, NGLLZ
+! do jj = 1, NGLLY
+! iglob_is_surface_external_mesh(ibool(i,jj,kk,ispec)) = .true.
+! enddo
+! enddo
+! endif
+! endif
+!
+! endif
+! enddo
+! enddo
+! enddo
+!
+! enddo ! nspec
- endif ! .not. RECVS_CAN_BE_BURIED_EXT_MESH
+ endif
+
+ ! handles movies and shakemaps
+ if (EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) then
+ call setup_movie_meshes()
+ endif
!!!! NL NL REGOLITH : runs at cines for asteroid simulations. Elements in contact with surface are part of the regolith layer.
!!$ allocate(ispec_is_regolith(NSPEC_AB))
Added: seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -0,0 +1,187 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! 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 detect_surface(NPROC,nglob,nspec,ibool,&
+ ispec_is_surface_external_mesh, &
+ iglob_is_surface_external_mesh, &
+ nfaces_surface_external_mesh, &
+ num_interfaces_ext_mesh, &
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh)
+
+! detects surface (points/elements) of model based upon valence
+!
+! returns: ispec_is_surface_external_mesh, iglob_is_surface_external_mesh
+! and nfaces_surface_external_mesh
+
+ implicit none
+
+ include "constants.h"
+
+! global indexing
+ integer :: NPROC,nglob,nspec
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec):: ibool
+
+! surface
+ logical, dimension(nspec) :: ispec_is_surface_external_mesh
+ logical, dimension(nglob) :: iglob_is_surface_external_mesh
+ integer :: nfaces_surface_external_mesh
+
+! MPI partitions
+ integer :: num_interfaces_ext_mesh
+ integer :: max_nibool_interfaces_ext_mesh
+ integer,dimension(num_interfaces_ext_mesh):: nibool_interfaces_ext_mesh
+ integer,dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh):: ibool_interfaces_ext_mesh
+ integer,dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+
+!local parameters
+ integer, dimension(:), allocatable :: valence_external_mesh
+ integer, dimension(:,:), allocatable :: buffer_send_scalar_i_ext_mesh
+ integer, dimension(:,:), allocatable :: buffer_recv_scalar_i_ext_mesh
+ integer, dimension(:), allocatable :: request_send_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_recv_scalar_ext_mesh
+ integer :: ispec,i,j,k,ii,jj,kk,iglob,ier
+
+
+! detecting surface points/elements (based on valence check on NGLL points) for external mesh
+ allocate(valence_external_mesh(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocate valence array'
+
+! initialize surface indices
+ ispec_is_surface_external_mesh(:) = .false.
+ iglob_is_surface_external_mesh(:) = .false.
+ valence_external_mesh(:) = 0
+
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( iglob < 1 .or. iglob > nglob) then
+ print*,'error valence iglob:',iglob,i,j,k,ispec
+ stop 'error valence'
+ endif
+ valence_external_mesh(iglob) = valence_external_mesh(iglob) + 1
+ enddo
+ enddo
+ enddo
+ enddo
+
+ allocate(buffer_send_scalar_i_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_recv_scalar_i_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(request_send_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh))
+
+ ! adds contributions from different partitions to valence_external_mesh
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,valence_external_mesh, &
+ buffer_send_scalar_i_ext_mesh,buffer_recv_scalar_i_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
+ request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+
+ deallocate(buffer_send_scalar_i_ext_mesh)
+ deallocate(buffer_recv_scalar_i_ext_mesh)
+ deallocate(request_send_scalar_ext_mesh)
+ deallocate(request_recv_scalar_ext_mesh)
+
+ do ispec = 1, nspec
+
+ ! loops over GLL points not on edges or corners
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ if ( &
+ (k == 1 .or. k == NGLLZ) .and. (j /= 1 .and. j /= NGLLY) .and. (i /= 1 .and. i /= NGLLX) .or. &
+ (j == 1 .or. j == NGLLY) .and. (k /= 1 .and. k /= NGLLZ) .and. (i /= 1 .and. i /= NGLLX) .or. &
+ (i == 1 .or. i == NGLLX) .and. (k /= 1 .and. k /= NGLLZ) .and. (j /= 1 .and. j /= NGLLY) &
+ ) then
+ iglob = ibool(i,j,k,ispec)
+ if (valence_external_mesh(iglob) == 1) then
+ ispec_is_surface_external_mesh(ispec) = .true.
+
+ ! sets flags for all gll points on this face
+ if (k == 1 .or. k == NGLLZ) then
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ iglob_is_surface_external_mesh(ibool(ii,jj,k,ispec)) = .true.
+ enddo
+ enddo
+ endif
+ if (j == 1 .or. j == NGLLY) then
+ do kk = 1, NGLLZ
+ do ii = 1, NGLLX
+ iglob_is_surface_external_mesh(ibool(ii,j,kk,ispec)) = .true.
+ enddo
+ enddo
+ endif
+ if (i == 1 .or. i == NGLLX) then
+ do kk = 1, NGLLZ
+ do jj = 1, NGLLY
+ iglob_is_surface_external_mesh(ibool(i,jj,kk,ispec)) = .true.
+ enddo
+ enddo
+ endif
+ endif
+
+ endif
+ enddo
+ enddo
+ enddo
+
+ enddo ! nspec
+
+! counts faces for movies and shakemaps
+ nfaces_surface_external_mesh = 0
+ do ispec = 1, nspec
+ iglob = ibool(2,2,1,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ iglob = ibool(2,2,NGLLZ,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ iglob = ibool(2,1,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ iglob = ibool(2,NGLLY,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ iglob = ibool(1,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ iglob = ibool(NGLLX,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ enddo
+
+ end subroutine detect_surface
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -28,8 +28,10 @@
subroutine finalize_simulation()
use specfem_par
+ use specfem_par_elastic
+
+ implicit none
-
! save last frame
if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -267,7 +267,7 @@
integer :: dummy_elmnt
integer :: ispec, inode, num_interface, ie,imat !pll
integer :: nnodes_ext_mesh, nelmnts_ext_mesh
- integer :: ninterface_ext_mesh
+ integer :: num_interfaces_ext_mesh
integer :: max_interface_size_ext_mesh
integer :: nmat_ext_mesh, nundefMat_ext_mesh !pll
integer, dimension(:), allocatable :: my_neighbours_ext_mesh
@@ -278,7 +278,9 @@
double precision, dimension(:,:), allocatable :: nodes_coords_ext_mesh
integer, dimension(:,:), allocatable :: elmnts_ext_mesh
integer, dimension(:,:), allocatable :: mat_ext_mesh
-
+ integer :: max_nibool_interfaces_ext_mesh
+ integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy
+
! pll
double precision, dimension(:,:), allocatable :: materials_ext_mesh
integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top
@@ -300,6 +302,10 @@
! auxiliary variables to generate the mesh
! integer ix,iy
+ integer,dimension(:),allocatable :: ispec_is_surface_external_mesh,iglob_is_surface_external_mesh
+ integer :: nfaces_surface_external_mesh,nfaces_surface_glob_ext_mesh
+ integer :: i
+
end module
!
@@ -309,6 +315,7 @@
subroutine generate_databases
use generate_databases_par
+ implicit none
! sizeprocs returns number of processes started (should be equal to NPROC).
! myrank is the rank of each process, between 0 and NPROC-1.
@@ -336,18 +343,10 @@
endif
! read the parameter file
- call read_parameter_file( &
- NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
- UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
- ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
- OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
- MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
- SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
- NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
-
-! checks user input parameters for mesher to run
- call generate_databases_check_parameters()
+ call generate_databases_read_parameters()
+
+! makes sure processes are synchronized
+ call sync_all()
! reads topography and bathymetry file
call generate_databases_read_topography()
@@ -366,122 +365,34 @@
! external mesh creation
call generate_databases_setup_mesh()
-!--- print number of points and elements in the mesh
- call sum_all_i(NGLOB_AB,nglob_total)
- call sum_all_i(NSPEC_AB,nspec_total)
- call sync_all()
- if(myrank == 0) then
-
- write(IMAIN,*)
- write(IMAIN,*) 'Repartition of elements:'
- write(IMAIN,*) '-----------------------'
- write(IMAIN,*)
- write(IMAIN,*) 'total number of elements in each slice: ',NSPEC_AB
- write(IMAIN,*) 'total number of points in each slice: ',NGLOB_AB
- write(IMAIN,*)
- write(IMAIN,*) 'total number of elements in entire mesh: ',nspec_total ! NSPEC_AB*NPROC
- write(IMAIN,*) 'total number of points in entire mesh: ',nglob_total !NGLOB_AB*NPROC
- write(IMAIN,*) 'total number of DOFs in entire mesh: ',nglob_total*NDIM !NGLOB_AB*NPROC*NDIM
- write(IMAIN,*)
- write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
- write(IMAIN,*)
-
- ! write information about precision used for floating-point operations
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IMAIN,*) 'using single precision for the calculations'
- else
- write(IMAIN,*) 'using double precision for the calculations'
- endif
- write(IMAIN,*)
- write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
- write(IMAIN,*)
-
- ! copy number of elements and points in an include file for the solver
- call save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
- ATTENUATION,ANISOTROPY,NSTEP,DT, &
- SIMULATION_TYPE,max_static_memory_size)
-
-! call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS')
-! call get_value_string(filtered_rec_filename, 'solver.STATIONS_FILTERED', 'DATA/STATIONS_FILTERED')
-
-! get total number of stations
-! open(unit=IIN,file=rec_filename,iostat=ios,status='old',action='read')
-! nrec = 0
-! do while(ios == 0)
-! read(IIN,"(a)",iostat=ios) dummystring
-! if(ios == 0) nrec = nrec + 1
-! enddo
-! close(IIN)
-
-! filter list of stations, only retain stations that are in the model
-! nrec_filtered = 0
-! open(unit=IIN,file=rec_filename,status='old',action='read')
-! do irec = 1,nrec
-! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
-! if((stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
-! .or. USE_EXTERNAL_MESH) &
-! nrec_filtered = nrec_filtered + 1
-! enddo
-! close(IIN)
-
-! write(IMAIN,*)
-! write(IMAIN,*) 'there are ',nrec,' stations in file ', trim(rec_filename)
-! write(IMAIN,*) 'saving ',nrec_filtered,' stations inside the model in file ', trim(filtered_rec_filename)
-! write(IMAIN,*) 'excluding ',nrec - nrec_filtered,' stations located outside the model'
-! write(IMAIN,*)
-
-! if(nrec_filtered < 1) call exit_MPI(myrank,'need at least one station in the model')
-
-! if(nrec < 1) call exit_MPI(myrank,'need at least one station in the model')
-
-! open(unit=IIN,file=rec_filename,status='old',action='read')
-! open(unit=IOUT,file=filtered_rec_filename,status='unknown')
-
-! do irec = 1,nrec
-! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
-! if((stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
-! .or. USE_EXTERNAL_MESH) &
-! write(IOUT,*) station_name(1:len_trim(station_name)),' ',network_name(1:len_trim(network_name)),' ', &
-! sngl(stlat),' ',sngl(stlon), ' ', sngl(stele), ' ', sngl(stbur)
-! enddo
-
-! close(IIN)
-! close(IOUT)
-
- endif ! end of section executed by main process only
-
-! elapsed time since beginning of mesh generation
- if(myrank == 0) then
- tCPU = wtime() - time_start
- write(IMAIN,*)
- write(IMAIN,*) 'Elapsed time for mesh generation and buffer creation in seconds = ',tCPU
- write(IMAIN,*) 'End of mesh generation'
- write(IMAIN,*)
- endif
-
-! close main output file
- if(myrank == 0) then
- write(IMAIN,*) 'done'
- write(IMAIN,*)
- close(IMAIN)
- endif
-
-! synchronize all the processes to make sure everybody has finished
- call sync_all()
-
+! finalize mesher
+ call generate_databases_finalize()
+
end subroutine generate_databases
-
!
!-------------------------------------------------------------------------------------------------
!
- subroutine generate_databases_check_parameters
+ subroutine generate_databases_read_parameters
-! checks user input parameters
+! reads and checks user input parameters
use generate_databases_par
+ implicit none
+! reads DATA/Par_file
+ call read_parameter_file( &
+ NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
+ OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
+ MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
+ SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
+
+! checks user input parameters for mesher to run
if (sizeprocs == 1 .and. (NPROC_XI /= 1 .or. NPROC_ETA /= 1)) then
stop 'must have NPROC_XI = NPROC_ETA = 1 for a serial run'
endif
@@ -582,7 +493,7 @@
endif
- end subroutine generate_databases_check_parameters
+ end subroutine generate_databases_read_parameters
!
!-------------------------------------------------------------------------------------------------
@@ -593,6 +504,7 @@
! reads in topography files
use generate_databases_par
+ implicit none
if(TOPOGRAPHY .or. OCEANS) then
@@ -640,6 +552,7 @@
! reads in proc***_Databases files
use generate_databases_par
+ implicit none
! read databases about external mesh simulation
! global node coordinates
@@ -765,13 +678,13 @@
call sync_all()
! MPI interfaces between different partitions
- read(IIN,*) ninterface_ext_mesh, max_interface_size_ext_mesh
- allocate(my_neighbours_ext_mesh(ninterface_ext_mesh))
- allocate(my_nelmnts_neighbours_ext_mesh(ninterface_ext_mesh))
- allocate(my_interfaces_ext_mesh(6,max_interface_size_ext_mesh,ninterface_ext_mesh))
- allocate(ibool_interfaces_ext_mesh(NGLLX*NGLLX*max_interface_size_ext_mesh,ninterface_ext_mesh))
- allocate(nibool_interfaces_ext_mesh(ninterface_ext_mesh))
- do num_interface = 1, ninterface_ext_mesh
+ read(IIN,*) num_interfaces_ext_mesh, max_interface_size_ext_mesh
+ allocate(my_neighbours_ext_mesh(num_interfaces_ext_mesh))
+ allocate(my_nelmnts_neighbours_ext_mesh(num_interfaces_ext_mesh))
+ allocate(my_interfaces_ext_mesh(6,max_interface_size_ext_mesh,num_interfaces_ext_mesh))
+ allocate(ibool_interfaces_ext_mesh(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh))
+ allocate(nibool_interfaces_ext_mesh(num_interfaces_ext_mesh))
+ do num_interface = 1, num_interfaces_ext_mesh
read(IIN,*) my_neighbours_ext_mesh(num_interface), my_nelmnts_neighbours_ext_mesh(num_interface)
do ie = 1, my_nelmnts_neighbours_ext_mesh(num_interface)
read(IIN,*) my_interfaces_ext_mesh(1,ie,num_interface), my_interfaces_ext_mesh(2,ie,num_interface), &
@@ -782,7 +695,7 @@
close(IIN)
if(myrank == 0) then
- write(IMAIN,*) ' number of MPI partition interfaces: ',ninterface_ext_mesh
+ write(IMAIN,*) ' number of MPI partition interfaces: ',num_interfaces_ext_mesh
endif
call sync_all()
@@ -797,6 +710,7 @@
! mesh creation for static solver
use generate_databases_par
+ implicit none
! assign theoretical number of elements
nspec = NSPEC_AB
@@ -813,7 +727,7 @@
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
call memory_eval_mesher(myrank,nspec,npointot,nnodes_ext_mesh,&
- nelmnts_ext_mesh,nmat_ext_mesh,ninterface_ext_mesh, &
+ nelmnts_ext_mesh,nmat_ext_mesh,num_interfaces_ext_mesh, &
max_interface_size_ext_mesh,nspec2D_xmin,nspec2D_xmax,&
nspec2D_ymin,nspec2D_ymax,nspec2D_bottom,nspec2D_top,&
max_static_memory_size_request)
@@ -834,7 +748,7 @@
nodes_coords_ext_mesh, elmnts_ext_mesh, &
max_static_memory_size, mat_ext_mesh, materials_ext_mesh, &
nmat_ext_mesh, undef_mat_prop, nundefMat_ext_mesh, &
- ninterface_ext_mesh, max_interface_size_ext_mesh, &
+ num_interfaces_ext_mesh, max_interface_size_ext_mesh, &
my_neighbours_ext_mesh, my_nelmnts_neighbours_ext_mesh, &
my_interfaces_ext_mesh, &
ibool_interfaces_ext_mesh, nibool_interfaces_ext_mesh, &
@@ -864,9 +778,150 @@
endif
endif
- deallocate(ibool,xstore,ystore,zstore)
+ deallocate(xstore,ystore,zstore)
! make sure everybody is synchronized
call sync_all()
end subroutine generate_databases_setup_mesh
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine generate_databases_finalize
+
+! checks user input parameters
+
+ use generate_databases_par
+ implicit none
+
+!--- print number of points and elements in the mesh
+ call sum_all_i(NGLOB_AB,nglob_total)
+ call sum_all_i(NSPEC_AB,nspec_total)
+ call sync_all()
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Repartition of elements:'
+ write(IMAIN,*) '-----------------------'
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of elements in each slice: ',NSPEC_AB
+ write(IMAIN,*) 'total number of points in each slice: ',NGLOB_AB
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of elements in entire mesh: ',nspec_total ! NSPEC_AB*NPROC
+ write(IMAIN,*) 'total number of points in entire mesh: ',nglob_total !NGLOB_AB*NPROC
+ write(IMAIN,*) 'total number of DOFs in entire mesh: ',nglob_total*NDIM !NGLOB_AB*NPROC*NDIM
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
+ write(IMAIN,*)
+ ! write information about precision used for floating-point operations
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IMAIN,*) 'using single precision for the calculations'
+ else
+ write(IMAIN,*) 'using double precision for the calculations'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
+ write(IMAIN,*)
+ endif
+
+! gets number of surface elements (for movie outputs)
+ allocate( ispec_is_surface_external_mesh(NSPEC_AB), &
+ iglob_is_surface_external_mesh(NGLOB_AB),stat=ier)
+ if( ier /= 0 ) stop 'error allocating array'
+ max_nibool_interfaces_ext_mesh = maxval(nibool_interfaces_ext_mesh)
+ allocate(ibool_interfaces_ext_mesh_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier)
+ if( ier /= 0 ) stop 'error allocating array'
+ do i = 1, num_interfaces_ext_mesh
+ ibool_interfaces_ext_mesh_dummy(:,:) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,:)
+ enddo
+
+ call detect_surface(NPROC,NGLOB_AB,NSPEC_AB,ibool, &
+ ispec_is_surface_external_mesh, &
+ iglob_is_surface_external_mesh, &
+ nfaces_surface_external_mesh, &
+ num_interfaces_ext_mesh, &
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh_dummy )
+
+ deallocate(ibool)
+ deallocate(ispec_is_surface_external_mesh)
+ deallocate(iglob_is_surface_external_mesh)
+ deallocate(ibool_interfaces_ext_mesh_dummy)
+
+! number of surface faces for all partitions together
+ call sum_all_i(nfaces_surface_external_mesh,nfaces_surface_glob_ext_mesh)
+
+
+! copy number of elements and points in an include file for the solver
+ if( myrank == 0 ) then
+ call save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
+ ATTENUATION,ANISOTROPY,NSTEP,DT, &
+ SIMULATION_TYPE,max_static_memory_size,nfaces_surface_glob_ext_mesh)
+ endif
+
+! filters stations file
+! if( myrank == 0 ) then
+! call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS')
+! call get_value_string(filtered_rec_filename, 'solver.STATIONS_FILTERED', 'DATA/STATIONS_FILTERED')
+! get total number of stations
+! open(unit=IIN,file=rec_filename,iostat=ios,status='old',action='read')
+! nrec = 0
+! do while(ios == 0)
+! read(IIN,"(a)",iostat=ios) dummystring
+! if(ios == 0) nrec = nrec + 1
+! enddo
+! close(IIN)
+! filter list of stations, only retain stations that are in the model
+! nrec_filtered = 0
+! open(unit=IIN,file=rec_filename,status='old',action='read')
+! do irec = 1,nrec
+! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
+! if((stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
+! .or. USE_EXTERNAL_MESH) &
+! nrec_filtered = nrec_filtered + 1
+! enddo
+! close(IIN)
+! write(IMAIN,*)
+! write(IMAIN,*) 'there are ',nrec,' stations in file ', trim(rec_filename)
+! write(IMAIN,*) 'saving ',nrec_filtered,' stations inside the model in file ', trim(filtered_rec_filename)
+! write(IMAIN,*) 'excluding ',nrec - nrec_filtered,' stations located outside the model'
+! write(IMAIN,*)
+! if(nrec_filtered < 1) call exit_MPI(myrank,'need at least one station in the model')
+! if(nrec < 1) call exit_MPI(myrank,'need at least one station in the model')
+! open(unit=IIN,file=rec_filename,status='old',action='read')
+! open(unit=IOUT,file=filtered_rec_filename,status='unknown')
+! do irec = 1,nrec
+! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
+! if((stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
+! .or. USE_EXTERNAL_MESH) &
+! write(IOUT,*) station_name(1:len_trim(station_name)),' ',network_name(1:len_trim(network_name)),' ', &
+! sngl(stlat),' ',sngl(stlon), ' ', sngl(stele), ' ', sngl(stbur)
+! enddo
+! close(IIN)
+! close(IOUT)
+! endif ! end of section executed by main process only
+
+! elapsed time since beginning of mesh generation
+ if(myrank == 0) then
+ tCPU = wtime() - time_start
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for mesh generation and buffer creation in seconds = ',tCPU
+ write(IMAIN,*) 'End of mesh generation'
+ write(IMAIN,*)
+ endif
+
+! close main output file
+ if(myrank == 0) then
+ write(IMAIN,*) 'done'
+ write(IMAIN,*)
+ close(IMAIN)
+ endif
+
+! synchronize all the processes to make sure everybody has finished
+ call sync_all()
+
+ end subroutine generate_databases_finalize
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_attenuation_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_attenuation_model.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_attenuation_model.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -215,3 +215,64 @@
end subroutine get_attenuation_model
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine get_attenuation_model_Olsen_sediment( vs_val, iselected )
+
+! uses scaling rule similar to Olsen et al. (2003) to determine attenuation medium
+!
+! returns: selected sediment iselected
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) :: vs_val
+ integer :: iselected
+
+!local parameters
+ real(kind=CUSTOM_REAL) :: Q_mu
+ integer :: int_Q_mu,iattenuation_sediments
+
+ ! use rule Q_mu = constant * v_s
+ Q_mu = OLSEN_ATTENUATION_RATIO * vs_val
+ int_Q_mu = 10 * nint(Q_mu / 10.)
+
+ if(int_Q_mu < 40) int_Q_mu = 40
+ if(int_Q_mu > 150) int_Q_mu = 150
+
+ if(int_Q_mu == 40) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_40
+ else if(int_Q_mu == 50) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_50
+ else if(int_Q_mu == 60) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_60
+ else if(int_Q_mu == 70) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_70
+ else if(int_Q_mu == 80) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_80
+ else if(int_Q_mu == 90) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_90
+ else if(int_Q_mu == 100) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_100
+ else if(int_Q_mu == 110) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_110
+ else if(int_Q_mu == 120) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_120
+ else if(int_Q_mu == 130) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_130
+ else if(int_Q_mu == 140) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_140
+ else if(int_Q_mu == 150) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_150
+ else
+ stop 'incorrect attenuation coefficient'
+ endif
+
+ ! return sediment number
+ iselected = iattenuation_sediments
+
+ end subroutine get_attenuation_model_Olsen_sediment
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -28,7 +28,11 @@
subroutine initialize_simulation()
use specfem_par
+ use specfem_par_elastic
+ !use specfem_par_movie
+ implicit none
+
integer :: sizeprocs
! sizeprocs returns number of processes started
@@ -172,11 +176,11 @@
allocate(zstore(NGLOB_AB))
allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(mustore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(not_fully_in_bedrock(NSPEC_AB))
- allocate(flag_sediments(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+! allocate(not_fully_in_bedrock(NSPEC_AB))
+! allocate(flag_sediments(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(idoubling(NSPEC_AB))
+! allocate(idoubling(NSPEC_AB))
allocate(rmass(NGLOB_AB))
allocate(rmass_ocean_load(NGLOB_AB))
allocate(updated_dof_ocean_load(NGLOB_AB))
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -28,6 +28,7 @@
subroutine iterate_time()
use specfem_par
+ implicit none
!
! s t a r t t i m e i t e r a t i o n s
@@ -59,115 +60,20 @@
do it = 1,NSTEP
-! compute the maximum of the norm of the displacement
-! in all the slices using an MPI reduction
-! and output timestamp file to check that simulation is running fine
+! simulation status output and stability check
if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
call iterate_time_check_stability()
endif
+
+! update displacement using Newark time scheme
+ call iterate_time_update_displacement_scheme()
+
+! elastic solver
+ call compute_forces_elastic()
-
-! update displacement using finite difference time scheme
- displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
- veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
- accel(:,:) = 0._CUSTOM_REAL
-
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) then
-! b_displ(:,:) = b_displ(:,:) + b_deltat*b_veloc(:,:) + b_deltatsqover2*b_accel(:,:)
-! b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
-! b_accel(:,:) = 0._CUSTOM_REAL
-! endif
-
-! if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
-! ispec2D_moho_top = 0
-! ispec2D_moho_bot = 0
-! endif
-
-
-! update acceleration
-! shared points between processors only
- if(USE_DEVILLE_PRODUCTS) then
- call compute_forces_with_Deville( .false. ,NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel,&
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh, &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source, &
- xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
- 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_xz,epsilondev_yz,iflag_attenuation_store,&
- ABSORBING_CONDITIONS, &
- absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
- absorbing_boundary_ijk,absorbing_boundary_ispec, &
- num_absorbing_boundary_faces, &
- veloc,rho_vp,rho_vs)
- else
- call compute_forces_no_Deville(NSPEC_AB,NGLOB_AB,displ,accel,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, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.false., &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source,hdur,dt)
- endif
-
-! assemble all the contributions between slices using MPI
- call assemble_MPI_vector_ext_mesh_s(NPROC,NGLOB_AB,accel, &
- buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
- ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
- request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
-
-! update acceleration
-! points inside processor's partition only
- if(USE_DEVILLE_PRODUCTS) then
- call compute_forces_with_Deville( .true., NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel,&
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh, &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source, &
- xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
- 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_xz,epsilondev_yz,iflag_attenuation_store,&
- ABSORBING_CONDITIONS, &
- absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
- absorbing_boundary_ijk,absorbing_boundary_ispec, &
- num_absorbing_boundary_faces, &
- veloc,rho_vp,rho_vs)
- else
- call compute_forces_no_Deville(NSPEC_AB,NGLOB_AB,displ,accel,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, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.true., &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source,hdur,dt)
- endif
-
-! assemble all the contributions between slices using MPI
- call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,accel, &
- buffer_recv_vector_ext_mesh,ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
- request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
-
-!! DK DK May 2009: removed this because now each slice of a CUBIT + SCOTCH mesh
-!! DK DK May 2009: has a different number of spectral elements and therefore
-!! DK DK May 2009: only the general non-blocking MPI routines assemble_MPI_vector_ext_mesh_s
-!! DK DK May 2009: and assemble_MPI_vector_ext_mesh_w above can be used.
-!! DK DK May 2009: For adjoint runs below (SIMULATION_TYPE == 3) they should be used as well.
-! if (SIMULATION_TYPE == 3) call assemble_MPI_vector(b_accel,iproc_xi,iproc_eta,addressing, &
-! iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
-! buffer_send_faces_vector,buffer_received_faces_vector,npoin2D_xi,npoin2D_eta, &
-! NPROC_XI,NPROC_ETA,NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NPOIN2DMAX_XY)
-
! multiply by the inverse of the mass matrix
- accel(1,:) = accel(1,:)*rmass(:)
- accel(2,:) = accel(2,:)*rmass(:)
- accel(3,:) = accel(3,:)*rmass(:)
-
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) then
-! b_accel(1,:) = b_accel(1,:)*rmass(:)
-! b_accel(2,:) = b_accel(2,:)*rmass(:)
-! b_accel(3,:) = b_accel(3,:)*rmass(:)
-! endif
-
+ call iterate_time_update_acceleration()
+
! updates acceleration with ocean load term
if(OCEANS) then
@@ -177,11 +83,8 @@
endif
! updates velocity
- veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
-
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
-
+ call iterate_time_update_velocity()
+
! write the seismograms with time shift
if (nrec_local > 0) then
call iterate_time_write_seismograms()
@@ -230,17 +133,20 @@
end subroutine iterate_time
-
-
!=====================================================================
-! simulation status output and stability check
-
subroutine iterate_time_check_stability()
+
+! computes the maximum of the norm of the displacement
+! in all the slices using an MPI reduction
+! and output timestamp file to check that simulation is running fine
use specfem_par
-
+ use specfem_par_elastic
+
+ implicit none
+
! compute maximum of norm of displacement in each slice
Usolidnorm = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2 + displ(3,:)**2))
@@ -328,15 +234,83 @@
end subroutine iterate_time_check_stability
+
+!=====================================================================
+
+ subroutine iterate_time_update_displacement_scheme()
+
+! Newark finite-difference time scheme
+ use specfem_par
+ use specfem_par_elastic
+ implicit none
+
+! updates elastic displacement and velocity
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0._CUSTOM_REAL
+
+!! DK DK array not created yet for CUBIT
+! if (SIMULATION_TYPE == 3) then
+! b_displ(:,:) = b_displ(:,:) + b_deltat*b_veloc(:,:) + b_deltatsqover2*b_accel(:,:)
+! b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
+! b_accel(:,:) = 0._CUSTOM_REAL
+! endif
+
+
+ end subroutine iterate_time_update_displacement_scheme
+
!=====================================================================
-! updates acceleration with ocean load term
+ subroutine iterate_time_update_acceleration()
+! updates acceleration
+
+ use specfem_par_elastic
+
+ implicit none
+
+ accel(1,:) = accel(1,:)*rmass(:)
+ accel(2,:) = accel(2,:)*rmass(:)
+ accel(3,:) = accel(3,:)*rmass(:)
+
+!! DK DK array not created yet for CUBIT
+! if (SIMULATION_TYPE == 3) then
+! b_accel(1,:) = b_accel(1,:)*rmass(:)
+! b_accel(2,:) = b_accel(2,:)*rmass(:)
+! b_accel(3,:) = b_accel(3,:)*rmass(:)
+! endif
+
+ end subroutine iterate_time_update_acceleration
+
+!=====================================================================
+
+ subroutine iterate_time_update_velocity()
+
+! updates velocities
+
+ use specfem_par
+ use specfem_par_elastic
+
+ implicit none
+
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+!! DK DK array not created yet for CUBIT
+! if (SIMULATION_TYPE == 3) b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
+
+ end subroutine iterate_time_update_velocity
+!=====================================================================
+
subroutine iterate_time_ocean_load()
+
+! updates acceleration with ocean load term
use specfem_par
+ use specfem_par_elastic
+
+ implicit none
! initialize the updates
updated_dof_ocean_load(:) = .false.
@@ -397,18 +371,18 @@
enddo ! NGLLY
enddo ! NSPEC2D_TOP
-
end subroutine iterate_time_ocean_load
-
-
-
+
!=====================================================================
-! write the seismograms with time shift
-
subroutine iterate_time_write_seismograms()
+
+! writes the seismograms with time shift
use specfem_par
+ use specfem_par_elastic
+
+ implicit none
do irec_local = 1,nrec_local
@@ -582,14 +556,16 @@
end subroutine iterate_time_write_seismograms
-
!================================================================
+
+ subroutine iterate_time_store_attenuation_arrays()
! resetting d/v/a/R/eps for the backward reconstruction with attenuation
- subroutine iterate_time_store_attenuation_arrays()
-
use specfem_par
+ use specfem_par_elastic
+
+ implicit none
if( it > 1 .and. it < NSTEP) then
if (SIMULATION_TYPE == 3 .and. mod(NSTEP-it,NSTEP_Q_SAVE) == 0) then
@@ -630,20 +606,20 @@
endif ! SIMULATION_TYPE
endif ! it
-
end subroutine iterate_time_store_attenuation_arrays
-
-
!================================================================
+
+ subroutine iterate_time_create_shakemap_ext_mesh()
! creation of shapemap file
- subroutine iterate_time_create_shakemap_ext_mesh()
-
use specfem_par
+ use specfem_par_elastic
+ use specfem_par_movie
+
+ implicit none
-
! initializes arrays
if (it == 1) then
@@ -819,12 +795,16 @@
!================================================================
-
+ subroutine iterate_time_create_movie_surface_ext_mesh()
+
! creation of moviedata files
- subroutine iterate_time_create_movie_surface_ext_mesh()
use specfem_par
+ use specfem_par_elastic
+ use specfem_par_movie
+ implicit none
+
! get coordinates of surface mesh and surface displacement
do ispec = 1,nfaces_surface_external_mesh
if (USE_HIGHRES_FOR_MOVIES) then
@@ -921,12 +901,16 @@
!=====================================================================
-! outputs moviedata files
-
subroutine iterate_time_movie_surface_output_obsolete()
+
+! outputs moviedata files
use specfem_par
-
+ use specfem_par_elastic
+ use specfem_par_movie
+
+ implicit none
+
! get coordinates of surface mesh and surface displacement
ipoin = 0
@@ -997,17 +981,20 @@
close(IOUT)
endif
-
end subroutine iterate_time_movie_surface_output_obsolete
!=====================================================================
-! outputs shakemap file
-
subroutine iterate_time_create_shakemap_obsolete()
+
+! outputs shakemap file
use specfem_par
+ use specfem_par_elastic
+ use specfem_par_movie
+
+ implicit none
ipoin = 0
k = NGLLZ
@@ -1076,15 +1063,19 @@
endif ! NTSTEP
end subroutine iterate_time_create_shakemap_obsolete
-
-
+
+
!=====================================================================
-! outputs movie files for div, curl and velocity
-
subroutine iterate_time_movie_volume_output()
+
+! outputs movie files for div, curl and velocity
use specfem_par
+ use specfem_par_elastic
+ use specfem_par_movie
+
+ implicit none
! save velocity here to avoid static offset on displacement for movies
@@ -1194,5 +1185,5 @@
write(27) veloc
close(27)
- end subroutine
+ end subroutine iterate_time_movie_volume_output
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -28,7 +28,7 @@
! compute the approximate amount of static memory needed to run the solver
- subroutine memory_eval(NSPEC_AB,NGLOB_AB,max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh,static_memory_size)
+ subroutine memory_eval(NSPEC_AB,NGLOB_AB,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh,static_memory_size)
implicit none
@@ -37,7 +37,7 @@
! input
! logical, intent(in) :: ATTENUATION
integer, intent(in) :: NSPEC_AB,NGLOB_AB
- integer, intent(in) :: max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh
+ integer, intent(in) :: max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh
! output
double precision, intent(out) :: static_memory_size
@@ -70,19 +70,19 @@
static_memory_size = static_memory_size + 3.d0*dble(NDIM)*NGLOB_AB*dble(CUSTOM_REAL)
! my_neighbours_ext_mesh,nibool_interfaces_ext_mesh
- static_memory_size = static_memory_size + 2.d0*ninterfaces_ext_mesh*dble(SIZE_INTEGER)
+ static_memory_size = static_memory_size + 2.d0*num_interfaces_ext_mesh*dble(SIZE_INTEGER)
! ibool_interfaces_ext_mesh
- static_memory_size = static_memory_size + max_nibool_interfaces_ext_mesh*ninterfaces_ext_mesh*dble(SIZE_INTEGER)
+ static_memory_size = static_memory_size + max_nibool_interfaces_ext_mesh*num_interfaces_ext_mesh*dble(SIZE_INTEGER)
! buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh
- static_memory_size = static_memory_size + 2.d0*dble(NDIM)*max_nibool_interfaces_ext_mesh*ninterfaces_ext_mesh*dble(CUSTOM_REAL)
+ static_memory_size = static_memory_size + 2.d0*dble(NDIM)*max_nibool_interfaces_ext_mesh*num_interfaces_ext_mesh*dble(CUSTOM_REAL)
! buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh
- static_memory_size = static_memory_size + 2.d0*max_nibool_interfaces_ext_mesh*ninterfaces_ext_mesh*dble(CUSTOM_REAL)
+ static_memory_size = static_memory_size + 2.d0*max_nibool_interfaces_ext_mesh*num_interfaces_ext_mesh*dble(CUSTOM_REAL)
! request_send_vector_ext_mesh,request_recv_vector_ext_mesh,request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh
- static_memory_size = static_memory_size + 4.d0*ninterfaces_ext_mesh*dble(SIZE_INTEGER)
+ static_memory_size = static_memory_size + 4.d0*num_interfaces_ext_mesh*dble(SIZE_INTEGER)
end subroutine memory_eval
@@ -93,7 +93,7 @@
! compute the approximate amount of static memory needed to run the mesher
- subroutine memory_eval_mesher(myrank,nspec,npointot,nnodes_ext_mesh,nelmnts_ext_mesh,nmat_ext_mesh,ninterface_ext_mesh, &
+ subroutine memory_eval_mesher(myrank,nspec,npointot,nnodes_ext_mesh,nelmnts_ext_mesh,nmat_ext_mesh,num_interfaces_ext_mesh, &
max_interface_size_ext_mesh,nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,nspec2D_bottom,nspec2D_top,&
static_memory_size_request)
@@ -101,7 +101,7 @@
include "constants.h"
- integer :: myrank,nspec,npointot,nnodes_ext_mesh,nelmnts_ext_mesh,nmat_ext_mesh,ninterface_ext_mesh, &
+ integer :: myrank,nspec,npointot,nnodes_ext_mesh,nelmnts_ext_mesh,nmat_ext_mesh,num_interfaces_ext_mesh, &
max_interface_size_ext_mesh,nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,nspec2D_bottom,nspec2D_top
integer :: static_memory_size_request
@@ -111,8 +111,8 @@
! memory usage, in generate_database() routine so far
static_memory_size = NGLLX*NGLLY*NGLLZ*nspec*4 + 3*NGLLX*NGLLY*NGLLZ*nspec*8 &
+ NDIM*nnodes_ext_mesh*8 + ESIZE*nelmnts_ext_mesh*4 + 2*nelmnts_ext_mesh*4 &
- + 5*nmat_ext_mesh*8 + 3*ninterface_ext_mesh + 6*max_interface_size_ext_mesh*ninterface_ext_mesh*4 &
- + NGLLX*NGLLX*max_interface_size_ext_mesh*ninterface_ext_mesh*4 &
+ + 5*nmat_ext_mesh*8 + 3*num_interfaces_ext_mesh + 6*max_interface_size_ext_mesh*num_interfaces_ext_mesh*4 &
+ + NGLLX*NGLLX*max_interface_size_ext_mesh*num_interfaces_ext_mesh*4 &
+ nspec2D_xmin*20 + nspec2D_xmax*20 + nspec2D_ymin*20 + nspec2D_ymax*20 + nspec2D_bottom*20 + nspec2D_top*20
! memory usage, in create_regions_mesh_ext_mesh() routine requested approximately
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -28,8 +28,42 @@
subroutine prepare_timerun()
use specfem_par
+ use specfem_par_elastic
+ use specfem_par_movie
+
+ implicit none
+! user info
+ if(myrank == 0) then
+ write(IMAIN,*)
+ if(TOPOGRAPHY) then
+ write(IMAIN,*) 'incorporating surface topography'
+ else
+ write(IMAIN,*) 'no surface topography'
+ endif
+
+ write(IMAIN,*)
+ if(ATTENUATION) then
+ write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
+ if(USE_OLSEN_ATTENUATION) then
+ write(IMAIN,*) 'using Olsen''s attenuation'
+ else
+ write(IMAIN,*) 'not using Olsen''s attenuation'
+ endif
+ else
+ write(IMAIN,*) 'no attenuation'
+ endif
+
+ write(IMAIN,*)
+ if(OCEANS) then
+ write(IMAIN,*) 'incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) 'no oceans'
+ endif
+
+ endif
+
! synchronize all the processes before assembling the mass matrix
! to make sure all the nodes have finished to read their databases
call sync_all()
@@ -37,7 +71,7 @@
! the mass matrix needs to be assembled with MPI here once and for all
call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass, &
buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
- ninterfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
@@ -80,7 +114,33 @@
enddo
! rescale shear modulus according to attenuation model
+ !pll
+ do ispec = 1,NSPEC_AB
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+! use scaling rule similar to Olsen et al. (2003)
+!! We might need to fix the attenuation part for the anisotropy case
+!! At this stage, we turn the ATTENUATION flag off always, and still keep mustore
+ if(USE_OLSEN_ATTENUATION) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_Olsen_sediment( vs_val, iselected )
+ else
+! takes iflag set in (CUBIT) mesh
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+! scales only mu
+ scale_factor = factor_scale(iselected)
+ mustore(i,j,k,ispec) = mustore(i,j,k,ispec) * scale_factor
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+! obsolete, old way...
!pll
! do ispec = 1,NSPEC_AB
! if(not_fully_in_bedrock(ispec)) then
@@ -147,20 +207,8 @@
! enddo
! endif
! enddo
-
- !pll
- do ispec = 1,NSPEC_AB
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- scale_factor = factor_scale(iflag_attenuation_store(i,j,k,ispec))
- mustore(i,j,k,ispec) = mustore(i,j,k,ispec) * scale_factor
- enddo
- enddo
- enddo
- enddo
- endif
+ endif ! ATTENUATION
! allocate seismogram array
if (nrec_local > 0) then
@@ -286,14 +334,14 @@
deltat**3*tauinv(:,:)**3 / 6. + deltat**4*tauinv(:,:)**4 / 24.
betaval(:,:) = deltat / 2. + deltat**2*tauinv(:,:) / 3. + deltat**3*tauinv(:,:)**2 / 8. + deltat**4*tauinv(:,:)**3 / 24.
gammaval(:,:) = deltat / 2. + deltat**2*tauinv(:,:) / 6. + deltat**3*tauinv(:,:)**2 / 24.
- if (SIMULATION_TYPE == 3) then
- b_alphaval(:,:) = 1 + b_deltat*tauinv(:,:) + b_deltat**2*tauinv(:,:)**2 / 2. + &
- b_deltat**3*tauinv(:,:)**3 / 6. + b_deltat**4*tauinv(:,:)**4 / 24.
- b_betaval(:,:) = b_deltat / 2. + b_deltat**2*tauinv(:,:) / 3. + &
- b_deltat**3*tauinv(:,:)**2 / 8. + b_deltat**4*tauinv(:,:)**3 / 24.
- b_gammaval(:,:) = b_deltat / 2. + b_deltat**2*tauinv(:,:) / 6. + &
- b_deltat**3*tauinv(:,:)**2 / 24.
- endif
+ !if (SIMULATION_TYPE == 3) then
+ ! b_alphaval(:,:) = 1 + b_deltat*tauinv(:,:) + b_deltat**2*tauinv(:,:)**2 / 2. + &
+ ! b_deltat**3*tauinv(:,:)**3 / 6. + b_deltat**4*tauinv(:,:)**4 / 24.
+ ! b_betaval(:,:) = b_deltat / 2. + b_deltat**2*tauinv(:,:) / 3. + &
+ ! b_deltat**3*tauinv(:,:)**2 / 8. + b_deltat**4*tauinv(:,:)**3 / 24.
+ ! b_gammaval(:,:) = b_deltat / 2. + b_deltat**2*tauinv(:,:) / 6. + &
+ ! b_deltat**3*tauinv(:,:)**2 / 24.
+ !endif
endif
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/program_generate_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/program_generate_databases.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/program_generate_databases.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -29,7 +29,7 @@
call init()
! run the main program
- call generate_databases
+ call generate_databases()
! mpi finish
call finalize()
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -28,6 +28,9 @@
subroutine read_mesh_databases()
use specfem_par
+ use specfem_par_elastic
+
+ implicit none
! start reading the databasesa
@@ -167,23 +170,23 @@
read(27) normal_top
! MPI interfaces
- read(27) ninterfaces_ext_mesh
+ read(27) num_interfaces_ext_mesh
read(27) max_nibool_interfaces_ext_mesh
- allocate(my_neighbours_ext_mesh(ninterfaces_ext_mesh))
- allocate(nibool_interfaces_ext_mesh(ninterfaces_ext_mesh))
- allocate(ibool_interfaces_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
+ allocate(my_neighbours_ext_mesh(num_interfaces_ext_mesh))
+ allocate(nibool_interfaces_ext_mesh(num_interfaces_ext_mesh))
+ allocate(ibool_interfaces_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
read(27) my_neighbours_ext_mesh
read(27) nibool_interfaces_ext_mesh
read(27) ibool_interfaces_ext_mesh
- allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- allocate(request_send_vector_ext_mesh(ninterfaces_ext_mesh))
- allocate(request_recv_vector_ext_mesh(ninterfaces_ext_mesh))
- allocate(request_send_scalar_ext_mesh(ninterfaces_ext_mesh))
- allocate(request_recv_scalar_ext_mesh(ninterfaces_ext_mesh))
+ allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(request_send_vector_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_vector_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_send_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh))
close(27)
! locate inner and outer elements
@@ -191,7 +194,7 @@
allocate(iglob_is_inner_ext_mesh(NGLOB_AB))
ispec_is_inner_ext_mesh(:) = .true.
iglob_is_inner_ext_mesh(:) = .true.
- do iinterface = 1, ninterfaces_ext_mesh
+ do iinterface = 1, num_interfaces_ext_mesh
do i = 1, nibool_interfaces_ext_mesh(iinterface)
iglob = ibool_interfaces_ext_mesh(i,iinterface)
iglob_is_inner_ext_mesh(iglob) = .false.
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -28,6 +28,7 @@
subroutine read_topography_bathymetry()
use specfem_par
+ implicit none
! read topography and bathymetry file
if(TOPOGRAPHY .or. OCEANS) then
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -34,7 +34,7 @@
absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
absorbing_boundary_ijk,absorbing_boundary_ispec, &
num_absorbing_boundary_faces, &
- ninterface_ext_mesh,my_neighbours_ext_mesh,nibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,my_neighbours_ext_mesh,nibool_interfaces_ext_mesh, &
max_interface_size_ext_mesh,ibool_interfaces_ext_mesh, &
prname,SAVE_MESH_FILES)
@@ -98,11 +98,11 @@
! integer, dimension(2,NSPEC2DMAX_XMIN_XMAX) :: njmin,njmax,nkmin_xi
! MPI interfaces
- integer :: ninterface_ext_mesh
- integer, dimension(ninterface_ext_mesh) :: my_neighbours_ext_mesh
- integer, dimension(ninterface_ext_mesh) :: nibool_interfaces_ext_mesh
+ integer :: num_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
integer :: max_interface_size_ext_mesh
- integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,ninterface_ext_mesh) :: ibool_interfaces_ext_mesh
+ integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
! file name
character(len=150) prname
@@ -206,15 +206,15 @@
write(IOUT) normal_top
!MPI interfaces
- write(IOUT) ninterface_ext_mesh
+ write(IOUT) num_interfaces_ext_mesh
write(IOUT) maxval(nibool_interfaces_ext_mesh)
write(IOUT) my_neighbours_ext_mesh
write(IOUT) nibool_interfaces_ext_mesh
- allocate(ibool_interfaces_ext_mesh_dummy(maxval(nibool_interfaces_ext_mesh),ninterface_ext_mesh),stat=ier)
+ allocate(ibool_interfaces_ext_mesh_dummy(maxval(nibool_interfaces_ext_mesh),num_interfaces_ext_mesh),stat=ier)
if( ier /= 0 ) stop 'error allocating array'
- do i = 1, ninterface_ext_mesh
+ do i = 1, num_interfaces_ext_mesh
ibool_interfaces_ext_mesh_dummy = ibool_interfaces_ext_mesh(1:maxval(nibool_interfaces_ext_mesh),:)
enddo
write(IOUT) ibool_interfaces_ext_mesh_dummy
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -27,7 +27,7 @@
subroutine save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
ATTENUATION,ANISOTROPY,NSTEP,DT, &
- SIMULATION_TYPE,static_memory_size)
+ SIMULATION_TYPE,static_memory_size,nfaces_surface_glob_ext_mesh)
implicit none
@@ -47,6 +47,8 @@
character(len=150) HEADER_FILE
+ integer :: nfaces_surface_glob_ext_mesh
+
! copy number of elements and points in an include file for the solver
call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
@@ -146,7 +148,7 @@
endif
write(IOUT,*)
-
+
!! DK DK May 2009: removed all the things that are not supported in the CUBIT + SCOTCH version yet
!! DK DK May 2009: removed all the things that are not supported in the CUBIT + SCOTCH version yet
!! DK DK May 2009: removed all the things that are not supported in the CUBIT + SCOTCH version yet
@@ -203,5 +205,24 @@
close(IOUT)
+
+! copy number of surface elements in an include file for the movies
+ if( nfaces_surface_glob_ext_mesh > 0 ) then
+
+ call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/surface_from_mesher.h')
+
+ open(unit=IOUT,file=HEADER_FILE,status='unknown')
+ write(IOUT,*) '!'
+ write(IOUT,*) '! this is the parameter file for static compilation for movie creation'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of elements containing surface faces '
+ write(IOUT,*) '! ---------------'
+ write(IOUT,*)
+ write(IOUT,*) 'integer,parameter :: NSPEC_SURFACE_EXT_MESH = ',nfaces_surface_glob_ext_mesh
+ write(IOUT,*)
+ close(IOUT)
+
+ endif
+
end subroutine save_header_file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -28,8 +28,8 @@
subroutine setup_GLL_points()
use specfem_par
+ implicit none
-
if(myrank == 0) then
write(IMAIN,*) '******************************************'
write(IMAIN,*) 'There is a total of ',NPROC,' slices'
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -30,35 +30,38 @@
subroutine setup_movie_meshes()
use specfem_par
+ use specfem_par_movie
+ implicit none
+
! initializes mesh arrays for movies and shakemaps
- nfaces_surface_external_mesh = 0
- do ispec = 1, NSPEC_AB
- iglob = ibool(2,2,1,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- iglob = ibool(2,2,NGLLZ,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- iglob = ibool(2,1,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- iglob = ibool(2,NGLLY,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- iglob = ibool(1,2,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- iglob = ibool(NGLLX,2,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- enddo ! NSPEC_AB
+! nfaces_surface_external_mesh = 0
+! do ispec = 1, NSPEC_AB
+! iglob = ibool(2,2,1,ispec)
+! if (iglob_is_surface_external_mesh(iglob)) then
+! nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+! endif
+! iglob = ibool(2,2,NGLLZ,ispec)
+! if (iglob_is_surface_external_mesh(iglob)) then
+! nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+! endif
+! iglob = ibool(2,1,2,ispec)
+! if (iglob_is_surface_external_mesh(iglob)) then
+! nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+! endif
+! iglob = ibool(2,NGLLY,2,ispec)
+! if (iglob_is_surface_external_mesh(iglob)) then
+! nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+! endif
+! iglob = ibool(1,2,2,ispec)
+! if (iglob_is_surface_external_mesh(iglob)) then
+! nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+! endif
+! iglob = ibool(NGLLX,2,2,ispec)
+! if (iglob_is_surface_external_mesh(iglob)) then
+! nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+! endif
+! enddo ! NSPEC_AB
allocate(nfaces_perproc_surface_ext_mesh(NPROC))
allocate(faces_surface_offset_ext_mesh(NPROC))
@@ -99,7 +102,10 @@
allocate(store_val_uz_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
endif
endif
+
+! number of surface faces for all partitions together
call sum_all_i(nfaces_surface_external_mesh,nfaces_surface_glob_ext_mesh)
+
if (myrank == 0) then
if (USE_HIGHRES_FOR_MOVIES) then
allocate(store_val_x_all_external_mesh(NGLLX*NGLLY*nfaces_surface_glob_ext_mesh))
@@ -245,7 +251,7 @@
enddo ! NSPEC_AB
if (myrank == 0) then
- write(IMAIN,*) 'movie: nfaces_surface_external_mesh = ',nfaces_surface_external_mesh
+ write(IMAIN,*) 'movie: nfaces_surface_external_mesh = ',nfaces_surface_external_mesh
write(IMAIN,*) 'movie: nfaces_perproc_surface_ext_mesh = ',nfaces_perproc_surface_ext_mesh
write(IMAIN,*) 'movie: nfaces_surface_glob_ext_mesh = ',nfaces_surface_glob_ext_mesh
endif
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -28,8 +28,8 @@
subroutine setup_sources_receivers()
use specfem_par
+ implicit none
-
! write source and receiver VTK files for Paraview
if (myrank == 0) then
open(IOVTK,file=trim(OUTPUT_FILES)//'/sr.vtk',status='unknown')
@@ -284,40 +284,9 @@
else
write(IMAIN,*) 'this total is okay'
endif
- endif
-
- if(myrank == 0) then
-
+
if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
-
- write(IMAIN,*)
- if(TOPOGRAPHY) then
- write(IMAIN,*) 'incorporating surface topography'
- else
- write(IMAIN,*) 'no surface topography'
- endif
-
- write(IMAIN,*)
- if(ATTENUATION) then
- write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
- if(USE_OLSEN_ATTENUATION) then
- write(IMAIN,*) 'using Olsen''s attenuation'
- else
- write(IMAIN,*) 'not using Olsen''s attenuation'
- endif
- else
- write(IMAIN,*) 'no attenuation'
- endif
-
- write(IMAIN,*)
- if(OCEANS) then
- write(IMAIN,*) 'incorporating the oceans using equivalent load'
- else
- write(IMAIN,*) 'no oceans'
- endif
-
+
endif
-
-
end subroutine
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2009-10-22 03:45:35 UTC (rev 15866)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2009-10-22 21:01:47 UTC (rev 15867)
@@ -25,11 +25,23 @@
!
! United States and French Government Sponsorship Acknowledged.
+module constants
+
+ include "constants.h"
+
+end module constants
+
+!=====================================================================
+
module specfem_par
+! main parameter module for specfem simulations
+
+ use constants
+
implicit none
- include "constants.h"
+! include "constants.h"
! include values created by the mesher
include "OUTPUT_FILES/values_from_mesher.h"
@@ -37,8 +49,6 @@
! standard include of the MPI library
! include 'mpif.h'
-
-
! memory variables and standard linear solids for attenuation
double precision, dimension(N_SLS) :: tau_mu_dble,tau_sigma_dble,beta_dble
double precision factor_scale_dble,one_minus_sum_beta_dble
@@ -132,42 +142,25 @@
kappastore,mustore
! flag for sediments
- logical, dimension(:), allocatable :: not_fully_in_bedrock
- logical, dimension(:,:,:,:), allocatable :: flag_sediments
+! logical, dimension(:), allocatable :: not_fully_in_bedrock
+! logical, dimension(:,:,:,:), allocatable :: flag_sediments
-! Stacey
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
! local to global mapping
- integer, dimension(:), allocatable :: idoubling
+! integer, dimension(:), allocatable :: idoubling
-! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
-
! additional mass matrix for ocean load
! ocean load mass matrix is always allocated statically even if no oceans
real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
logical, dimension(:), allocatable :: updated_dof_ocean_load
real(kind=CUSTOM_REAL) additional_term,force_normal_comp
-! displacement, velocity, acceleration
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: displ,veloc,accel
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
-
- real(kind=CUSTOM_REAL) hp1,hp2,hp3
-
- real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
- real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
- real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
-
! time scheme
real(kind=CUSTOM_REAL) deltat,deltatover2,deltatsqover2
! ADJOINT
real(kind=CUSTOM_REAL) b_additional_term,b_force_normal_comp
!! DK DK array not created yet for CUBIT
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_ADJOINT) :: b_displ, b_veloc, b_accel
! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT) :: rho_kl, mu_kl, kappa_kl, &
! rhop_kl, beta_kl, alpha_kl
! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: absorb_xmin, absorb_xmax, &
@@ -266,13 +259,6 @@
! integer iproc_xi,iproc_eta
-! maximum of the norm of the displacement
- real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all
- integer:: Usolidnorm_index(1)
-! ADJOINT
-! real(kind=CUSTOM_REAL) b_Usolidnorm, b_Usolidnorm_all
-! ADJOINT
-
! timer MPI
double precision, external :: wtime
integer :: ihours,iminutes,iseconds,int_tCPU, &
@@ -280,7 +266,6 @@
ihours_total,iminutes_total,iseconds_total,int_t_total
double precision :: time_start,tCPU,t_remain,t_total
-
! parameters read from parameter file
integer NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
integer NSOURCES
@@ -314,22 +299,9 @@
!integer, dimension(:,:),allocatable :: nimin,nimax,nkmin_eta
!integer, dimension(:,:),allocatable :: njmin,njmax,nkmin_xi
-! to save movie frames
- integer ipoin, nmovie_points, iloc, iorderi(NGNOD2D), iorderj(NGNOD2D)
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
- store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz, &
- store_val_norm_displ,store_val_norm_veloc,store_val_norm_accel
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all
-! to save full 3D snapshot of velocity
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dvxdxl,dvxdyl,dvxdzl,dvydxl,dvydyl,dvydzl,dvzdxl,dvzdyl,dvzdzl
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable:: div, curl_x, curl_y, curl_z
-
! for assembling in case of external mesh
- integer :: ninterfaces_ext_mesh
+ integer :: num_interfaces_ext_mesh
integer :: max_nibool_interfaces_ext_mesh
integer, dimension(:), allocatable :: my_neighbours_ext_mesh
integer, dimension(:), allocatable :: nibool_interfaces_ext_mesh
@@ -344,16 +316,98 @@
integer, dimension(:), allocatable :: request_recv_vector_ext_mesh
! for detecting surface receivers and source in case of external mesh
- integer, dimension(:), allocatable :: valence_external_mesh
logical, dimension(:), allocatable :: iglob_is_surface_external_mesh
logical, dimension(:), allocatable :: ispec_is_surface_external_mesh
- integer, dimension(:,:), allocatable :: buffer_send_scalar_i_ext_mesh
- integer, dimension(:,:), allocatable :: buffer_recv_scalar_i_ext_mesh
+ !integer, dimension(:), allocatable :: valence_external_mesh
+ !integer, dimension(:,:), allocatable :: buffer_send_scalar_i_ext_mesh
+ !integer, dimension(:,:), allocatable :: buffer_recv_scalar_i_ext_mesh
integer :: nfaces_surface_external_mesh
integer :: nfaces_surface_glob_ext_mesh
integer,dimension(:),allocatable :: nfaces_perproc_surface_ext_mesh
integer,dimension(:),allocatable :: faces_surface_offset_ext_mesh
integer,dimension(:,:),allocatable :: faces_surface_external_mesh
+
+ integer :: ii,jj,kk
+
+! model surface
+ logical, dimension(:), allocatable :: ispec_is_inner_ext_mesh
+ logical, dimension(:), allocatable :: iglob_is_inner_ext_mesh
+ integer :: iinterface
+
+! integer, dimension(:),allocatable :: spec_inner, spec_outer
+! integer :: nspec_inner,nspec_outer
+
+!!!! NL NL REGOLITH : regolith layer for asteroid
+!!$ double precision, external :: materials_ext_mesh
+!!$ logical, dimension(:), allocatable :: ispec_is_regolith
+!!$ real(kind=CUSTOM_REAL) :: weight, jacobianl
+!!!! NL NL REGOLITH
+
+end module specfem_par
+
+
+!=====================================================================
+
+module specfem_par_elastic
+
+! parameter module for elastic solver
+
+ use constants,only: CUSTOM_REAL
+ implicit none
+
+! displacement, velocity, acceleration
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: displ,veloc,accel
+
+! ADJOINT
+!! DK DK array not created yet for CUBIT
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_ADJOINT) :: b_displ, b_veloc, b_accel
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
+
+! Stacey
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
+
+! maximum of the norm of the displacement
+ real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all
+ integer:: Usolidnorm_index(1)
+
+! ADJOINT
+! real(kind=CUSTOM_REAL) b_Usolidnorm, b_Usolidnorm_all
+! ADJOINT
+
+! attenuation Olsen
+ real(kind=CUSTOM_REAL):: vs_val
+ integer :: iselected
+
+
+end module specfem_par_elastic
+
+
+!=====================================================================
+
+module specfem_par_movie
+
+! parameter module for movies/shakemovies
+
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,NGNOD2D
+
+ implicit none
+
+! to save movie frames
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ store_val_norm_displ,store_val_norm_veloc,store_val_norm_accel
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ store_val_x_all,store_val_y_all,store_val_z_all, &
+ store_val_ux_all,store_val_uy_all,store_val_uz_all
+
+! to save full 3D snapshot of velocity (movie volume
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dvxdxl,dvxdyl,dvxdzl,dvydxl,dvydyl,dvydzl,dvzdxl,dvzdyl,dvzdzl
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable:: div, curl_x, curl_y, curl_z
+
+! shakemovies
real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_x_external_mesh
real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_y_external_mesh
real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_z_external_mesh
@@ -366,22 +420,17 @@
real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_ux_all_external_mesh
real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_uy_all_external_mesh
real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_uz_all_external_mesh
- integer :: ii,jj,kk
-! for communications overlapping
- logical, dimension(:), allocatable :: ispec_is_inner_ext_mesh
- logical, dimension(:), allocatable :: iglob_is_inner_ext_mesh
- integer :: iinterface
+! movie volume
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
-! integer, dimension(:),allocatable :: spec_inner, spec_outer
-! integer :: nspec_inner,nspec_outer
-
+ real(kind=CUSTOM_REAL) hp1,hp2,hp3
-!!!! NL NL REGOLITH : regolith layer for asteroid
-!!$ double precision, external :: materials_ext_mesh
-!!$ logical, dimension(:), allocatable :: ispec_is_regolith
-!!$ real(kind=CUSTOM_REAL) :: weight, jacobianl
-!!!! NL NL REGOLITH
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
-
-end module
+ integer ipoin, nmovie_points, iloc, iorderi(NGNOD2D), iorderj(NGNOD2D)
+
+end module specfem_par_movie
+
More information about the CIG-COMMITS
mailing list