[cig-commits] r16023 - in seismo/3D/SPECFEM3D_SESAME/trunk: . EXAMPLES/homogeneous_halfspace EXAMPLES/layered_halfspace UTILS/Visualization/opendx_AVS_GMT UTILS/ampuero_implicit_Clayton UTILS/carcione_aniso_copper UTILS/cmt_frechet UTILS/oldstuff/convert_finite_sources UTILS/remap_database decompose_mesh_SCOTCH decompose_mesh_SCOTCH/OUTPUT_FILES meshfem3D
danielpeter at geodynamics.org
danielpeter at geodynamics.org
Fri Nov 20 18:18:49 PST 2009
Author: danielpeter
Date: 2009-11-20 18:18:44 -0800 (Fri, 20 Nov 2009)
New Revision: 16023
Added:
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh-anisotropic.py
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/scotch_user5.1.pdf
seismo/3D/SPECFEM3D_SESAME/trunk/write_VTK_data.f90
Modified:
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/Par_file
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/cubit2specfem3d.py
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/Par_file
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/cubit2specfem3d.py
seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/create_highres_shakemaps_AVS_DX.f90
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/extract_shakemap_GMT.f90
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/ampuero_implicit_Clayton/ampuero_implicit_ABC_specfem3D.f90
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/carcione_aniso_copper/plot_polarograms.f90
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cmt_frechet/make_cmtsolution_files.f90
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/oldstuff/convert_finite_sources/convert_CMT_psmeca_format.f90
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/remap_database/remap_database.f90
seismo/3D/SPECFEM3D_SESAME/trunk/aniso_model.f90
seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_scalar.f90
seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90
seismo/3D/SPECFEM3D_SESAME/trunk/check_buffers_2D.f90
seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90
seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90
seismo/3D/SPECFEM3D_SESAME/trunk/combine_surf_data.f90
seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_arrays_source.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.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/constants.h.in
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_name_database.f90
seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
seismo/3D/SPECFEM3D_SESAME/trunk/create_serial_name_database.f90
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/OUTPUT_FILES/cubit2specfem3d.py
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/README
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/detect_surface.f90
seismo/3D/SPECFEM3D_SESAME/trunk/exit_mpi.f90
seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_MPI_cutplanes_eta.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_MPI_cutplanes_xi.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_absorb.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_attenuation_model.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_cmt.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_shape3D.f90
seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
seismo/3D/SPECFEM3D_SESAME/trunk/lagrange_poly.f90
seismo/3D/SPECFEM3D_SESAME/trunk/locate_receivers.f90
seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90
seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90
seismo/3D/SPECFEM3D_SESAME/trunk/meshfem3D/save_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90
seismo/3D/SPECFEM3D_SESAME/trunk/prepare_assemble_MPI.f90
seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_arrays_buffers_solver.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_arrays_solver.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_moho_map.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_parameter_file.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_value_parameters.f90
seismo/3D/SPECFEM3D_SESAME/trunk/salton_trough_gocad.f90
seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90
seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90
seismo/3D/SPECFEM3D_SESAME/trunk/serial.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/sort_array_coordinates.f90
seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D.f90
seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_global_data.f90
seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_global_faces_data.f90
seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_surface_data.f90
seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90
Log:
added acoustic solver, requires a domainID flag on the material properties
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/Par_file
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/Par_file 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/Par_file 2009-11-21 02:18:44 UTC (rev 16023)
@@ -38,7 +38,7 @@
SAVE_MESH_FILES = .true.
# path to store the local database file on each node
-LOCAL_PATH = /scratch/lustre/dpeter/SPECFEM3D_SESAME/DATABASES_MPI.hom
+LOCAL_PATH = DATABASES_MPI
# interval at which we output time step info and max of norm of displacement
NTSTEP_BETWEEN_OUTPUT_INFO = 500
Added: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh-anisotropic.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh-anisotropic.py (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh-anisotropic.py 2009-11-21 02:18:44 UTC (rev 16023)
@@ -0,0 +1,62 @@
+#!/usr/bin/env python
+
+import cubit
+import boundary_definition
+import cubit2specfem3d
+
+import os
+import sys
+
+# two volumes separating 134000x134000x60000 block horizontally
+cubit.cmd('reset')
+cubit.cmd('brick x 67000 y 134000 z 60000')
+cubit.cmd('volume 1 move x 33500 y 67000 z -30000')
+cubit.cmd('brick x 67000 y 134000 z 60000')
+cubit.cmd('volume 2 move x 100500 y 67000 z -30000')
+cubit.cmd('merge all')
+
+# Meshing the volumes
+elementsize = 3750.0
+
+cubit.cmd('volume 1 size '+str(elementsize))
+cubit.cmd('volume 2 size '+str(elementsize))
+cubit.cmd('mesh volume 1 2')
+
+
+#### End of meshing
+
+###### This is boundary_definition.py of GEOCUBIT
+#..... which extracts the bounding faces and defines them into blocks
+boundary_definition.entities=['face']
+boundary_definition.define_bc(boundary_definition.entities,parallel=True)
+
+#### Define material properties for the 3 volumes ################
+cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
+cubit.cmd('block 1 name "elastic" ') # elastic material region
+cubit.cmd('block 1 attribute count 6')
+cubit.cmd('block 1 attribute index 1 1') # flag for material: 1 for 1. material
+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 13') # Q flag (see constants.h: IATTENUATION_ ... )
+cubit.cmd('block 1 attribute index 6 1 ') # anisotropy_flag
+
+cubit.cmd('block 2 name "elastic" ') # elastic material region
+cubit.cmd('block 2 attribute count 6')
+cubit.cmd('block 2 attribute index 1 1') # flag for material: 1 for 1. material
+cubit.cmd('block 2 attribute index 2 2800') # vp
+cubit.cmd('block 2 attribute index 3 1500') # vs
+cubit.cmd('block 2 attribute index 4 2300') # rho
+cubit.cmd('block 2 attribute index 5 13') # Q flag (see constants.h: IATTENUATION_ ... )
+cubit.cmd('block 2 attribute index 6 0 ') # anisotropy_flag
+
+
+cubit.cmd('export mesh "top.e" dimension 3 overwrite')
+cubit.cmd('save as "meshing.cub" overwrite')
+
+#### Export to SESAME format using cubit2specfem3d.py of GEOCUBIT
+
+os.system('mkdir -p MESH')
+cubit2specfem3d.export2SESAME('MESH')
+
+# all files needed by SCOTCH are now in directory MESH
Property changes on: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh-anisotropic.py
___________________________________________________________________
Name: svn:executable
+ *
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh.py 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh.py 2009-11-21 02:18:44 UTC (rev 16023)
@@ -28,14 +28,26 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
+
+
+cubit.cmd('block 1 name "elastic" ') # elastic material region
cubit.cmd('block 1 attribute count 6')
-cubit.cmd('block 1 attribute index 1 1') # flag for material properties: 1 for 1. volume
+cubit.cmd('block 1 attribute index 1 1') # flag for material: 1 for 1. material
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 13') # Q flag (see constants.h: IATTENUATION_ ... )
cubit.cmd('block 1 attribute index 6 0 ') # anisotropy_flag
+
+#cubit.cmd('block 1 name "acoustic" ') # acoustic material region
+#cubit.cmd('block 1 attribute count 4')
+#cubit.cmd('block 1 attribute index 1 1 ') # material 1
+#cubit.cmd('block 1 attribute index 2 1480 ') # vp
+#cubit.cmd('block 1 attribute index 3 0 ') # vs
+#cubit.cmd('block 1 attribute index 4 1028 ') # rho (ocean salt water density:
+
+
cubit.cmd('export mesh "top.e" dimension 3 overwrite')
cubit.cmd('save as "meshing.cub" overwrite')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/cubit2specfem3d.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/cubit2specfem3d.py 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/cubit2specfem3d.py 2009-11-21 02:18:44 UTC (rev 16023)
@@ -33,7 +33,8 @@
# automatically using the module boundary_definition (see boundary_definition.py for more information)
#or
# manually following the convention:
-# - each material should have a block defined by name,flag of the material (integer),p velocity
+# - each material should have a block defined by:
+# material domain_flag (acoustic/elastic/poroelastic)name,flag of the material (integer),p velocity
# (or the full description: name, flag, vp, vs, rho, Q ... if not present these last 3 parameters will be
# interpolated by module mat_parameter)
# - each mesh should have the block definition for the face on the free_surface (topography),
@@ -371,20 +372,35 @@
for block in blocks:
name=cubit.get_exodus_entity_name('block',block)
ty=cubit.get_block_element_type(block)
- print block,blocks,ty,self.hex,self.face
+ print block,name,blocks,ty,self.hex,self.face
if ty == self.hex:
- nattrib=cubit.get_block_attribute_count(block)
flag=None
vel=None
vs=None
rho=None
- q=None
- ani=None
+ q=0
+ ani=0
+ # material domain id
+ if name == "acoustic" :
+ imaterial = 1
+ elif name == "elastic" :
+ imaterial = 2
+ elif name == "poroelastic" :
+ imaterial = 3
+ else :
+ imaterial = 0
+
+ nattrib=cubit.get_block_attribute_count(block)
if nattrib != 0:
- flag=int(cubit.get_block_attribute_value(block,0))
+ # material flag:
+ # positive => material properties,
+ # negative => interface/tomography domain
+ flag=int(cubit.get_block_attribute_value(block,0))
if flag > 0 and nattrib >= 2:
+ # vp
vel=cubit.get_block_attribute_value(block,1)
if nattrib >= 3:
+ # vs
vs=cubit.get_block_attribute_value(block,2)
if nattrib >= 4:
#density
@@ -402,6 +418,7 @@
#anisotropy_flag
ani=cubit.get_block_attribute_value(block,5)
elif flag < 0:
+ # velocity model
vel=name
attrib=cubit.get_block_attribute_value(block,1)
if attrib == 1:
@@ -416,19 +433,19 @@
block_flag.append(int(flag))
block_mat.append(block)
if flag > 0:
- par=tuple([flag,vel,vs,rho,q,ani])
+ par=tuple([imaterial,flag,vel,vs,rho,q,ani])
elif flag < 0:
if kind=='interface':
- par=tuple([flag,kind,name,flag_down,flag_up])
+ par=tuple([imaterial,flag,kind,name,flag_down,flag_up])
elif kind=='tomography':
- par=tuple([flag,kind,name])
+ par=tuple([imaterial,flag,kind,name])
elif flag==0:
- par=tuple([flag,name])
- material[name]=par
+ par=tuple([imaterial,flag,name])
+ material[block]=par
elif ty == self.face: #Stacey condition, we need hex here for pml
block_bc_flag.append(4)
block_bc.append(block)
- bc[name]=4 #face has connectivity = 4
+ bc[block]=4 #face has connectivity = 4
if name == self.topo: topography_face=block
else:
print 'blocks no properly defined',ty
@@ -463,36 +480,39 @@
#TODO: material property acoustic/elastic/poroelastic ? .... where?
print "#material properties:"
print properties
- flag=properties[0]
+ imaterial=properties[0]
+ flag=properties[1]
if flag > 0:
- vel=properties[1]
- if properties[2] is None and type(vel) != str:
+ vel=properties[2]
+ if properties[3] is None and type(vel) != str:
+ # velocity model scales with given vp value
if vel >= 30:
m2km=1000.
else:
m2km=1.
vp=vel/m2km
rho=(1.6612*vp-0.472*vp**2+0.0671*vp**3-0.0043*vp**4+0.000106*vp**4)*m2km
- txt='%3i %20f %20f %20f %1i %1i\n' % (properties[0],rho,vel,vel/(3**.5),0,0)
+ txt='%1i %3i %20f %20f %20f %1i %1i\n' % (properties[0],properties[1],rho,vel,vel/(3**.5),0,0)
elif type(vel) != str:
- #format nummaterials file: #material_id #rho #vp #vs #Q_flag #anisotropy_flag
- txt='%3i %20f %20f %20f %2i %2i\n' % (properties[0],properties[3], \
- properties[1],properties[2],properties[4],properties[5])
+ # velocity model given as vp,vs,rho,..
+ #format nummaterials file: #material_domain_id #material_id #rho #vp #vs #Q_flag #anisotropy_flag
+ txt='%1i %3i %20f %20f %20f %2i %2i\n' % (properties[0],properties[1],properties[4], \
+ properties[2],properties[3],properties[5],properties[6])
else:
- txt='%3i %s \n' % (properties[0],properties[1])
+ txt='%1i %3i %s \n' % (properties[0],properties[1],properties[2])
elif flag < 0:
- if properties[1] == 'tomography':
- txt='%3i %s %s\n' % (properties[0],properties[1],properties[2])
- elif properties[1] == 'interface':
- txt='%3i %s %s %1i %1i\n' % (properties[0],properties[1],properties[2],\
- properties[3],properties[4])
+ if properties[2] == 'tomography':
+ txt='%1i %3i %s %s\n' % (properties[0],properties[1],properties[2],properties[3])
+ elif properties[2] == 'interface':
+ txt='%1i %3i %s %s %1i %1i\n' % (properties[0],properties[1],properties[2],properties[3],\
+ properties[4],properties[5])
return txt
def nummaterial_write(self,nummaterial_name):
print 'Writing '+nummaterial_name+'.....'
nummaterial=open(nummaterial_name,'w')
for block in self.block_mat:
- name=cubit.get_exodus_entity_name('block',block)
- nummaterial.write(self.mat_parameter(self.material[name]))
+ #name=cubit.get_exodus_entity_name('block',block)
+ nummaterial.write(self.mat_parameter(self.material[block]))
nummaterial.close()
print 'Ok'
def mesh_write(self,mesh_name):
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-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8-nodoubling.py 2009-11-21 02:18:44 UTC (rev 16023)
@@ -73,14 +73,16 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
+cubit.cmd('block 1 name "elastic" ') # elastic material region
cubit.cmd('block 1 attribute count 6')
cubit.cmd('block 1 attribute index 1 1 ') # volume 1
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 6 ') # Q_flag
-cubit.cmd('block 1 attribute index 6 1 ') # anisotropy_flag
+cubit.cmd('block 1 attribute index 6 0 ') # anisotropy_flag
+cubit.cmd('block 2 name "elastic" ') # elastic material region
cubit.cmd('block 2 attribute count 6')
cubit.cmd('block 2 attribute index 1 2 ') # volume 2
cubit.cmd('block 2 attribute index 2 7500 ') # vp
@@ -89,8 +91,9 @@
cubit.cmd('block 2 attribute index 5 6') # Q_flag
cubit.cmd('block 2 attribute index 6 0 ') # anisotropy_flag
+cubit.cmd('block 3 name "elastic" ') # elastic material region
cubit.cmd('block 3 attribute count 6')
-cubit.cmd('block 3 attribute index 1 2 ') # same material properties as for volume 2
+cubit.cmd('block 3 attribute index 1 3 ') # 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 ')
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-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8.py 2009-11-21 02:18:44 UTC (rev 16023)
@@ -70,6 +70,7 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
+cubit.cmd('block 1 name "elastic" ') # elastic material region
cubit.cmd('block 1 attribute count 6')
cubit.cmd('block 1 attribute index 1 1 ') # volume 1
cubit.cmd('block 1 attribute index 2 2800 ') # vp
@@ -78,6 +79,7 @@
cubit.cmd('block 1 attribute index 5 6 ') # Q_flag
cubit.cmd('block 1 attribute index 6 0 ') # anisotropy_flag
+cubit.cmd('block 2 name "elastic" ') # elastic material region
cubit.cmd('block 2 attribute count 6')
cubit.cmd('block 2 attribute index 1 2 ') # volume 2
cubit.cmd('block 2 attribute index 2 7500 ')
@@ -86,8 +88,9 @@
cubit.cmd('block 2 attribute index 5 6 ')
cubit.cmd('block 2 attribute index 6 0 ') # anisotropy_flag
+cubit.cmd('block 3 name "elastic" ') # elastic material region
cubit.cmd('block 3 attribute count 6')
-cubit.cmd('block 3 attribute index 1 2 ') # same properties as for volume 2
+cubit.cmd('block 3 attribute index 1 3 ') # 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 ')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/Par_file
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/Par_file 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/Par_file 2009-11-21 02:18:44 UTC (rev 16023)
@@ -38,7 +38,7 @@
SAVE_MESH_FILES = .true.
# path to store the local database file on each node
-LOCAL_PATH = /scratch/lustre/dpeter/SPECFEM3D_SESAME/DATABASES_MPI.FIG8
+LOCAL_PATH = DATABASES_MPI
# interval at which we output time step info and max of norm of displacement
NTSTEP_BETWEEN_OUTPUT_INFO = 500
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/cubit2specfem3d.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/cubit2specfem3d.py 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/cubit2specfem3d.py 2009-11-21 02:18:44 UTC (rev 16023)
@@ -33,7 +33,8 @@
# automatically using the module boundary_definition (see boundary_definition.py for more information)
#or
# manually following the convention:
-# - each material should have a block defined by name,flag of the material (integer),p velocity
+# - each material should have a block defined by:
+# material domain_flag (acoustic/elastic/poroelastic)name,flag of the material (integer),p velocity
# (or the full description: name, flag, vp, vs, rho, Q ... if not present these last 3 parameters will be
# interpolated by module mat_parameter)
# - each mesh should have the block definition for the face on the free_surface (topography),
@@ -371,20 +372,35 @@
for block in blocks:
name=cubit.get_exodus_entity_name('block',block)
ty=cubit.get_block_element_type(block)
- print block,blocks,ty,self.hex,self.face
+ print block,name,blocks,ty,self.hex,self.face
if ty == self.hex:
- nattrib=cubit.get_block_attribute_count(block)
flag=None
vel=None
vs=None
rho=None
- q=None
- ani=None
+ q=0
+ ani=0
+ # material domain id
+ if name == "acoustic" :
+ imaterial = 1
+ elif name == "elastic" :
+ imaterial = 2
+ elif name == "poroelastic" :
+ imaterial = 3
+ else :
+ imaterial = 0
+
+ nattrib=cubit.get_block_attribute_count(block)
if nattrib != 0:
- flag=int(cubit.get_block_attribute_value(block,0))
+ # material flag:
+ # positive => material properties,
+ # negative => interface/tomography domain
+ flag=int(cubit.get_block_attribute_value(block,0))
if flag > 0 and nattrib >= 2:
+ # vp
vel=cubit.get_block_attribute_value(block,1)
if nattrib >= 3:
+ # vs
vs=cubit.get_block_attribute_value(block,2)
if nattrib >= 4:
#density
@@ -402,6 +418,7 @@
#anisotropy_flag
ani=cubit.get_block_attribute_value(block,5)
elif flag < 0:
+ # velocity model
vel=name
attrib=cubit.get_block_attribute_value(block,1)
if attrib == 1:
@@ -416,19 +433,19 @@
block_flag.append(int(flag))
block_mat.append(block)
if flag > 0:
- par=tuple([flag,vel,vs,rho,q,ani])
+ par=tuple([imaterial,flag,vel,vs,rho,q,ani])
elif flag < 0:
if kind=='interface':
- par=tuple([flag,kind,name,flag_down,flag_up])
+ par=tuple([imaterial,flag,kind,name,flag_down,flag_up])
elif kind=='tomography':
- par=tuple([flag,kind,name])
+ par=tuple([imaterial,flag,kind,name])
elif flag==0:
- par=tuple([flag,name])
- material[name]=par
+ par=tuple([imaterial,flag,name])
+ material[block]=par
elif ty == self.face: #Stacey condition, we need hex here for pml
block_bc_flag.append(4)
block_bc.append(block)
- bc[name]=4 #face has connectivity = 4
+ bc[block]=4 #face has connectivity = 4
if name == self.topo: topography_face=block
else:
print 'blocks no properly defined',ty
@@ -463,36 +480,39 @@
#TODO: material property acoustic/elastic/poroelastic ? .... where?
print "#material properties:"
print properties
- flag=properties[0]
+ imaterial=properties[0]
+ flag=properties[1]
if flag > 0:
- vel=properties[1]
- if properties[2] is None and type(vel) != str:
+ vel=properties[2]
+ if properties[3] is None and type(vel) != str:
+ # velocity model scales with given vp value
if vel >= 30:
m2km=1000.
else:
m2km=1.
vp=vel/m2km
rho=(1.6612*vp-0.472*vp**2+0.0671*vp**3-0.0043*vp**4+0.000106*vp**4)*m2km
- txt='%3i %20f %20f %20f %1i %1i\n' % (properties[0],rho,vel,vel/(3**.5),0,0)
+ txt='%1i %3i %20f %20f %20f %1i %1i\n' % (properties[0],properties[1],rho,vel,vel/(3**.5),0,0)
elif type(vel) != str:
- #format nummaterials file: #material_id #rho #vp #vs #Q_flag #anisotropy_flag
- txt='%3i %20f %20f %20f %2i %2i\n' % (properties[0],properties[3], \
- properties[1],properties[2],properties[4],properties[5])
+ # velocity model given as vp,vs,rho,..
+ #format nummaterials file: #material_domain_id #material_id #rho #vp #vs #Q_flag #anisotropy_flag
+ txt='%1i %3i %20f %20f %20f %2i %2i\n' % (properties[0],properties[1],properties[4], \
+ properties[2],properties[3],properties[5],properties[6])
else:
- txt='%3i %s \n' % (properties[0],properties[1])
+ txt='%1i %3i %s \n' % (properties[0],properties[1],properties[2])
elif flag < 0:
- if properties[1] == 'tomography':
- txt='%3i %s %s\n' % (properties[0],properties[1],properties[2])
- elif properties[1] == 'interface':
- txt='%3i %s %s %1i %1i\n' % (properties[0],properties[1],properties[2],\
- properties[3],properties[4])
+ if properties[2] == 'tomography':
+ txt='%1i %3i %s %s\n' % (properties[0],properties[1],properties[2],properties[3])
+ elif properties[2] == 'interface':
+ txt='%1i %3i %s %s %1i %1i\n' % (properties[0],properties[1],properties[2],properties[3],\
+ properties[4],properties[5])
return txt
def nummaterial_write(self,nummaterial_name):
print 'Writing '+nummaterial_name+'.....'
nummaterial=open(nummaterial_name,'w')
for block in self.block_mat:
- name=cubit.get_exodus_entity_name('block',block)
- nummaterial.write(self.mat_parameter(self.material[name]))
+ #name=cubit.get_exodus_entity_name('block',block)
+ nummaterial.write(self.mat_parameter(self.material[block]))
nummaterial.close()
print 'Ok'
def mesh_write(self,mesh_name):
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2009-11-21 02:18:44 UTC (rev 16023)
@@ -73,7 +73,6 @@
$O/exit_mpi.o \
$O/get_MPI_cutplanes_eta.o \
$O/get_MPI_cutplanes_xi.o \
- $O/get_absorb.o \
$O/get_attenuation_model.o \
$O/get_cmt.o \
$O/get_element_face.o \
@@ -101,6 +100,7 @@
$O/write_AVS_DX_global_data.o \
$O/write_AVS_DX_global_faces_data.o \
$O/write_AVS_DX_surface_data.o \
+ $O/write_VTK_data.o \
$O/write_seismograms.o \
$O/compute_boundary_kernel.o \
$O/memory_eval.o \
@@ -112,6 +112,7 @@
# $O/compute_rho_estimate.o \
# $O/define_subregions.o \
# $O/define_subregions_heuristic.o \
+# $O/get_absorb.o \
# $O/get_flags_boundaries.o \
# $O/hauksson_model.o \
# $O/interpolate_gocad_block_HR.o \
@@ -124,13 +125,15 @@
-# solver objects with statically allocated arrays; dependent upon
-# values_from_mesher.h
+# solver objects with statically allocated arrays; not dependent upon
+# values_from_mesher.h anymore
SOLVER_ARRAY_OBJECTS = \
$O/specfem3D_par.o \
$O/compute_forces_no_Deville.o \
$O/compute_forces_with_Deville.o \
$O/compute_forces_elastic.o \
+ $O/compute_forces_acoustic.o \
+ $O/compute_gradient.o \
$O/initialize_simulation.o \
$O/read_mesh_databases.o \
$O/setup_GLL_points.o \
@@ -255,40 +258,40 @@
####
###
-### optimized flags and dependence on values from mesher
+### optimized flags (not dependent on values from mesher anymore)
###
-$O/specfem3D_par.o: constants.h OUTPUT_FILES/values_from_mesher.h specfem3D_par.f90
+$O/specfem3D_par.o: constants.h specfem3D_par.f90
${FCCOMPILE_NO_CHECK} -c -o $O/specfem3D_par.o specfem3D_par.f90
-$O/initialize_simulation.o: constants.h OUTPUT_FILES/values_from_mesher.h initialize_simulation.f90
+$O/initialize_simulation.o: constants.h initialize_simulation.f90
${FCCOMPILE_NO_CHECK} -c -o $O/initialize_simulation.o initialize_simulation.f90
-$O/read_mesh_databases.o: constants.h OUTPUT_FILES/values_from_mesher.h read_mesh_databases.f90
+$O/read_mesh_databases.o: constants.h read_mesh_databases.f90
${FCCOMPILE_NO_CHECK} -c -o $O/read_mesh_databases.o read_mesh_databases.f90
-$O/setup_GLL_points.o: constants.h OUTPUT_FILES/values_from_mesher.h setup_GLL_points.f90
+$O/setup_GLL_points.o: constants.h setup_GLL_points.f90
${FCCOMPILE_NO_CHECK} -c -o $O/setup_GLL_points.o setup_GLL_points.f90
-$O/detect_mesh_surfaces.o: constants.h OUTPUT_FILES/values_from_mesher.h detect_mesh_surfaces.f90
+$O/detect_mesh_surfaces.o: constants.h detect_mesh_surfaces.f90
${FCCOMPILE_NO_CHECK} -c -o $O/detect_mesh_surfaces.o detect_mesh_surfaces.f90
-$O/setup_movie_meshes.o: constants.h OUTPUT_FILES/values_from_mesher.h setup_movie_meshes.f90
+$O/setup_movie_meshes.o: constants.h setup_movie_meshes.f90
${FCCOMPILE_NO_CHECK} -c -o $O/setup_movie_meshes.o setup_movie_meshes.f90
-$O/read_topography_bathymetry.o: constants.h OUTPUT_FILES/values_from_mesher.h read_topography_bathymetry.f90
+$O/read_topography_bathymetry.o: constants.h read_topography_bathymetry.f90
${FCCOMPILE_NO_CHECK} -c -o $O/read_topography_bathymetry.o read_topography_bathymetry.f90
-$O/setup_sources_receivers.o: constants.h OUTPUT_FILES/values_from_mesher.h setup_sources_receivers.f90
+$O/setup_sources_receivers.o: constants.h setup_sources_receivers.f90
${FCCOMPILE_NO_CHECK} -c -o $O/setup_sources_receivers.o setup_sources_receivers.f90
-$O/prepare_timerun.o: constants.h OUTPUT_FILES/values_from_mesher.h prepare_timerun.f90
+$O/prepare_timerun.o: constants.h prepare_timerun.f90
${FCCOMPILE_NO_CHECK} -c -o $O/prepare_timerun.o prepare_timerun.f90
-$O/iterate_time.o: constants.h OUTPUT_FILES/values_from_mesher.h iterate_time.f90
+$O/iterate_time.o: constants.h iterate_time.f90
${FCCOMPILE_NO_CHECK} -c -o $O/iterate_time.o iterate_time.f90
-$O/finalize_simulation.o: constants.h OUTPUT_FILES/values_from_mesher.h finalize_simulation.f90
+$O/finalize_simulation.o: constants.h finalize_simulation.f90
${FCCOMPILE_NO_CHECK} -c -o $O/finalize_simulation.o finalize_simulation.f90
$O/assemble_MPI_vector.o: constants.h assemble_MPI_vector.f90
@@ -380,9 +383,6 @@
$O/gll_library.o: constants.h gll_library.f90
${FCCOMPILE_CHECK} -c -o $O/gll_library.o gll_library.f90
-$O/get_absorb.o: constants.h get_absorb.f90
- ${FCCOMPILE_CHECK} -c -o $O/get_absorb.o get_absorb.f90
-
$O/get_jacobian_boundaries.o: constants.h get_jacobian_boundaries.f90
${FCCOMPILE_CHECK} -c -o $O/get_jacobian_boundaries.o get_jacobian_boundaries.f90
@@ -398,7 +398,7 @@
$O/get_cmt.o: constants.h get_cmt.f90
${FCCOMPILE_CHECK} -c -o $O/get_cmt.o get_cmt.f90
-$O/create_movie_shakemap_AVS_DX_GMT.o: constants.h create_movie_shakemap_AVS_DX_GMT.f90
+$O/create_movie_shakemap_AVS_DX_GMT.o: constants.h create_movie_shakemap_AVS_DX_GMT.f90 OUTPUT_FILES/surface_from_mesher.h
${FCCOMPILE_CHECK} -c -o $O/create_movie_shakemap_AVS_DX_GMT.o create_movie_shakemap_AVS_DX_GMT.f90
$O/get_element_face.o: constants.h get_element_face.f90
@@ -416,6 +416,9 @@
$O/write_AVS_DX_global_data.o: constants.h write_AVS_DX_global_data.f90
${FCCOMPILE_CHECK} -c -o $O/write_AVS_DX_global_data.o write_AVS_DX_global_data.f90
+$O/write_VTK_data.o: constants.h write_VTK_data.f90
+ ${FCCOMPILE_CHECK} -c -o $O/write_VTK_data.o write_VTK_data.f90
+
$O/get_shape3D.o: constants.h get_shape3D.f90
${FCCOMPILE_CHECK} -c -o $O/get_shape3D.o get_shape3D.f90
@@ -493,7 +496,13 @@
$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
+$O/compute_forces_acoustic.o: constants.h compute_forces_acoustic.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_acoustic.o compute_forces_acoustic.f90
+$O/compute_gradient.o: constants.h compute_gradient.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_gradient.o compute_gradient.f90
+
+
###
### all obsolete files ?
###
@@ -502,6 +511,10 @@
# ${FCCOMPILE_CHECK} -c -o $O/mesh_vertical.o mesh_vertical.f90
#--obsolete
+#$O/get_absorb.o: constants.h get_absorb.f90
+# ${FCCOMPILE_CHECK} -c -o $O/get_absorb.o get_absorb.f90
+
+#--obsolete
#$O/interpolate_gocad_block_MR.o: constants.h interpolate_gocad_block_MR.f90
# ${FCCOMPILE_CHECK} -c -o $O/interpolate_gocad_block_MR.o interpolate_gocad_block_MR.f90
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/create_highres_shakemaps_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/create_highres_shakemaps_AVS_DX.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/create_highres_shakemaps_AVS_DX.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -63,7 +63,7 @@
double precision min_field_current,max_field_current,max_absol
- character(len=150) outputname
+ character(len=256) outputname
integer iproc,ipoin
@@ -106,7 +106,7 @@
double precision zscaling
- character(len=150) LOCAL_PATH
+ character(len=256) LOCAL_PATH
! parameters deduced from parameters read from file
integer NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/extract_shakemap_GMT.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/extract_shakemap_GMT.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/extract_shakemap_GMT.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -61,7 +61,7 @@
double precision min_field_current,max_field_current,max_absol
- character(len=150) outputname
+ character(len=256) outputname
integer iproc,ipoin
@@ -104,7 +104,7 @@
double precision zscaling
- character(len=150) LOCAL_PATH
+ character(len=256) LOCAL_PATH
! parameters deduced from parameters read from file
integer NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/ampuero_implicit_Clayton/ampuero_implicit_ABC_specfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/ampuero_implicit_Clayton/ampuero_implicit_ABC_specfem3D.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/ampuero_implicit_Clayton/ampuero_implicit_ABC_specfem3D.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -249,7 +249,7 @@
double precision DT,LAT_MIN,LAT_MAX,LONG_MIN,LONG_MAX
logical ATTENUATION,STACEY_ABS_CONDITIONS
- character(len=150) LOCAL_PATH,prname
+ character(len=256) LOCAL_PATH,prname
! parameters deduced from parameters read from file
integer NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
@@ -262,7 +262,7 @@
NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX
! names of the data files for all the processors in MPI
- character(len=150) outputname
+ character(len=256) outputname
! Stacey conditions put back
integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,ispec2D
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/carcione_aniso_copper/plot_polarograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/carcione_aniso_copper/plot_polarograms.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/carcione_aniso_copper/plot_polarograms.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -38,7 +38,7 @@
double precision, parameter :: sizex = 21.d0
double precision, parameter :: sizez = 29.7d0
- character(len=150) filename
+ character(len=256) filename
! to store seismograms everywhere on vertical face for polarograms
! use single precision to store this array
@@ -60,7 +60,7 @@
logical POSTSCRIPT_SNAPSHOTS
- character(len=150) LOCAL_PATH
+ character(len=256) LOCAL_PATH
!--------- program starts here
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cmt_frechet/make_cmtsolution_files.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cmt_frechet/make_cmtsolution_files.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cmt_frechet/make_cmtsolution_files.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -34,14 +34,14 @@
integer yr,jda,ho,mi
double precision sec,t_cmt,hdur,lat,long,depth
double precision moment_tensor(6)
- character(len=150) cmt_file
+ character(len=256) cmt_file
integer iu,i,ios,lstr,mo,da,julian_day
double precision mb,ms
double precision latp,longp
character(len=24) reg
character(len=5) datasource
- character(len=150) string
+ character(len=256) string
open(unit=1,file='CMTSOLUTION',iostat=ios,status='old')
if(ios /= 0) stop 'error opening CMT file '
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/oldstuff/convert_finite_sources/convert_CMT_psmeca_format.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/oldstuff/convert_finite_sources/convert_CMT_psmeca_format.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/oldstuff/convert_finite_sources/convert_CMT_psmeca_format.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -15,7 +15,7 @@
integer iline,NLINES
double precision long,lat,depth,mrr,mtt,mpp,mrt,mrp,mtp,scaleval
- character(len=150) string
+ character(len=256) string
! header of script
write(*,8)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/remap_database/remap_database.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/remap_database/remap_database.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/remap_database/remap_database.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -11,7 +11,7 @@
integer, parameter :: MAX_PROCS = 1000
integer ier,sizeprocs,myrank,ios,i
- character(len=150) old_machine_file,junk,junk2,slice_to_old_machine(MAX_PROCS), &
+ character(len=256) old_machine_file,junk,junk2,slice_to_old_machine(MAX_PROCS), &
mymachine, local_data_base, scp_outfile, command_string
integer num_slices, num_slices2,num
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/aniso_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/aniso_model.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/aniso_model.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -36,7 +36,11 @@
include "constants.h"
-! include "constants_gocad.h"
+! see for example:
+!
+! M. Chen & J. Tromp, 2006. Theoretical & numerical investigations
+! of global and regional seismic wave propagation in weakly anisotropic earth models,
+! GJI, 168, 1130-1152.
!------------------------------------------------------------------------------
! for anisotropy simulations in a halfspace model
@@ -44,10 +48,10 @@
! only related to body waves
! one-zeta term
real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1p_A = 0.2_CUSTOM_REAL
- real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1sv_A = 0.0_CUSTOM_REAL
- real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1sh_N = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1sv_A = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1sh_N = 0._CUSTOM_REAL
! three-zeta term
- real(kind=CUSTOM_REAL), parameter :: FACTOR_CS3_L = 0.0_CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS3_L = 0._CUSTOM_REAL
! Relative to Love wave
! four-zeta term
@@ -84,60 +88,6 @@
real(kind=CUSTOM_REAL) d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,d33,d34,d35,d36, &
d44,d45,d46,d55,d56,d66
-! not anymore, takes vp,vs rho from given isotropic input model...
-!
-!! implement the background model
-! if(iflag_aniso == IANISOTROPY_HALFSPACE_MOHO) then
-! vp=7.8_CUSTOM_REAL
-! vs=4.5_CUSTOM_REAL
-! rho=3.0_CUSTOM_REAL
-! vph = vp
-! vpv = vp
-! vsh = vs
-! vsv = vs
-! eta_aniso = 1.0_CUSTOM_REAL
-!
-! else if(iflag_aniso == IANISOTROPY_MOHO_16km) then
-! vp=7.8_CUSTOM_REAL
-! vs=4.5_CUSTOM_REAL
-! rho=3.0_CUSTOM_REAL
-! vph = vp
-! vpv = vp
-! vsh = vs
-! vsv = vs
-! eta_aniso = 1.0_CUSTOM_REAL
-!
-! else if(zmesh >= DEPTH_5p5km_SOCAL) then
-! vp=7.8_CUSTOM_REAL
-! vs=4.5_CUSTOM_REAL
-! rho=3.0_CUSTOM_REAL
-! vph = vp
-! vpv = vp
-! vsh = vs
-! vsv = vs
-! eta_aniso = 1.0_CUSTOM_REAL
-!
-! else
-! vp=7.8_CUSTOM_REAL
-! vs=4.5_CUSTOM_REAL
-! rho=3.0_CUSTOM_REAL
-! vph = vp
-! vpv = vp
-! vsh = vs
-! vsv = vs
-! eta_aniso = 1.0_CUSTOM_REAL
-!
-! endif
-
-! scale to standard units
-! vp = vp * 1000._CUSTOM_REAL
-! vs = vs * 1000._CUSTOM_REAL
-! vph = vph * 1000._CUSTOM_REAL
-! vpv = vpv * 1000._CUSTOM_REAL
-! vsh = vsh * 1000._CUSTOM_REAL
-! vsv = vsv * 1000._CUSTOM_REAL
-! rho = rho * 1000._CUSTOM_REAL
-
! assumes vp,vs given in m/s, rho in kg/m**3
vph = vp
vpv = vp
@@ -145,80 +95,156 @@
vsv = vs
eta_aniso = 1.0_CUSTOM_REAL
-! see for example:
+
+! for definition, see for example:
!
-! M. Chen & J. Tromp, 2006. Theoretical & numerical investigations
-! of global and regional seismic wave propagation in weakly anisotropic earth models,
-! GJI, 168, 1130-1152.
-
+! Dziewonski & Anderson, 1981. Preliminary reference earth model, PEPI, 25, 297-356.
+! page 305:
aa = rho*vph*vph
cc = rho*vpv*vpv
nn = rho*vsh*vsh
ll = rho*vsv*vsv
ff = eta_aniso*(aa - 2.*ll)
-! Add anisotropic perturbation in the whole halfspace
-! You can also add different perturbations to different layers
+! Add anisotropic perturbation
+! notation: see Chen & Tromp, 2006, appendix A, page 1151
+!
+! zeta-independant terms:
+! A = \delta A
+! C = \delta C
+! AN = \delta N
+! AL = \delta L
+! F = \delta F
+!
+! zeta-dependant terms:
+! C1p = J_c
+! C1sv = K_c
+! C1sh = M_c
+! S1p = J_s
+! S1sv = K_s
+! S1sh = M_s
+!
+! two-zeta dependant terms:
+! Gc = G_c
+! Gs = G_s
+! Bc = B_c
+! Bs = B_s
+! Hc = H_c
+! Hs = H_s
+!
+! three-zeta dependant terms:
+! C3 = D_c
+! S3 = D_s
+!
+! four-zeta dependant terms:
+! Ec = E_c
+! Es = E_s
+
! no anisotropic perturbation
if( iflag_aniso <= 0 ) then
+ ! zeta-independant
A = aa
C = cc
AN = nn
AL = ll
F = ff
- C1p = 0.0
- C1sv = 0.0
- C1sh = 0.0
- Gc = 0.0
- Bc = 0.0
- Hc = 0.0
- C3 = 0.0
- Ec = 0.0
+
+ ! zeta-dependant terms
+ C1p = 0._CUSTOM_REAL
+ C1sv = 0._CUSTOM_REAL
+ C1sh = 0._CUSTOM_REAL
+ S1p = 0._CUSTOM_REAL
+ S1sv = 0._CUSTOM_REAL
+ S1sh = 0._CUSTOM_REAL
+
+ ! two-zeta dependant terms
+ Gc = 0._CUSTOM_REAL
+ Gs = 0._CUSTOM_REAL
+
+ Bc = 0._CUSTOM_REAL
+ Bs = 0._CUSTOM_REAL
+
+ Hc = 0._CUSTOM_REAL
+ Hs = 0._CUSTOM_REAL
+
+ ! three-zeta dependant terms
+ C3 = 0._CUSTOM_REAL
+ S3 = 0._CUSTOM_REAL
+
+ ! four-zeta dependant terms
+ Ec = 0._CUSTOM_REAL
+ Es = 0._CUSTOM_REAL
endif
! perturbation model 1
if( iflag_aniso == IANISOTROPY_MODEL1 ) then
+ ! zeta-independant
A = aa*(1.0_CUSTOM_REAL + FACTOR_A)
C = cc*(1.0_CUSTOM_REAL + FACTOR_C)
AN = nn*(1.0_CUSTOM_REAL + FACTOR_N)
AL = ll*(1.0_CUSTOM_REAL + FACTOR_L)
F = ff*(1.0_CUSTOM_REAL + FACTOR_F)
+
+ ! zeta-dependant terms
C1p = FACTOR_CS1p_A*aa
C1sv = FACTOR_CS1sv_A*aa
C1sh = FACTOR_CS1sh_N*nn
+ S1p = 0._CUSTOM_REAL
+ S1sv = 0._CUSTOM_REAL
+ S1sh = 0._CUSTOM_REAL
+
+ ! two-zeta dependant terms
Gc = FACTOR_G_L*ll
Bc = FACTOR_B_A*aa
Hc = FACTOR_H_F*ff
+ Gs = 0._CUSTOM_REAL
+ Bs = 0._CUSTOM_REAL
+ Hs = 0._CUSTOM_REAL
+
+ ! three-zeta dependant terms
C3 = FACTOR_CS3_L*ll
+ S3 = 0._CUSTOM_REAL
+
+ ! four-zeta dependant terms
Ec = FACTOR_E_N*nn
+ Es = 0._CUSTOM_REAL
endif
! perturbation model 2
if( iflag_aniso == IANISOTROPY_MODEL2 ) then
+ ! zeta-independant
A = aa*(1.0_CUSTOM_REAL + FACTOR_A + 0.1)
C = cc*(1.0_CUSTOM_REAL + FACTOR_C + 0.1)
AN = nn*(1.0_CUSTOM_REAL + FACTOR_N + 0.1)
AL = ll*(1.0_CUSTOM_REAL + FACTOR_L + 0.1)
F = ff*(1.0_CUSTOM_REAL + FACTOR_F + 0.1)
+
+ ! zeta-dependant terms
C1p = FACTOR_CS1p_A*aa
C1sv = FACTOR_CS1sv_A*aa
C1sh = FACTOR_CS1sh_N*nn
+ S1p = 0._CUSTOM_REAL
+ S1sv = 0._CUSTOM_REAL
+ S1sh = 0._CUSTOM_REAL
+
+ ! two-zeta dependant terms
Gc = FACTOR_G_L*ll
Bc = FACTOR_B_A*aa
Hc = FACTOR_H_F*ff
+ Gs = 0._CUSTOM_REAL
+ Bs = 0._CUSTOM_REAL
+ Hs = 0._CUSTOM_REAL
+
+ ! three-zeta dependant terms
C3 = FACTOR_CS3_L*ll
+ S3 = 0._CUSTOM_REAL
+
+ ! four-zeta dependant terms
Ec = FACTOR_E_N*nn
+ Es = 0._CUSTOM_REAL
endif
- S1p = 0._CUSTOM_REAL
- S1sv = 0._CUSTOM_REAL
- S1sh = 0._CUSTOM_REAL
- Gs = 0._CUSTOM_REAL
- Bs = 0._CUSTOM_REAL
- Hs = 0._CUSTOM_REAL
- S3 = 0._CUSTOM_REAL
- Es = 0._CUSTOM_REAL
! The mapping from the elastic coefficients to the elastic tensor elements
! in the local Cartesian coordinate system (classical geographic) used in the
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_scalar.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_scalar.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_scalar.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -28,77 +28,100 @@
!----
subroutine assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,array_val, &
- buffer_send_scalar_ext_mesh,buffer_recv_scalar_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)
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+! subroutine assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,array_val, &
+! buffer_send_scalar_ext_mesh,buffer_recv_scalar_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)
+
implicit none
include "constants.h"
-! include values created by the mesher
-! include "OUTPUT_FILES/values_from_mesher.h"
-
! array to assemble
real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: array_val
integer :: NPROC
integer :: NGLOB_AB
- 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 :: 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
+
+! 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, dimension(num_interfaces_ext_mesh) :: request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_scalar_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_send_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_recv_scalar_ext_mesh
+
+
integer ipoin,iinterface
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
! here we have to assemble all the contributions between partitions using MPI
! assemble only if more than one partition
if(NPROC > 1) then
-! partition border copy into the buffer
- 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))
+ 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_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh))
+
+ ! partition border copy into the buffer
+ 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
- enddo
-! send messages
- 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), &
- itag, &
- request_send_scalar_ext_mesh(iinterface) &
- )
- call irecv_cr(buffer_recv_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
- nibool_interfaces_ext_mesh(iinterface), &
- my_neighbours_ext_mesh(iinterface), &
- itag, &
- request_recv_scalar_ext_mesh(iinterface) &
- )
- enddo
+ ! send messages
+ 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), &
+ itag, &
+ request_send_scalar_ext_mesh(iinterface) &
+ )
+ call irecv_cr(buffer_recv_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_recv_scalar_ext_mesh(iinterface) &
+ )
+ enddo
-! wait for communications completion
- do iinterface = 1, num_interfaces_ext_mesh
- call wait_req(request_recv_scalar_ext_mesh(iinterface))
- enddo
+ ! wait for communications completion
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_recv_scalar_ext_mesh(iinterface))
+ enddo
-! adding contributions of neighbours
- 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)
+ ! adding contributions of neighbours
+ 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)
+ enddo
enddo
- enddo
+ ! wait for communications completion (send)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_send_scalar_ext_mesh(iinterface))
+ enddo
+
+ deallocate(buffer_send_scalar_ext_mesh)
+ deallocate(buffer_recv_scalar_ext_mesh)
+ deallocate(request_send_scalar_ext_mesh)
+ deallocate(request_recv_scalar_ext_mesh)
+
endif
end subroutine assemble_MPI_scalar_ext_mesh
@@ -108,84 +131,210 @@
!
subroutine assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,array_val, &
- buffer_send_scalar_ext_mesh,buffer_recv_scalar_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 &
- )
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
implicit none
include "constants.h"
-! include values created by the mesher
-! include "OUTPUT_FILES/values_from_mesher.h"
-
! array to assemble
integer, dimension(NGLOB_AB) :: array_val
integer :: NPROC
integer :: NGLOB_AB
- integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
- buffer_send_scalar_ext_mesh,buffer_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
+ integer, dimension(:,:), allocatable :: buffer_send_scalar_ext_mesh
+ integer, dimension(:,:), allocatable :: buffer_recv_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_send_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_recv_scalar_ext_mesh
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+ integer :: ipoin,iinterface
! here we have to assemble all the contributions between partitions using MPI
! assemble only if more than one partition
if(NPROC > 1) then
-! partition border copy into the buffer
- 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))
+ 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_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh))
+
+ ! partition border copy into the buffer
+ 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
- enddo
-! send messages
- 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), &
- itag, &
- request_send_scalar_ext_mesh(iinterface) &
- )
- call irecv_i(buffer_recv_scalar_ext_mesh(1,iinterface), &
- nibool_interfaces_ext_mesh(iinterface), &
- my_neighbours_ext_mesh(iinterface), &
- itag, &
- request_recv_scalar_ext_mesh(iinterface) &
- )
- enddo
+ ! send messages
+ do iinterface = 1, num_interfaces_ext_mesh
+ call issend_i(buffer_send_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_send_scalar_ext_mesh(iinterface) &
+ )
+ call irecv_i(buffer_recv_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_recv_scalar_ext_mesh(iinterface) &
+ )
+ enddo
-! wait for communications completion
- do iinterface = 1, num_interfaces_ext_mesh
- call wait_req(request_recv_scalar_ext_mesh(iinterface))
- enddo
+ ! wait for communications completion
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_recv_scalar_ext_mesh(iinterface))
+ enddo
-! adding contributions of neighbours
- 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)
+ ! adding contributions of neighbours
+ 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)
+ enddo
enddo
- enddo
-! wait for communications completion (send)
- do iinterface = 1, num_interfaces_ext_mesh
- call wait_req(request_send_scalar_ext_mesh(iinterface))
- enddo
+ ! wait for communications completion (send)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_send_scalar_ext_mesh(iinterface))
+ enddo
+ deallocate(buffer_send_scalar_ext_mesh)
+ deallocate(buffer_recv_scalar_ext_mesh)
+ deallocate(request_send_scalar_ext_mesh)
+ deallocate(request_recv_scalar_ext_mesh)
+
endif
end subroutine assemble_MPI_scalar_i_ext_mesh
+!
+!----
+!
+
+ subroutine assemble_MPI_scalar_ext_mesh_s(NPROC,NGLOB_AB,array_val, &
+ buffer_send_scalar_ext_mesh,buffer_recv_scalar_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)
+
+! non-blocking MPI send
+
+ implicit none
+
+ include "constants.h"
+
+! array to send
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: array_val
+
+ integer :: NPROC
+ integer :: NGLOB_AB
+
+ 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 :: 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
+
+! sends only if more than one partition
+ if(NPROC > 1) then
+
+ ! partition border copy into the buffer
+ 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, 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), &
+ itag, &
+ request_send_scalar_ext_mesh(iinterface) &
+ )
+ call irecv_cr(buffer_recv_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_recv_scalar_ext_mesh(iinterface) &
+ )
+
+ enddo
+
+ endif
+
+ end subroutine assemble_MPI_scalar_ext_mesh_s
+
+!
+!----
+!
+
+ subroutine assemble_MPI_scalar_ext_mesh_w(NPROC,NGLOB_AB,array_val, &
+ buffer_recv_scalar_ext_mesh,num_interfaces_ext_mesh, &
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+
+! waits for send/receiver to be completed and assembles contributions
+
+ implicit none
+
+ include "constants.h"
+
+! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: array_val
+
+ integer :: NPROC
+ integer :: NGLOB_AB
+
+ real(kind=CUSTOM_REAL), dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
+ buffer_recv_scalar_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_scalar_ext_mesh,request_recv_scalar_ext_mesh
+
+ integer ipoin,iinterface
+
+! assemble only if more than one partition
+ if(NPROC > 1) then
+
+ ! wait for communications completion
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_recv_scalar_ext_mesh(iinterface))
+ enddo
+
+ ! adding contributions of neighbours
+ 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)
+ enddo
+ enddo
+
+ ! wait for communications completion (send)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_send_scalar_ext_mesh(iinterface))
+ enddo
+
+ endif
+
+ end subroutine assemble_MPI_scalar_ext_mesh_w
+
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -37,9 +37,6 @@
include "constants.h"
-! include values created by the mesher
-! include "OUTPUT_FILES/values_from_mesher.h"
-
! array to assemble
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
@@ -108,6 +105,10 @@
end subroutine assemble_MPI_vector_ext_mesh
+!
+!-------------------------------------------------------------------------------------------------
+!
+
subroutine assemble_MPI_vector_ext_mesh_s(NPROC,NGLOB_AB,array_val, &
buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
@@ -119,9 +120,6 @@
include "constants.h"
-! include values created by the mesher
-! include "OUTPUT_FILES/values_from_mesher.h"
-
! array to assemble
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
@@ -172,6 +170,9 @@
end subroutine assemble_MPI_vector_ext_mesh_s
+!
+!-------------------------------------------------------------------------------------------------
+!
subroutine assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,array_val, &
buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
@@ -182,9 +183,6 @@
include "constants.h"
-! include values created by the mesher
-! include "OUTPUT_FILES/values_from_mesher.h"
-
! array to assemble
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/check_buffers_2D.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/check_buffers_2D.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/check_buffers_2D.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -73,7 +73,7 @@
USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION,USE_REGULAR_MESH
integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
- character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+ character(len=256) OUTPUT_FILES,LOCAL_PATH,MODEL
! parameters deduced from parameters read from file
integer NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
@@ -87,7 +87,7 @@
NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NGLOB_AB
! processor identification
- character(len=150) prname,prname_other
+ character(len=256) prname,prname_other
! ************** PROGRAM STARTS HERE **************
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -60,8 +60,8 @@
! estimation of time step and period resolved
real(kind=CUSTOM_REAL),parameter :: COURANT_SUGGESTED = 0.3
real(kind=CUSTOM_REAL),parameter :: NELEM_PER_WAVELENGTH = 1.5
+ logical :: has_vs_zero
-
! initializes
if( DT <= 0.0d0) then
DT_PRESENT = .false.
@@ -83,6 +83,8 @@
dt_suggested_glob = HUGEVAL
+ has_vs_zero = .false.
+
! checks courant number & minimum resolved period for each grid cell
do ispec=1,NSPEC_AB
@@ -91,8 +93,18 @@
vpmax = -HUGEVAL
vsmin = HUGEVAL
vsmax = -HUGEVAL
- vp_elem(:,:,:) = (FOUR_THIRDS * mustore(:,:,:,ispec) + kappastore(:,:,:,ispec)) / rho_vp(:,:,:,ispec)
- vs_elem(:,:,:) = mustore(:,:,:,ispec) / rho_vs(:,:,:,ispec)
+ ! vp
+ where( rho_vp(:,:,:,ispec) > TINYVAL )
+ vp_elem(:,:,:) = (FOUR_THIRDS * mustore(:,:,:,ispec) + kappastore(:,:,:,ispec)) / rho_vp(:,:,:,ispec)
+ elsewhere
+ vp_elem(:,:,:) = 0.0
+ endwhere
+ ! vs
+ where( rho_vs(:,:,:,ispec) > TINYVAL )
+ vs_elem(:,:,:) = mustore(:,:,:,ispec) / rho_vs(:,:,:,ispec)
+ elsewhere
+ vs_elem(:,:,:) = 0.0
+ endwhere
val_min = minval(vp_elem(:,:,:))
val_max = maxval(vp_elem(:,:,:))
@@ -104,7 +116,11 @@
val_max = maxval(vs_elem(:,:,:))
! ignore fluid regions with Vs = 0
- if( val_min(1) > 0.0001 ) vsmin = min(vsmin,val_min(1))
+ if( val_min(1) > 0.0001 ) then
+ vsmin = min(vsmin,val_min(1))
+ else
+ has_vs_zero = .true.
+ endif
vsmax = max(vsmax,val_max(1))
! min/max for whole cpu partition
@@ -180,6 +196,8 @@
call max_all_cr(vpmax,vpmax_glob)
vsmin = vsmin_glob
+ if( has_vs_zero ) vsmin = 0.0
+
vsmax = vsmax_glob
call min_all_cr(vsmin,vsmin_glob)
call max_all_cr(vsmax,vsmax_glob)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -68,12 +68,12 @@
double precision, allocatable, dimension(:) :: stlat,stlon,stele,stbur
character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
- character(len=150) dummystring
+ character(len=256) dummystring
double precision, allocatable, dimension(:) :: x_target,y_target,z_target
! processor identification
- character(len=150) prname
+ character(len=256) prname
! small offset for source and receiver line in AVS_DX
! (small compared to normalized radius of the Earth)
@@ -101,7 +101,7 @@
double precision zscaling
- character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL,filtered_rec_filename
+ character(len=256) OUTPUT_FILES,LOCAL_PATH,MODEL,filtered_rec_filename
! parameters deduced from parameters read from file
integer NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/combine_surf_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/combine_surf_data.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/combine_surf_data.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -34,7 +34,7 @@
implicit none
include 'constants.h'
- include 'OUTPUT_FILES/values_from_mesher.h'
+! include 'OUTPUT_FILES/values_from_mesher.h'
integer i,j,k,ispec, ios, it
integer iproc, proc1, proc2, num_node, node_list(300), nspec, nglob
@@ -48,9 +48,9 @@
real x, y, z
real, dimension(:,:,:,:), allocatable :: dat3D
real, dimension(:,:,:), allocatable :: dat2D
- character(len=150) :: sline, arg(8), filename, indir, outdir, prname, surfname
- character(len=150) :: mesh_file, local_file, local_data_file, local_ibool_file
- character(len=150) :: local_ibool_surf_file
+ character(len=256) :: sline, arg(8), filename, indir, outdir, prname, surfname
+ character(len=256) :: mesh_file, local_file, local_data_file, local_ibool_file
+ character(len=256) :: local_ibool_surf_file
integer :: num_ibool(NGLOB_AB)
logical :: HIGH_RESOLUTION_MESH, FILE_ARRAY_IS_3D
integer :: ires, nspec_surf, npoint1, npoint2, ispec_surf, inx, iny, idim
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -36,7 +36,7 @@
implicit none
include 'constants.h'
- include 'OUTPUT_FILES/values_from_mesher.h'
+! include 'OUTPUT_FILES/values_from_mesher.h'
! comment next line if using old basin version
integer :: NSPEC_AB, NGLOB_AB
@@ -53,10 +53,10 @@
integer :: numpoin
integer :: i, ios, it
integer :: iproc, proc1, proc2, num_node, node_list(300), nspec, nglob
- integer :: np, ne, npp, nee, npoint, nelement, njunk
+ integer :: np, ne, npp, nee, nelement, njunk
- character(len=150) :: sline, arg(6), filename, indir, outdir, prname
- character(len=150) :: mesh_file,local_data_file, local_ibool_file
+ character(len=256) :: sline, arg(6), filename, indir, outdir, prname
+ character(len=256) :: mesh_file,local_data_file, local_ibool_file
logical :: HIGH_RESOLUTION_MESH
integer :: ires
@@ -187,8 +187,8 @@
if (.not. HIGH_RESOLUTION_MESH) then
! writes out element corners only
call combine_vol_data_write_corners(nspec,nglob,ibool,mask_ibool,&
- xstore,ystore,zstore,dat,npoint,&
- it,npp,num_node,prname,numpoin)
+ xstore,ystore,zstore,dat, &
+ it,npp,prname,numpoin)
else
! high resolution, all GLL points
call combine_vol_data_write_GLL_points(nspec,nglob,ibool,mask_ibool,&
@@ -245,7 +245,7 @@
! spectral elements
call combine_vol_data_write_corner_elements(nspec,nglob,ibool,mask_ibool,num_ibool, &
np,nelement, &
- it,nee,num_node,prname,numpoin)
+ it,nee,numpoin)
else
! subdivided spectral elements
call combine_vol_data_write_GLL_elements(nspec,nglob,ibool,mask_ibool,num_ibool, &
@@ -274,7 +274,7 @@
print *, 'Done writing '//trim(mesh_file)
- end program combine_paraview_data
+ end program combine_paraview_data_ext_mesh
!=============================================================
@@ -287,7 +287,7 @@
include 'constants.h'
integer,intent(in) :: num_node,node_list(300)
- character(len=150),intent(in) :: indir
+ character(len=256),intent(in) :: indir
integer,intent(out) :: npp,nee
logical,intent(in) :: HIGH_RESOLUTION_MESH
@@ -297,7 +297,7 @@
integer :: NSPEC_AB, NGLOB_AB
integer :: it,iproc,npoint,nelement,ios,ispec
integer :: iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
- character(len=150) :: prname
+ character(len=256) :: prname
npp = 0
nee = 0
@@ -374,8 +374,8 @@
! writes out locations of spectral element corners only
subroutine combine_vol_data_write_corners(nspec,nglob,ibool,mask_ibool,&
- xstore,ystore,zstore,dat,npoint,&
- it,npp,num_node,prname,numpoin)
+ xstore,ystore,zstore,dat,&
+ it,npp,prname,numpoin)
implicit none
include 'constants.h'
@@ -386,14 +386,16 @@
real(kind=CUSTOM_REAL),dimension(nglob) :: xstore, ystore, zstore
real,dimension(NGLLY,NGLLY,NGLLZ,nspec),intent(in) :: dat
integer:: it
- integer :: npp,num_node,npoint,numpoin
- character(len=150) :: prname
+ integer :: npp,numpoin
+ character(len=256) :: prname
+ !integer :: npoint,num_node
+
! local parameters
real :: x, y, z
- integer :: ios,ispec,njunk
+ integer :: ios,ispec !,njunk
integer :: iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
- character(len=150) :: local_file
+ character(len=256) :: local_file
! corner locations
! reads in coordinate files
@@ -550,12 +552,12 @@
real(kind=CUSTOM_REAL),dimension(nglob) :: xstore, ystore, zstore
real,dimension(NGLLY,NGLLY,NGLLZ,nspec),intent(in) :: dat
integer:: it,npp,numpoin
- character(len=150) :: prname
+ character(len=256) :: prname
! local parameters
real :: x, y, z
integer :: ios,ispec,i,j,k,iglob
- character(len=150) :: local_file
+ character(len=256) :: local_file
! writes out total number of points
if (it == 1) then
@@ -620,8 +622,8 @@
! writes out locations of spectral element corners only
subroutine combine_vol_data_write_corner_elements(nspec,nglob,ibool,mask_ibool,num_ibool,&
- np,nelement,&
- it,nee,num_node,prname,numpoin)
+ np,nelement, &
+ it,nee,numpoin)
implicit none
include 'constants.h'
@@ -630,14 +632,16 @@
integer,dimension(NGLLX,NGLLY,NGLLZ,nspec),intent(in) :: ibool
logical,dimension(nglob) :: mask_ibool
integer,dimension(nglob) :: num_ibool
- integer:: it,nee,num_node,np,nelement,numpoin
- character(len=150) :: prname
+ integer:: it,nee,np,nelement,numpoin
+ !character(len=256) :: prname
+ !integer :: num_node
+
! local parameters
- integer :: ios,ispec,i
+ integer :: ispec !,i,ios,njunk,njunk2
integer :: iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
- integer :: njunk, njunk2, n1, n2, n3, n4, n5, n6, n7, n8
- character(len=150) :: local_element_file
+ integer :: n1, n2, n3, n4, n5, n6, n7, n8
+ !character(len=256) :: local_element_file
! outputs total number of elements for all slices
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_arrays_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_arrays_source.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_arrays_source.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -197,7 +197,7 @@
integer icomp, itime, i, j, k, ios
double precision :: junk
character(len=3) :: comp(3)
- character(len=150) :: filename
+ character(len=256) :: filename
call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
@@ -412,6 +412,59 @@
end subroutine compute_adj_source_frechet
+! =======================================================================
+! compute array for acoustic source
+ subroutine compute_arrays_source_acoustic(xi_source,eta_source,gamma_source,&
+ sourcearray,xigll,yigll,zigll,factor_source)
+ implicit none
+ include "constants.h"
+
+ double precision :: xi_source,eta_source,gamma_source
+ real(kind=CUSTOM_REAL) :: factor_source
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+! local parameters
+! source arrays
+ double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
+ double precision, dimension(NGLLX) :: hxis,hpxis
+ double precision, dimension(NGLLY) :: hetas,hpetas
+ double precision, dimension(NGLLZ) :: hgammas,hpgammas
+ integer :: i,j,k
+
+! initializes
+ sourcearray(:,:,:,:) = 0._CUSTOM_REAL
+ sourcearrayd(:,:,:,:) = 0.d0
+
+! compute Lagrange polynomials at the source location
+ call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
+ call lagrange_any(eta_source,NGLLY,yigll,hetas,hpetas)
+ call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
+
+! calculates source array for interpolated location
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! identical source array components in x,y,z-direction
+ sourcearrayd(:,i,j,k) = hxis(i)*hetas(j)*hgammas(k)*dble(factor_source)
+ enddo
+ enddo
+ enddo
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ sourcearray(:,:,:,:) = sngl(sourcearrayd(:,:,:,:))
+ else
+ sourcearray(:,:,:,:) = sourcearrayd(:,:,:,:)
+ endif
+
+ end subroutine compute_arrays_source_acoustic
+
+
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -0,0 +1,712 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! acoustic solver
+
+! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
+! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
+! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
+!
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement is then:
+! u = grad(Chi) / rho
+! Velocity is then:
+! v = grad(Chi_dot) / rho
+! (Chi_dot being the time derivative of Chi)
+! and pressure is:
+! p = - Chi_dot_dot
+! (Chi_dot_dot being the time second derivative of Chi).
+!
+! The source in an acoustic element is a pressure source.
+!
+! First-order acoustic-acoustic discontinuities are also handled automatically
+! because pressure is continuous at such an interface, therefore Chi_dot_dot
+! is continuous, therefore Chi is also continuous, which is consistent with
+! the spectral-element basis functions and with the assembling process.
+! This is the reason why a simple displacement potential u = grad(Chi) would
+! not work because it would be discontinuous at such an interface and would
+! therefore not be consistent with the basis functions.
+
+
+subroutine compute_forces_acoustic()
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ implicit none
+
+ integer:: iphase
+ logical:: phase_is_inner
+
+! enforces free surface (zeroes potentials at free surface)
+ call compute_forces_acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool, &
+ free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ ispec_is_acoustic)
+
+! 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
+
+! acoustic pressure term
+ call compute_forces_acoustic_pressure( phase_is_inner, NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_dot_acoustic, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ rhostore,jacobian,ibool, &
+ ispec_is_inner, &
+ ispec_is_acoustic)
+
+! absorbing boundaries
+ if(ABSORBING_CONDITIONS) &
+ call compute_forces_acoustic_absorbing_boundaries(NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic,potential_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ rhostore,kappastore, &
+ ispec_is_acoustic)
+
+! elastic coupling
+ if(ELASTIC_SIMULATION ) &
+ call compute_forces_acoustic_coupling_elastic(NSPEC_AB,NGLOB_AB, &
+ ibool,displ,potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+
+! poroelastic coupling
+ if(POROELASTIC_SIMULATION ) &
+ call compute_forces_acoustic_coupling_poroelastic()
+
+! sources
+ call compute_forces_acoustic_sources(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0, &
+ sourcearrays,kappastore, &
+ ispec_is_acoustic)
+
+! assemble all the contributions between slices using MPI
+ if( phase_is_inner .eqv. .false. ) then
+ ! sends potential_dot_dot_acoustic values to corresponding MPI interface neighbors (non-blocking)
+ call assemble_MPI_scalar_ext_mesh_s(NPROC,NGLOB_AB,potential_dot_dot_acoustic, &
+ buffer_send_scalar_ext_mesh,buffer_recv_scalar_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)
+ else
+ ! waits for send/receive requests to be completed and assembles values
+ call assemble_MPI_scalar_ext_mesh_w(NPROC,NGLOB_AB,potential_dot_dot_acoustic, &
+ buffer_recv_scalar_ext_mesh,num_interfaces_ext_mesh,&
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+ endif
+
+ enddo
+
+! update pressure with mass
+ potential_dot_dot_acoustic(:) = potential_dot_dot_acoustic(:) * rmass_acoustic(:)
+
+! update velocity
+! note: Newark finite-difference time scheme with acoustic domains:
+! (see e.g. Hughes, 1987; Chaljub et al., 2003)
+!
+! chi(t+delta_t) = chi(t) + delta_t chi_dot(t) + 1/2 delta_t**2 chi_dot_dot(t)
+! chi_dot(t+delta_t) = chi_dot(t) + 1/2 delta_t chi_dot_dot(t) + 1/2 delta_t chi_dot_dot(t+delta_t)
+! chi_dot_dot(t+delta_t) = 1/M_acoustic( -K_acoustic chi(t+delta) + B_acoustic u(t+delta_t) + f(t+delta_t) )
+!
+! where
+! chi, chi_dot, chi_dot_dot are acoustic (fluid) potentials ( dotted with respect to time)
+! u, v, a are displacement,velocity & acceleration
+! M is mass matrix, K stiffness matrix and B boundary term
+! f denotes a source term
+!
+! corrector:
+! updates the chi_dot term which requires chi_dot_dot(t+delta)
+ potential_dot_acoustic(:) = potential_dot_acoustic(:) + deltatover2*potential_dot_dot_acoustic(:)
+
+! enforces free surface (zeroes potentials at free surface)
+ call compute_forces_acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool, &
+ free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ ispec_is_acoustic)
+
+end subroutine compute_forces_acoustic
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_forces_acoustic_pressure( phase_is_inner, NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_dot_acoustic, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ rhostore,jacobian,ibool, &
+ ispec_is_inner, &
+ ispec_is_acoustic )
+
+! compute forces for the acoustic elements
+!
+! note that pressure is defined as:
+! p = - Chi_dot_dot
+!
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! acoustic potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: &
+ potential_acoustic,potential_dot_dot_acoustic
+
+! 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) :: &
+ rhostore,jacobian
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+! local variables
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1,temp2,temp3
+ real(kind=CUSTOM_REAL) temp1l,temp2l,temp3l
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) rho_invl
+
+ integer :: ispec,iglob
+ integer :: i,j,k,l
+
+
+! loop over spectral elements
+ do ispec = 1,NSPEC_AB
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! density (reciproc)
+ rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
+
+ ! derivative along x, y, z
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the loops because NGLLX == NGLLY == NGLLZ
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l = 1,NGLLX
+ temp1l = temp1l + potential_acoustic(ibool(l,j,k,ispec))*hprime_xx(i,l)
+ temp2l = temp2l + potential_acoustic(ibool(i,l,k,ispec))*hprime_yy(j,l)
+ temp3l = temp3l + potential_acoustic(ibool(i,j,l,ispec))*hprime_zz(k,l)
+ enddo
+
+ ! get derivatives of potential with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ jacobianl = jacobian(i,j,k,ispec)
+
+ ! derivatives of potential
+ dpotentialdxl = xixl*temp1l + etaxl*temp2l + gammaxl*temp3l
+ dpotentialdyl = xiyl*temp1l + etayl*temp2l + gammayl*temp3l
+ dpotentialdzl = xizl*temp1l + etazl*temp2l + gammazl*temp3l
+
+ ! for acoustic medium
+ ! also add GLL integration weights
+ temp1(i,j,k) = rho_invl * wgllwgll_yz(j,k) * jacobianl* &
+ (xixl*dpotentialdxl + xiyl*dpotentialdyl + xizl*dpotentialdzl)
+ temp2(i,j,k) = rho_invl * wgllwgll_xz(i,k) * jacobianl* &
+ (etaxl*dpotentialdxl + etayl*dpotentialdyl + etazl*dpotentialdzl)
+ temp3(i,j,k) = rho_invl * wgllwgll_xy(i,j) * jacobianl* &
+ (gammaxl*dpotentialdxl + gammayl*dpotentialdyl + gammazl*dpotentialdzl)
+ enddo
+ enddo
+ enddo
+
+ ! second double-loop over GLL to compute all the terms
+ do k = 1,NGLLZ
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! along x,y,z direction
+ ! and assemble the contributions
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l=1,NGLLX
+ temp1l = temp1l + temp1(l,j,k) * hprimewgll_xx(l,i)
+ temp2l = temp2l + temp2(i,l,k) * hprimewgll_yy(l,j)
+ temp3l = temp3l + temp3(i,j,l) * hprimewgll_zz(l,k)
+ enddo
+
+ ! sum contributions from each element to the global values
+ iglob = ibool(i,j,k,ispec)
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - ( temp1l + temp2l + temp3l )
+
+ enddo
+ enddo
+ enddo
+
+ endif ! end of test if acoustic element
+ endif ! ispec_is_inner
+ enddo ! end of loop over all spectral elements
+
+end subroutine compute_forces_acoustic_pressure
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_forces_acoustic_absorbing_boundaries(NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic,potential_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ rhostore,kappastore, &
+ ispec_is_acoustic)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic,&
+ potential_dot_acoustic
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rhostore,kappastore
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+! absorbing boundary surface
+ integer :: num_abs_boundary_faces
+ real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ispec(num_abs_boundary_faces)
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: rhol,cpl,jacobianw !weight,jacobianl
+ integer :: ispec,iglob,i,j,k,iface,igll
+
+! absorbs absorbing-boundary surface using Stacey condition (Clayton & Enquist)
+ do iface=1,num_abs_boundary_faces
+
+ ispec = abs_boundary_ispec(iface)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! reference gll points on boundary face
+ do igll = 1,NGLLSQUARE
+
+ ! gets local indices for GLL point
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
+
+ ! gets global index
+ iglob=ibool(i,j,k,ispec)
+
+ ! determines bulk sound speed
+ rhol = rhostore(i,j,k,ispec)
+ cpl = sqrt( kappastore(i,j,k,ispec) / rhol )
+
+ ! gets associated, weighted jacobian
+ jacobianw = abs_boundary_jacobian2Dw(igll,iface)
+
+ ! Sommerfeld condition
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob) * jacobianw / cpl / rhol
+
+ enddo
+
+ endif ! ispec_is_acoustic
+ endif ! ispec_is_inner
+ enddo ! num_abs_boundary_faces
+
+end subroutine compute_forces_acoustic_absorbing_boundaries
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_forces_acoustic_coupling_elastic(NSPEC_AB,NGLOB_AB, &
+ ibool,displ,potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+
+! returns the updated pressure array: potential_dot_dot_acoustic
+
+ implicit none
+ include 'constants.h'
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and pressure
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+! global indexing
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! acoustic-elastic coupling surface
+ integer :: num_coupling_ac_el_faces
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ispec(num_coupling_ac_el_faces)
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n
+ real(kind=CUSTOM_REAL) :: nx,ny,nz,jacobianw
+
+ integer :: iface,igll,ispec,iglob
+ integer :: i,j,k
+
+! loops on all coupling faces
+ do iface = 1,num_coupling_ac_el_faces
+
+ ! gets corresponding elements
+ ! (note: can be either acoustic or elastic element, no need to specify since
+ ! no material properties are needed for this coupling term)
+ ispec = coupling_ac_el_ispec(iface)
+
+ if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
+
+ ! loops over common GLL points
+ do igll = 1, NGLLSQUARE
+ i = coupling_ac_el_ijk(1,igll,iface)
+ j = coupling_ac_el_ijk(2,igll,iface)
+ k = coupling_ac_el_ijk(3,igll,iface)
+
+ ! gets global index of this common GLL point
+ ! (note: should be the same as for corresponding i',j',k',ispec_elastic or ispec_acoustic)
+ iglob = ibool(i,j,k,ispec)
+
+ ! elastic displacement on global point
+ displ_x = displ(1,iglob)
+ displ_y = displ(2,iglob)
+ displ_z = displ(3,iglob)
+
+ ! gets associated normal on GLL point
+ ! (note convention: pointing outwards of acoustic element)
+ nx = coupling_ac_el_normal(1,igll,iface)
+ ny = coupling_ac_el_normal(2,igll,iface)
+ nz = coupling_ac_el_normal(3,igll,iface)
+
+ ! calculates displacement component along normal
+ ! (normal points outwards of acoustic element)
+ displ_n = displ_x*nx + displ_y*ny + displ_z*nz
+
+ ! gets associated, weighted jacobian
+ jacobianw = coupling_ac_el_jacobian2Dw(igll,iface)
+
+ ! continuity of pressure and normal displacement on global point
+ !
+ ! note: newark time scheme together with definition of scalar potential:
+ ! pressure = - chi_dot_dot
+ ! requires that this coupling term uses the updated displacement at time step [t+delta_t],
+ ! which is done at the very beginning of the time loop
+ ! (see e.g. Chaljub & Vilotte, Nissen-Meyer thesis...)
+ ! it also means you have to calculate and update this here first before
+ ! calculating the coupling on the elastic side for the acceleration...
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + jacobianw*displ_n
+
+ enddo ! igll
+
+ endif
+
+ enddo ! iface
+
+end subroutine compute_forces_acoustic_coupling_elastic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_forces_acoustic_coupling_poroelastic()
+ implicit none
+
+ stop 'not yet implemented'
+
+end subroutine compute_forces_acoustic_coupling_poroelastic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_forces_acoustic_sources(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0, &
+ sourcearrays,kappastore, &
+ ispec_is_acoustic)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: kappastore
+
+! 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(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
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+! local parameters
+ double precision :: t0,f0
+ double precision :: stf
+ real(kind=CUSTOM_REAL) stf_used
+ integer :: isource,iglob,ispec,i,j,k
+
+! adds acoustic sources
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec)
+
+ 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
+
+ ! gaussian source time function
+ !stf_used = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! 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.
+ stf_used = 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) )
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+ ! to add minus the source to Chi_dot_dot to get plus the source in pressure:
+
+ ! acoustic source for pressure gets divided by kappa
+ stf_used = stf_used / kappastore(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)),ispec)
+
+ ! source contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) - stf_used
+
+ else
+
+ ! gaussian source time
+ stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! distinguishes between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+ ! to add minus the source to Chi_dot_dot to get plus the source in pressure
+
+ ! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! adds source contribution
+ ! note: acoustic source for pressure gets divided by kappa
+ iglob = ibool(i,j,k,ispec)
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - sourcearrays(isource,1,i,j,k) * stf_used / kappastore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+ endif ! ispec_is_elastic
+ endif ! ispec_is_inner
+ endif ! myrank
+
+ enddo ! NSOURCES
+
+end subroutine compute_forces_acoustic_sources
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_forces_acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool, &
+ free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ ispec_is_acoustic)
+ implicit none
+ include 'constants.h'
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! acoustic potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! free surface
+ integer :: num_free_surface_faces
+ integer :: free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ispec(num_free_surface_faces)
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+! local parameters
+ integer :: iface,igll,i,j,k,ispec,iglob
+
+! enforce potentials to be zero at surface
+ do iface = 1, num_free_surface_faces
+
+ ispec = free_surface_ispec(iface)
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ do igll = 1, NGLLSQUARE
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+
+ ! sets potentials to zero
+ potential_acoustic(iglob) = 0._CUSTOM_REAL
+ potential_dot_acoustic(iglob) = 0._CUSTOM_REAL
+ potential_dot_dot_acoustic(iglob) = 0._CUSTOM_REAL
+ enddo
+ endif
+
+ enddo
+
+end subroutine compute_forces_acoustic_enforce_free_surface
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -28,7 +28,10 @@
subroutine compute_forces_elastic()
use specfem_par
+ use specfem_par_acoustic
use specfem_par_elastic
+ use specfem_par_poroelastic
+
implicit none
integer:: iphase
@@ -47,141 +50,149 @@
! 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, &
- ANISOTROPY,NSPEC_ANISO, &
- c11store,c12store,c13store,c14store,c15store,c16store,&
- c22store,c23store,c24store,c25store,c26store,c33store,&
- c34store,c35store,c36store,c44store,c45store,c46store,&
- c55store,c56store,c66store )
-
-
- !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)
+ 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, &
+ 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, &
+ ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store, &
+ ispec_is_elastic )
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, &
- ANISOTROPY,NSPEC_ANISO, &
- c11store,c12store,c13store,c14store,c15store,c16store,&
- c22store,c23store,c24store,c25store,c26store,c33store,&
- c34store,c35store,c36store,c44store,c45store,c46store,&
- c55store,c56store,c66store)
+ 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, &
+ ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store, &
+ ispec_is_elastic )
endif
! adds elastic absorbing boundary term to acceleration (Stacey conditions)
- if(ABSORBING_CONDITIONS) then
+ if(ABSORBING_CONDITIONS) &
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
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_normal,abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ veloc,rho_vp,rho_vs, &
+ ispec_is_elastic )
-! 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 )
+! acoustic coupling
+ if( ACOUSTIC_SIMULATION ) &
+ call compute_forces_elastic_coupling_acoustic(NSPEC_AB,NGLOB_AB, &
+ ibool,accel,potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+! poroelastic coupling
+ if( POROELASTIC_SIMULATION ) &
+ call compute_forces_elastic_coupling_poroelastic()
+! adds source term (single-force/moment-tensor solution)
+ call compute_forces_elastic_sources( 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, &
+ ispec_is_elastic )
+
! assemble all the contributions between slices using MPI
- if( phase_is_inner .eqv. .false. ) then
+ if( phase_is_inner .eqv. .false. ) then
+ ! sends accel values to corresponding MPI interface neighbors
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)
+ 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
+ ! waits for send/receive requests to be completed and assembles values
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)
+ 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
+
+ !! 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.
enddo
+
+! multiplies with inverse of mass matrix (note: rmass has been inverted already)
+ accel(1,:) = accel(1,:)*rmass(:)
+ accel(2,:) = accel(2,:)*rmass(:)
+ accel(3,:) = accel(3,:)*rmass(:)
-! 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
+ !! 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
+
+
+! updates acceleration with ocean load term
+ if(OCEANS) then
+ call compute_forces_elastic_ocean_load(NSPEC_AB,NGLOB_AB, &
+ ibool,rmass,rmass_ocean_load,accel, &
+ free_surface_normal,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces)
+ endif
+
+! updates velocities
+! Newark finite-difference time scheme with elastic domains:
+! (see e.g. Hughes, 1987; Chaljub et al., 2003)
!
-!! 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)
+! u(t+delta_t) = u(t) + delta_t v(t) + 1/2 delta_t**2 a(t)
+! v(t+delta_t) = v(t) + 1/2 delta_t a(t) + 1/2 delta_t a(t+delta_t)
+! a(t+delta_t) = 1/M_elastic ( -K_elastic u(t+delta) + B_elastic chi_dot_dot(t+delta_t) + f( t+delta_t) )
+!
+! where
+! u, v, a are displacement,velocity & acceleration
+! M is mass matrix, K stiffness matrix and B boundary term for acoustic/elastic domains
+! f denotes a source term (acoustic/elastic)
+! chi_dot_dot is acoustic (fluid) potential ( dotted twice with respect to time)
+!
+! corrector:
+! updates the velocity term which requires a(t+delta)
+ 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 compute_forces_elastic
@@ -192,11 +203,12 @@
! 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)
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_normal,abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ veloc,rho_vp,rho_vs, &
+ ispec_is_elastic)
implicit none
@@ -208,55 +220,22 @@
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
+ logical, dimension(NSPEC_AB) :: ispec_is_elastic
- 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
+! absorbing boundary surface
+ integer :: num_abs_boundary_faces
+ real(kind=CUSTOM_REAL) :: abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces)
+ real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ispec(num_abs_boundary_faces)
! local parameters
@@ -266,369 +245,173 @@
! absorbs absorbing-boundary surface using Stacey condition (Clayton & Enquist)
- do iface=1,num_absorbing_boundary_faces
+ do iface=1,num_abs_boundary_faces
- ispec = absorbing_boundary_ispec(iface)
+ ispec = abs_boundary_ispec(iface)
if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
- ! reference gll points on boundary face
- do igll = 1,NGLLSQUARE
+ if( ispec_is_elastic(ispec) ) 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 local indices for GLL point
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
- ! gets velocity
- iglob=ibool(i,j,k,ispec)
- vx=veloc(1,iglob)
- vy=veloc(2,iglob)
- vz=veloc(3,iglob)
+ ! 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)
+ ! gets associated normal
+ nx = abs_boundary_normal(1,igll,iface)
+ ny = abs_boundary_normal(2,igll,iface)
+ nz = abs_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)
+ ! 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
+ ! gets associated, weighted jacobian
+ jacobianw = abs_boundary_jacobian2Dw(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
+ endif ! ispec_is_elastic
+ endif ! ispec_is_inner
enddo
+
+end subroutine compute_forces_elastic_absorbing_boundaries
+
!
-!! 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)
+
+subroutine compute_forces_elastic_coupling_acoustic(NSPEC_AB,NGLOB_AB, &
+ ibool,accel,potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+
+! returns the updated acceleration array: accel
+
+ implicit none
+ include 'constants.h'
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and pressure
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+! global indexing
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! acoustic-elastic coupling surface
+ integer :: num_coupling_ac_el_faces
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ispec(num_coupling_ac_el_faces)
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: pressure
+ real(kind=CUSTOM_REAL) :: nx,ny,nz,jacobianw
+
+ integer :: iface,igll,ispec,iglob
+ integer :: i,j,k
+
+! loops on all coupling faces
+ do iface = 1,num_coupling_ac_el_faces
+
+ ! gets corresponding spectral element
+ ! (note: can be either acoustic or elastic element, no need to specify since
+ ! no material properties are needed for this coupling term)
+ ispec = coupling_ac_el_ispec(iface)
+
+ if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
+
+ ! loops over common GLL points
+ do igll = 1, NGLLSQUARE
+ i = coupling_ac_el_ijk(1,igll,iface)
+ j = coupling_ac_el_ijk(2,igll,iface)
+ k = coupling_ac_el_ijk(3,igll,iface)
+
+ ! gets global index of this common GLL point
+ ! (note: should be the same as for corresponding i',j',k',ispec_elastic or ispec_elastic )
+ iglob = ibool(i,j,k,ispec)
+
+ ! acoustic pressure on global point
+ pressure = - potential_dot_dot_acoustic(iglob)
+
+ ! gets associated normal on GLL point
+ ! (note convention: pointing outwards of acoustic element)
+ nx = coupling_ac_el_normal(1,igll,iface)
+ ny = coupling_ac_el_normal(2,igll,iface)
+ nz = coupling_ac_el_normal(3,igll,iface)
+
+ ! gets associated, weighted 2D jacobian
+ ! (note: should be the same for elastic and acoustic element)
+ jacobianw = coupling_ac_el_jacobian2Dw(igll,iface)
+
+ ! continuity of displacement and pressure on global point
+ !
+ ! note: newark time scheme together with definition of scalar potential:
+ ! pressure = - chi_dot_dot
+ ! requires that this coupling term uses the *UPDATED* pressure (chi_dot_dot), i.e.
+ ! pressure at time step [t + delta_t]
+ ! (see e.g. Chaljub & Vilotte, Nissen-Meyer thesis...)
+ ! it means you have to calculate and update the acoustic pressure first before
+ ! calculating this term...
+ accel(1,iglob) = accel(1,iglob) + jacobianw*nx*pressure
+ accel(2,iglob) = accel(2,iglob) + jacobianw*ny*pressure
+ accel(3,iglob) = accel(3,iglob) + jacobianw*nz*pressure
+
+ enddo ! igll
+
+ endif
+
+ enddo ! iface
+
+end subroutine compute_forces_elastic_coupling_acoustic
+
!
-! 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_coupling_poroelastic()
+ implicit none
+
+end subroutine compute_forces_elastic_coupling_poroelastic
+
!
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_elastic_source_term( NSPEC_AB,NGLOB_AB,accel, &
+subroutine compute_forces_elastic_sources( 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 )
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
+ ispec_is_elastic )
implicit none
@@ -656,70 +439,191 @@
real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
double precision, external :: comp_source_time_function
+
+ logical, dimension(NSPEC_AB) :: ispec_is_elastic
! local parameters
double precision :: t0,f0
double precision :: stf
real(kind=CUSTOM_REAL) stf_used
- integer :: isource,iglob,i,j,k
+ integer :: isource,iglob,i,j,k,ispec
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
+ ispec = ispec_selected_source(isource)
- 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))
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_elastic(ispec) ) then
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- stf_used = sngl(stf)
- else
- stf_used = stf
- endif
+ if(USE_FORCE_POINT_SOURCE) then
- ! 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
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ 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))
- endif ! USE_FORCE_POINT_SOURCE
+ ! 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)
+ accel(:,iglob) = accel(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+ endif ! ispec_is_elastic
endif ! ispec_is_inner
endif ! myrank
enddo ! NSOURCES
-end subroutine compute_forces_elastic_source_term
+end subroutine compute_forces_elastic_sources
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_forces_elastic_ocean_load(NSPEC_AB,NGLOB_AB, &
+ ibool,rmass,rmass_ocean_load,accel, &
+ free_surface_normal,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces)
+
+! updates acceleration with ocean load term:
+! approximates ocean-bottom continuity of pressure & displacement for longer period waves (> ~20s ),
+! assuming incompressible fluid column above bathymetry ocean bottom
+
+ implicit none
+
+ include 'constants.h'
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_AB),intent(inout) :: accel
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB),intent(in) :: rmass,rmass_ocean_load
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
+
+! free surface
+ integer :: num_free_surface_faces
+ real(kind=CUSTOM_REAL) :: free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ispec(num_free_surface_faces)
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: nx,ny,nz
+ real(kind=CUSTOM_REAL) :: additional_term,force_normal_comp
+ integer :: i,j,k,ispec,iglob
+ integer :: igll,iface
+ logical,dimension(NGLOB_AB) :: updated_dof_ocean_load
+
+! initialize the updates
+ updated_dof_ocean_load(:) = .false.
+
+! for surface elements exactly at the top of the model (ocean bottom)
+! do ispec2D = 1,NSPEC2D_TOP
+
+ do iface = 1,num_free_surface_faces
+
+!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
+
+! only for DOFs exactly at the top of the model (ocean bottom)
+! k = NGLLZ
+! do j = 1,NGLLY
+! do i = 1,NGLLX
+
+ ispec = free_surface_ispec(iface)
+ do igll = 1, NGLLSQUARE
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+
+! get global point number
+ iglob = ibool(i,j,k,ispec)
+
+! only update once
+ if(.not. updated_dof_ocean_load(iglob)) then
+
+ ! get normal
+ !! DK DK array not created yet for CUBIT nx = normal_top(1,i,j,ispec2D)
+ !! DK DK array not created yet for CUBIT ny = normal_top(2,i,j,ispec2D)
+ !! DK DK array not created yet for CUBIT nz = normal_top(3,i,j,ispec2D)
+ nx = free_surface_normal(1,igll,iface)
+ ny = free_surface_normal(2,igll,iface)
+ nz = free_surface_normal(3,igll,iface)
+
+! make updated component of right-hand side
+! we divide by rmass() which is 1 / M
+! we use the total force which includes the Coriolis term above
+ force_normal_comp = ( accel(1,iglob)*nx + &
+ accel(2,iglob)*ny + &
+ accel(3,iglob)*nz ) / rmass(iglob)
+
+ additional_term = (rmass_ocean_load(iglob) - rmass(iglob)) * force_normal_comp
+
+ accel(1,iglob) = accel(1,iglob) + additional_term * nx
+ accel(2,iglob) = accel(2,iglob) + additional_term * ny
+ accel(3,iglob) = accel(3,iglob) + additional_term * nz
+
+ !if (SIMULATION_TYPE == 3) then
+ !! DK DK array not created yet for CUBIT
+ ! b_force_normal_comp = (b_accel(1,iglob)*nx + &
+ ! b_accel(2,iglob)*ny + b_accel(3,iglob)*nz) / rmass(iglob)
+ ! b_additional_term = (rmass_ocean_load(iglob) - rmass(iglob)) * b_force_normal_comp
+ !! DK DK array not created yet for CUBIT
+ ! b_accel(1,iglob) = b_accel(1,iglob) + b_additional_term * nx
+ ! b_accel(2,iglob) = b_accel(2,iglob) + b_additional_term * ny
+ ! b_accel(3,iglob) = b_accel(3,iglob) + b_additional_term * nz
+ !endif
+
+ ! done with this point
+ updated_dof_ocean_load(iglob) = .true.
+
+ endif
+
+! enddo ! NGLLX
+! enddo ! NGLLY
+! enddo ! NSPEC2D_TOP
+
+ enddo ! igll
+ enddo ! iface
+
+end subroutine compute_forces_elastic_ocean_load
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -41,13 +41,13 @@
c11store,c12store,c13store,c14store,c15store,c16store,&
c22store,c23store,c24store,c25store,c26store,c33store,&
c34store,c35store,c36store,c44store,c45store,c46store,&
- c55store,c56store,c66store)
+ c55store,c56store,c66store, &
+ ispec_is_elastic )
! NSOURCES,myrank,islice_selected_source,&
! ispec_selected_source,xi_source,eta_source,&
! gamma_source,nu_source,hdur,dt)
-
implicit none
include "constants.h"
@@ -98,6 +98,8 @@
c34store,c35store,c36store,c44store,c45store,c46store, &
c55store,c56store,c66store
+ logical,dimension(NSPEC_AB) :: ispec_is_elastic
+
! source
! integer :: NSOURCES,myrank,it
! integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
@@ -152,391 +154,393 @@
if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
+ if( ispec_is_elastic(ispec) ) then
+
+ 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)
- 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
+ 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
- ! 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)
+ ! 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( 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)
+
endif
- ! use unrelaxed parameters if attenuation
- mul = mul * one_minus_sum_beta(iselected)
-
- endif
+ ! full anisotropic case, stress calculations
+ if(ANISOTROPY) then
+ c11 = c11store(i,j,k,ispec)
+ c12 = c12store(i,j,k,ispec)
+ c13 = c13store(i,j,k,ispec)
+ c14 = c14store(i,j,k,ispec)
+ c15 = c15store(i,j,k,ispec)
+ c16 = c16store(i,j,k,ispec)
+ c22 = c22store(i,j,k,ispec)
+ c23 = c23store(i,j,k,ispec)
+ c24 = c24store(i,j,k,ispec)
+ c25 = c25store(i,j,k,ispec)
+ c26 = c26store(i,j,k,ispec)
+ c33 = c33store(i,j,k,ispec)
+ c34 = c34store(i,j,k,ispec)
+ c35 = c35store(i,j,k,ispec)
+ c36 = c36store(i,j,k,ispec)
+ c44 = c44store(i,j,k,ispec)
+ c45 = c45store(i,j,k,ispec)
+ c46 = c46store(i,j,k,ispec)
+ c55 = c55store(i,j,k,ispec)
+ c56 = c56store(i,j,k,ispec)
+ c66 = c66store(i,j,k,ispec)
+ !if(ATTENUATION .and. not_fully_in_bedrock(ispec)) then
+ ! mul = c44
+ ! c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
+ ! c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
+ ! c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
+ ! c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c44 = c44 + minus_sum_beta * mul
+ ! c55 = c55 + minus_sum_beta * mul
+ ! c66 = c66 + minus_sum_beta * mul
+ !endif
-! full anisotropic case, stress calculations
- if(ANISOTROPY) then
- c11 = c11store(i,j,k,ispec)
- c12 = c12store(i,j,k,ispec)
- c13 = c13store(i,j,k,ispec)
- c14 = c14store(i,j,k,ispec)
- c15 = c15store(i,j,k,ispec)
- c16 = c16store(i,j,k,ispec)
- c22 = c22store(i,j,k,ispec)
- c23 = c23store(i,j,k,ispec)
- c24 = c24store(i,j,k,ispec)
- c25 = c25store(i,j,k,ispec)
- c26 = c26store(i,j,k,ispec)
- c33 = c33store(i,j,k,ispec)
- c34 = c34store(i,j,k,ispec)
- c35 = c35store(i,j,k,ispec)
- c36 = c36store(i,j,k,ispec)
- c44 = c44store(i,j,k,ispec)
- c45 = c45store(i,j,k,ispec)
- c46 = c46store(i,j,k,ispec)
- c55 = c55store(i,j,k,ispec)
- c56 = c56store(i,j,k,ispec)
- c66 = c66store(i,j,k,ispec)
- !if(ATTENUATION .and. not_fully_in_bedrock(ispec)) then
- ! mul = c44
- ! c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
- ! c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
- ! c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
- ! c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
- ! c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
- ! c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
- ! c44 = c44 + minus_sum_beta * mul
- ! c55 = c55 + minus_sum_beta * mul
- ! c66 = c66 + minus_sum_beta * mul
- !endif
+ sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
+ c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
+ sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
+ c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
+ sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
+ c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
+ sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
+ c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
+ sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
+ c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
+ sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
+ c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
- sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
- c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
- sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
- c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
- sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
- c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
- sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
- c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
- sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
- c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
- sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
- c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
+ !if (SIMULATION_TYPE == 3) then
+ ! b_sigma_xx = c11*b_duxdxl + c16*b_duxdyl_plus_duydxl + c12*b_duydyl + &
+ ! c15*b_duzdxl_plus_duxdzl + c14*b_duzdyl_plus_duydzl + c13*b_duzdzl
+ ! b_sigma_yy = c12*b_duxdxl + c26*b_duxdyl_plus_duydxl + c22*b_duydyl + &
+ ! c25*b_duzdxl_plus_duxdzl + c24*b_duzdyl_plus_duydzl + c23*b_duzdzl
+ ! b_sigma_zz = c13*b_duxdxl + c36*b_duxdyl_plus_duydxl + c23*b_duydyl + &
+ ! c35*b_duzdxl_plus_duxdzl + c34*b_duzdyl_plus_duydzl + c33*b_duzdzl
+ ! b_sigma_xy = c16*b_duxdxl + c66*b_duxdyl_plus_duydxl + c26*b_duydyl + &
+ ! c56*b_duzdxl_plus_duxdzl + c46*b_duzdyl_plus_duydzl + c36*b_duzdzl
+ ! b_sigma_xz = c15*b_duxdxl + c56*b_duxdyl_plus_duydxl + c25*b_duydyl + &
+ ! c55*b_duzdxl_plus_duxdzl + c45*b_duzdyl_plus_duydzl + c35*b_duzdzl
+ ! b_sigma_yz = c14*b_duxdxl + c46*b_duxdyl_plus_duydxl + c24*b_duydyl + &
+ ! c45*b_duzdxl_plus_duxdzl + c44*b_duzdyl_plus_duydzl + c34*b_duzdzl
+ !endif
+ else
- !if (SIMULATION_TYPE == 3) then
- ! b_sigma_xx = c11*b_duxdxl + c16*b_duxdyl_plus_duydxl + c12*b_duydyl + &
- ! c15*b_duzdxl_plus_duxdzl + c14*b_duzdyl_plus_duydzl + c13*b_duzdzl
- ! b_sigma_yy = c12*b_duxdxl + c26*b_duxdyl_plus_duydxl + c22*b_duydyl + &
- ! c25*b_duzdxl_plus_duxdzl + c24*b_duzdyl_plus_duydzl + c23*b_duzdzl
- ! b_sigma_zz = c13*b_duxdxl + c36*b_duxdyl_plus_duydxl + c23*b_duydyl + &
- ! c35*b_duzdxl_plus_duxdzl + c34*b_duzdyl_plus_duydzl + c33*b_duzdzl
- ! b_sigma_xy = c16*b_duxdxl + c66*b_duxdyl_plus_duydxl + c26*b_duydyl + &
- ! c56*b_duzdxl_plus_duxdzl + c46*b_duzdyl_plus_duydzl + c36*b_duzdzl
- ! b_sigma_xz = c15*b_duxdxl + c56*b_duxdyl_plus_duydxl + c25*b_duydyl + &
- ! c55*b_duzdxl_plus_duxdzl + c45*b_duzdyl_plus_duydzl + c35*b_duzdzl
- ! b_sigma_yz = c14*b_duxdxl + c46*b_duxdyl_plus_duydxl + c24*b_duydyl + &
- ! c45*b_duzdxl_plus_duxdzl + c44*b_duzdyl_plus_duydzl + c34*b_duzdzl
- !endif
- else
+ ! isotropic case
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
-! isotropic case
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
+ ! 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
- ! 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
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
+ !if (SIMULATION_TYPE == 3) then
+ ! b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
+ ! b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
+ ! b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
+ !
+ ! b_sigma_xy = mul*b_duxdyl_plus_duydxl
+ ! b_sigma_xz = mul*b_duzdxl_plus_duxdzl
+ ! b_sigma_yz = mul*b_duzdyl_plus_duydzl
+ !endif
- !if (SIMULATION_TYPE == 3) then
- ! b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
- ! b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
- ! b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
- !
- ! b_sigma_xy = mul*b_duxdyl_plus_duydxl
- ! b_sigma_xz = mul*b_duzdxl_plus_duxdzl
- ! b_sigma_yz = mul*b_duzdyl_plus_duydzl
- !endif
+ endif ! ANISOTROPY
- endif ! ANISOTROPY
+ ! 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
- ! 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)
- ! 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)
- 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)
- 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)
- ! 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
+ ! 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
- 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
+ ! 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( 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
- ! term in zz not computed since zero trace
+ ! 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 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
+ ! 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
- ! 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
+ ! 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
- enddo ! end of loop on memory variables
+ enddo ! end of loop on memory variables
- endif ! end attenuation
+ endif ! end attenuation
+ enddo
enddo
enddo
- enddo
- ! 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
-
+ ! 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
+ endif ! ispec_is_elastic
endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
enddo ! spectral element loop
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -42,15 +42,14 @@
c11store,c12store,c13store,c14store,c15store,c16store,&
c22store,c23store,c24store,c25store,c26store,c33store,&
c34store,c35store,c36store,c44store,c45store,c46store,&
- c55store,c56store,c66store )
+ c55store,c56store,c66store, &
+ ispec_is_elastic )
! computes elastic tensor term
implicit none
include "constants.h"
-! include values created by the mesher
-! include "OUTPUT_FILES/values_from_mesher.h"
integer :: NSPEC_AB,NGLOB_AB
@@ -96,6 +95,8 @@
c34store,c35store,c36store,c44store,c45store,c46store, &
c55store,c56store,c66store
+ logical,dimension(NSPEC_AB) :: ispec_is_elastic
+
! 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
@@ -167,497 +168,500 @@
if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- dummyx_loc(i,j,k) = displ(1,iglob)
- dummyy_loc(i,j,k) = displ(2,iglob)
- dummyz_loc(i,j,k) = displ(3,iglob)
+ if( ispec_is_elastic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+ enddo
enddo
enddo
- enddo
- ! subroutines adapted from Deville, Fischer and Mund, High-order methods
- ! 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) + &
- 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)
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! 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) + &
+ 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) + &
- 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)
+ 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) + &
- 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)
+ 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
- ! 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) + &
- 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)
+ ! 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
+ ! 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) + &
+ 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) + &
- 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)
+ 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) + &
- 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)
+ 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) + &
- 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)
+ ! 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) + &
+ 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) + &
- 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)
+ 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) + &
- 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)
+ 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
- do i=1,NGLLX
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
- ! 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*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
- duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
- duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
+ duxdxl = xixl*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
+ duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
+ duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
- duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
- duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
- duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
+ duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
+ duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
+ duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
- duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
- duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
- duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
+ duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
+ duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
+ duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
-! 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)
-! attenuation
- 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
+ ! attenuation
+ 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
- ! 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)
+ ! 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( 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)
+
endif
- ! use unrelaxed parameters if attenuation
- mul = mul * one_minus_sum_beta(iselected)
-
- endif
+ ! full anisotropic case, stress calculations
+ if(ANISOTROPY) then
+ c11 = c11store(i,j,k,ispec)
+ c12 = c12store(i,j,k,ispec)
+ c13 = c13store(i,j,k,ispec)
+ c14 = c14store(i,j,k,ispec)
+ c15 = c15store(i,j,k,ispec)
+ c16 = c16store(i,j,k,ispec)
+ c22 = c22store(i,j,k,ispec)
+ c23 = c23store(i,j,k,ispec)
+ c24 = c24store(i,j,k,ispec)
+ c25 = c25store(i,j,k,ispec)
+ c26 = c26store(i,j,k,ispec)
+ c33 = c33store(i,j,k,ispec)
+ c34 = c34store(i,j,k,ispec)
+ c35 = c35store(i,j,k,ispec)
+ c36 = c36store(i,j,k,ispec)
+ c44 = c44store(i,j,k,ispec)
+ c45 = c45store(i,j,k,ispec)
+ c46 = c46store(i,j,k,ispec)
+ c55 = c55store(i,j,k,ispec)
+ c56 = c56store(i,j,k,ispec)
+ c66 = c66store(i,j,k,ispec)
+ !if(ATTENUATION .and. not_fully_in_bedrock(ispec)) then
+ ! mul = c44
+ ! c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
+ ! c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
+ ! c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
+ ! c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c44 = c44 + minus_sum_beta * mul
+ ! c55 = c55 + minus_sum_beta * mul
+ ! c66 = c66 + minus_sum_beta * mul
+ !endif
-! full anisotropic case, stress calculations
- if(ANISOTROPY) then
- c11 = c11store(i,j,k,ispec)
- c12 = c12store(i,j,k,ispec)
- c13 = c13store(i,j,k,ispec)
- c14 = c14store(i,j,k,ispec)
- c15 = c15store(i,j,k,ispec)
- c16 = c16store(i,j,k,ispec)
- c22 = c22store(i,j,k,ispec)
- c23 = c23store(i,j,k,ispec)
- c24 = c24store(i,j,k,ispec)
- c25 = c25store(i,j,k,ispec)
- c26 = c26store(i,j,k,ispec)
- c33 = c33store(i,j,k,ispec)
- c34 = c34store(i,j,k,ispec)
- c35 = c35store(i,j,k,ispec)
- c36 = c36store(i,j,k,ispec)
- c44 = c44store(i,j,k,ispec)
- c45 = c45store(i,j,k,ispec)
- c46 = c46store(i,j,k,ispec)
- c55 = c55store(i,j,k,ispec)
- c56 = c56store(i,j,k,ispec)
- c66 = c66store(i,j,k,ispec)
- !if(ATTENUATION .and. not_fully_in_bedrock(ispec)) then
- ! mul = c44
- ! c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
- ! c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
- ! c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
- ! c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
- ! c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
- ! c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
- ! c44 = c44 + minus_sum_beta * mul
- ! c55 = c55 + minus_sum_beta * mul
- ! c66 = c66 + minus_sum_beta * mul
- !endif
+ sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
+ c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
+ sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
+ c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
+ sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
+ c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
+ sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
+ c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
+ sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
+ c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
+ sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
+ c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
- sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
- c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
- sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
- c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
- sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
- c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
- sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
- c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
- sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
- c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
- sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
- c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
+ !if (SIMULATION_TYPE == 3) then
+ ! b_sigma_xx = c11*b_duxdxl + c16*b_duxdyl_plus_duydxl + c12*b_duydyl + &
+ ! c15*b_duzdxl_plus_duxdzl + c14*b_duzdyl_plus_duydzl + c13*b_duzdzl
+ ! b_sigma_yy = c12*b_duxdxl + c26*b_duxdyl_plus_duydxl + c22*b_duydyl + &
+ ! c25*b_duzdxl_plus_duxdzl + c24*b_duzdyl_plus_duydzl + c23*b_duzdzl
+ ! b_sigma_zz = c13*b_duxdxl + c36*b_duxdyl_plus_duydxl + c23*b_duydyl + &
+ ! c35*b_duzdxl_plus_duxdzl + c34*b_duzdyl_plus_duydzl + c33*b_duzdzl
+ ! b_sigma_xy = c16*b_duxdxl + c66*b_duxdyl_plus_duydxl + c26*b_duydyl + &
+ ! c56*b_duzdxl_plus_duxdzl + c46*b_duzdyl_plus_duydzl + c36*b_duzdzl
+ ! b_sigma_xz = c15*b_duxdxl + c56*b_duxdyl_plus_duydxl + c25*b_duydyl + &
+ ! c55*b_duzdxl_plus_duxdzl + c45*b_duzdyl_plus_duydzl + c35*b_duzdzl
+ ! b_sigma_yz = c14*b_duxdxl + c46*b_duxdyl_plus_duydxl + c24*b_duydyl + &
+ ! c45*b_duzdxl_plus_duxdzl + c44*b_duzdyl_plus_duydzl + c34*b_duzdzl
+ !endif
+ else
- !if (SIMULATION_TYPE == 3) then
- ! b_sigma_xx = c11*b_duxdxl + c16*b_duxdyl_plus_duydxl + c12*b_duydyl + &
- ! c15*b_duzdxl_plus_duxdzl + c14*b_duzdyl_plus_duydzl + c13*b_duzdzl
- ! b_sigma_yy = c12*b_duxdxl + c26*b_duxdyl_plus_duydxl + c22*b_duydyl + &
- ! c25*b_duzdxl_plus_duxdzl + c24*b_duzdyl_plus_duydzl + c23*b_duzdzl
- ! b_sigma_zz = c13*b_duxdxl + c36*b_duxdyl_plus_duydxl + c23*b_duydyl + &
- ! c35*b_duzdxl_plus_duxdzl + c34*b_duzdyl_plus_duydzl + c33*b_duzdzl
- ! b_sigma_xy = c16*b_duxdxl + c66*b_duxdyl_plus_duydxl + c26*b_duydyl + &
- ! c56*b_duzdxl_plus_duxdzl + c46*b_duzdyl_plus_duydzl + c36*b_duzdzl
- ! b_sigma_xz = c15*b_duxdxl + c56*b_duxdyl_plus_duydxl + c25*b_duydyl + &
- ! c55*b_duzdxl_plus_duxdzl + c45*b_duzdyl_plus_duydzl + c35*b_duzdzl
- ! b_sigma_yz = c14*b_duxdxl + c46*b_duxdyl_plus_duydxl + c24*b_duydyl + &
- ! c45*b_duzdxl_plus_duxdzl + c44*b_duzdyl_plus_duydzl + c34*b_duzdzl
- !endif
- else
+ ! isotropic case
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
-! isotropic case
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
+ ! 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
- ! 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
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
+ !if (SIMULATION_TYPE == 3) then
+ ! b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
+ ! b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
+ ! b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
+ !
+ ! b_sigma_xy = mul*b_duxdyl_plus_duydxl
+ ! b_sigma_xz = mul*b_duzdxl_plus_duxdzl
+ ! b_sigma_yz = mul*b_duzdyl_plus_duydzl
+ !endif
- !if (SIMULATION_TYPE == 3) then
- ! b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
- ! b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
- ! b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
- !
- ! b_sigma_xy = mul*b_duxdyl_plus_duydxl
- ! b_sigma_xz = mul*b_duzdxl_plus_duxdzl
- ! b_sigma_yz = mul*b_duzdyl_plus_duydzl
- !endif
+ endif ! ANISOTROPY
+
+ ! 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
+
+ !if (SIMULATION_TYPE == 3) then
+ ! b_R_xx_val = b_R_xx(i,j,k,ispec,i_sls)
+ ! b_R_yy_val = b_R_yy(i,j,k,ispec,i_sls)
+ ! b_sigma_xx = b_sigma_xx - b_R_xx_val
+ ! b_sigma_yy = b_sigma_yy - b_R_yy_val
+ ! b_sigma_zz = b_sigma_zz + b_R_xx_val + b_R_yy_val
+ ! b_sigma_xy = b_sigma_xy - b_R_xy(i,j,k,ispec,i_sls)
+ ! b_sigma_xz = b_sigma_xz - b_R_xz(i,j,k,ispec,i_sls)
+ ! b_sigma_yz = b_sigma_yz - b_R_yz(i,j,k,ispec,i_sls)
+ !endif
+ 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)
- endif ! ANISOTROPY
-
- ! 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
-
- !if (SIMULATION_TYPE == 3) then
- ! b_R_xx_val = b_R_xx(i,j,k,ispec,i_sls)
- ! b_R_yy_val = b_R_yy(i,j,k,ispec,i_sls)
- ! b_sigma_xx = b_sigma_xx - b_R_xx_val
- ! b_sigma_yy = b_sigma_yy - b_R_yy_val
- ! b_sigma_zz = b_sigma_zz + b_R_xx_val + b_R_yy_val
- ! b_sigma_xy = b_sigma_xy - b_R_xy(i,j,k,ispec,i_sls)
- ! b_sigma_xz = b_sigma_xz - b_R_xz(i,j,k,ispec,i_sls)
- ! b_sigma_yz = b_sigma_yz - b_R_yz(i,j,k,ispec,i_sls)
- !endif
- 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)
- 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)
- 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
- ! subroutines adapted from Deville, Fischer and Mund, High-order methods
- ! 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) + &
- 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)
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! 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) + &
+ 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) + &
- 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)
+ 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) + &
- 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)
+ 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
- ! 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) + &
- 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)
+ ! 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
+ ! 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) + &
+ 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) + &
- 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)
+ 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) + &
- 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)
+ 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) + &
- 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)
+ ! 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) + &
+ 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) + &
- 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)
+ 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) + &
- 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)
+ 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
- do i=1,NGLLX
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
- 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 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)
+ ! 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)
- ! 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
+ ! 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
- 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
+ ! 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( 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
- ! term in zz not computed since zero trace
+ ! 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 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
+ ! 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
- ! 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
+ ! 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
- enddo ! end of loop on memory variables
+ enddo ! end of loop on memory variables
- endif ! end attenuation
+ endif ! end attenuation
+ enddo
enddo
enddo
- enddo
- ! 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
+ ! 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
+ endif ! ispec_is_elastic
+
endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
enddo ! spectral element loop
@@ -941,7 +945,7 @@
! ! 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 )
+! call get_attenuation_model_olsen( vs_val, iselected )
! else
! ! iflag from (CUBIT) mesh
! iselected = iflag_attenuation_store(i,j,k,ispec)
@@ -1119,7 +1123,7 @@
! ! 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 )
+! call get_attenuation_model_olsen( vs_val, iselected )
! else
! iselected = iflag_attenuation_store(i,j,k,ispec)
! endif
@@ -1366,9 +1370,9 @@
! 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, &
+! abs_boundary_normal,abs_boundary_jacobian2Dw, &
+! abs_boundary_ijk,abs_boundary_ispec, &
+! num_abs_boundary_faces, &
! veloc,rho_vp,rho_vs)
!
! implicit none
@@ -1457,11 +1461,11 @@
!! 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
+! integer :: num_abs_boundary_faces
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLSQUARE,num_abs_boundary_faces) :: abs_boundary_normal
+! real(kind=CUSTOM_REAL), dimension(NGLLSQUARE,num_abs_boundary_faces) :: abs_boundary_jacobian2Dw
+! integer, dimension(3,NGLLSQUARE,num_abs_boundary_faces) :: abs_boundary_ijk
+! integer, dimension(num_abs_boundary_faces) :: abs_boundary_ispec
!
!
!! computes elastic stiffness term
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -0,0 +1,112 @@
+!=====================================================================
+!
+! 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 compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ scalar_field, vector_field_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+
+! calculates gradient of given acoustic scalar (potential) field on all GLL points in one, single element
+! note:
+! displacement s = (rho)^{-1} \del \chi
+! velocity v = (rho)^{-1} \del \ddot \chi
+! returns: gradient vector field (vector_field_element) in specified element
+
+ implicit none
+ include 'constants.h'
+
+ integer,intent(in) :: ispec,NSPEC_AB,NGLOB_AB
+
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB),intent(in) :: scalar_field
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ),intent(out) :: vector_field_element
+
+ 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) :: rhostore
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local parameters
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
+ real(kind=CUSTOM_REAL) temp1l,temp2l,temp3l
+ real(kind=CUSTOM_REAL) rho_invl
+ integer :: i,j,k,l
+
+! double loop over GLL points to compute and store gradients
+ vector_field_element(:,:,:,:) = 0._CUSTOM_REAL
+
+ do k= 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ ! derivative along x
+ temp1l = ZERO
+ do l = 1,NGLLX
+ temp1l = temp1l + scalar_field(ibool(l,j,k,ispec))*hprime_xx(i,l)
+ enddo
+
+ ! derivative along y
+ temp2l = ZERO
+ do l = 1,NGLLZ
+ temp2l = temp2l + scalar_field(ibool(i,l,k,ispec))*hprime_yy(j,l)
+ enddo
+
+ ! derivative along z
+ temp3l = ZERO
+ do l = 1,NGLLZ
+ temp3l = temp3l + scalar_field(ibool(i,j,l,ispec))*hprime_zz(k,l)
+ enddo
+
+ 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)
+
+ rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
+
+ ! derivatives of acoustic scalar potential field on GLL points
+ vector_field_element(1,i,j,k) = (temp1l*xixl + temp2l*etaxl + temp3l*gammaxl) * rho_invl
+ vector_field_element(2,i,j,k) = (temp1l*xiyl + temp2l*etayl + temp3l*gammayl) * rho_invl
+ vector_field_element(3,i,j,k) = (temp1l*xizl + temp2l*etazl + temp3l*gammazl) * rho_invl
+
+ enddo
+ enddo
+ enddo
+
+end subroutine compute_gradient
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in 2009-11-21 02:18:44 UTC (rev 16023)
@@ -111,7 +111,7 @@
! the scratch disk to save the state variables saved in the forward
! simulation, this can be a global scratch disk in case you run out of
! space on the local scratch disk
- character(len=150), parameter :: LOCAL_PATH_Q = '/ibrixfs1/scratch/lqy/DATABASES_MPI_Q/'
+ character(len=256), parameter :: LOCAL_PATH_Q = '/ibrixfs1/scratch/lqy/DATABASES_MPI_Q/'
!------------------------------------------------------
! nlegoff -- Variables that should be read/computed elsewhere.
@@ -140,6 +140,12 @@
logical, parameter :: EXTERNAL_MESH_MOVIE_SURFACE = .false.
logical, parameter :: EXTERNAL_MESH_CREATE_SHAKEMAP = .false.
+! plots cross-section planes instead of model surface
+ logical, parameter :: PLOT_CROSS_SECTIONS = .false.
+ real(kind=CUSTOM_REAL),parameter :: CROSS_SECTION_X = 67000.0
+ real(kind=CUSTOM_REAL),parameter :: CROSS_SECTION_Y = 65500.0
+ real(kind=CUSTOM_REAL),parameter :: CROSS_SECTION_Z = -30000.0
+
! number of nodes per element as provided by the external mesh
integer, parameter :: ESIZE = 8
@@ -213,9 +219,6 @@
integer, parameter :: IANISOTROPY_MODEL1 = 1
integer, parameter :: IANISOTROPY_MODEL2 = 2
-! flag for projection from latitude/longitude to UTM, and back
- integer, parameter :: ILONGLAT2UTM = 0, IUTM2LONGLAT = 1
-
! smallest real number on the Pentium and the SGI = 1.1754944E-38
! largest real number on the Pentium and the SGI = 3.4028235E+38
! small negligible initial value to avoid very slow underflow trapping
@@ -247,19 +250,36 @@
double precision, parameter :: DEGREES_PER_CELL_TOPO_SOCAL = 5.d0 / 1000.d0
character(len=100), parameter :: TOPO_FILE_SOCAL = 'DATA/la_topography/topo_bathy_final.dat'
+! ! size of topography and bathymetry file for Piero Basini's model
+! integer, parameter :: NX_TOPO = 787, NY_TOPO = 793
+! double precision, parameter :: ORIG_LAT_TOPO = -102352.d0
+! double precision, parameter :: ORIG_LONG_TOPO = 729806.d0
+! ! for Piero Basini's model this is the resolution in meters of the topo file
+! double precision, parameter :: DEGREES_PER_CELL_TOPO = 250.d0
+! character(len=256), parameter :: TOPO_FILE = 'DATA/piero_model/dem_EV_UTM_regular_250_reordered.dat'
+! flag for projection from latitude/longitude to UTM, and back
+ integer, parameter :: ILONGLAT2UTM = 0, IUTM2LONGLAT = 1
+
+! minimum thickness in meters to include the effect of the oceans
+! to avoid taking into account spurious oscillations in topography model
+ double precision, parameter :: MINIMUM_THICKNESS_3D_OCEANS = 10.d0
+! density of sea water
+ real(kind=CUSTOM_REAL), parameter :: RHO_OCEANS = 1020.0
+
+! material domain ids
+ integer, parameter :: IDOMAIN_ACOUSTIC = 1
+ integer, parameter :: IDOMAIN_ELASTIC = 2
+ integer, parameter :: IDOMAIN_POROELASTIC = 3
+
+
+
! unused parameters
! -----------------
! apply heuristic rule to modify doubling regions to balance angles -- not used anywhere
! logical, parameter :: APPLY_HEURISTIC_RULE = .true.
!
-! minimum thickness in meters to include the effect of the oceans -- not used anywhere
-! to avoid taking into account spurious oscillations in topography model
-! double precision, parameter :: MINIMUM_THICKNESS_3D_OCEANS = 10.d0
!
-! density of sea water -- not used anywhere
-! real(kind=CUSTOM_REAL), parameter :: RHO_OCEANS = 1020.0
-!
! deltat -- obsolete, DT set in Par_file
! double precision, parameter :: DT_ext_mesh = 0.001d0
!
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -51,7 +51,7 @@
USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
- character(len=150) LOCAL_PATH,HEADER_FILE
+ character(len=256) LOCAL_PATH,HEADER_FILE
! ************** PROGRAM STARTS HERE **************
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-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -62,7 +62,7 @@
double precision min_field_current,max_field_current,max_absol
- character(len=150) outputname
+ character(len=256) outputname
integer iproc,ipoin
@@ -105,8 +105,8 @@
logical ABSORBING_CONDITIONS,SAVE_FORWARD
logical ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
- character(len=150) OUTPUT_FILES,LOCAL_PATH
-! character(len=150) MODEL
+ character(len=256) OUTPUT_FILES,LOCAL_PATH
+! character(len=256) MODEL
! parameters deduced from parameters read from file
integer NPROC
@@ -246,37 +246,39 @@
plot_shaking_map = .false.
print *,'enter first time step of movie (e.g. 1, enter -1 for shaking map)'
read(5,*) it1
+
+ if(it1 == 0 ) it1 = 1
if(it1 == -1) plot_shaking_map = .true.
-
+
if(.not. plot_shaking_map) then
- print *,'enter last time step of movie (e.g. ',NSTEP,')'
- read(5,*) it2
+ print *,'enter last time step of movie (e.g. ',NSTEP,')'
+ read(5,*) it2
- print *
- print *,'1 = define file names using frame number'
- print *,'2 = define file names using time step number'
- print *,'any other value = exit'
- print *
- print *,'enter value:'
- read(5,*) inumber
- if(inumber<1 .or. inumber>2) stop 'exiting...'
+ print *
+ print *,'1 = define file names using frame number'
+ print *,'2 = define file names using time step number'
+ print *,'any other value = exit'
+ print *
+ print *,'enter value:'
+ read(5,*) inumber
+ if(inumber<1 .or. inumber>2) stop 'exiting...'
- print *
- print *,'looping from ',it1,' to ',it2,' every ',NTSTEP_BETWEEN_FRAMES,' time steps'
+ print *
+ print *,'looping from ',it1,' to ',it2,' every ',NTSTEP_BETWEEN_FRAMES,' time steps'
-! count number of movie frames
- nframes = 0
- do it = it1,it2
- if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) nframes = nframes + 1
- enddo
- print *
- print *,'total number of frames will be ',nframes
- if(nframes == 0) stop 'null number of frames'
+ ! count number of movie frames
+ nframes = 0
+ do it = it1,it2
+ if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) nframes = nframes + 1
+ enddo
+ print *
+ print *,'total number of frames will be ',nframes
+ if(nframes == 0) stop 'null number of frames'
else
-! only one frame if shaking map
+ ! only one frame if shaking map
nframes = 1
it1 = 1
it2 = 1
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_name_database.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_name_database.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_name_database.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -32,7 +32,7 @@
integer iproc
! name of the database file
- character(len=150) prname,procname,LOCAL_PATH,clean_LOCAL_PATH
+ character(len=256) prname,procname,LOCAL_PATH,clean_LOCAL_PATH
! create the name for the database of the current slide and region
write(procname,"('/proc',i6.6,'_')") iproc
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -24,30 +24,120 @@
!=====================================================================
- subroutine create_regions_mesh_ext_mesh(ibool, &
- xstore,ystore,zstore,nspec,npointot,myrank,LOCAL_PATH, &
- nnodes_ext_mesh,nelmnts_ext_mesh, &
- 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, &
- 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, &
- 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, &
- SAVE_MESH_FILES,nglob, &
- ANISOTROPY)
+module create_regions_mesh_ext_par
+ include 'constants.h'
+
+! global point coordinates
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore_dummy
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: ystore_dummy
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: zstore_dummy
+
+! Gauss-Lobatto-Legendre points and weights of integration
+ double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
+
+! 3D shape functions and their derivatives
+ double precision, dimension(:,:,:,:), allocatable :: shape3D
+ double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
+
+ double precision, dimension(:), allocatable :: xelm,yelm,zelm
+
+! arrays with mesh parameters
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore,jacobianstore
+
+! for model density, kappa, mu
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,kappastore,mustore !,vpstore,vsstore
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass,rmass_acoustic,&
+ rmass_solid_poroelastic,rmass_fluid_poroelastic
+
+! ocean load
+ integer :: NGLOB_OCEAN
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
+
+! attenuation
+ integer, dimension(:,:,:,:), allocatable :: iflag_attenuation_store
+
+! 2D shape functions and their derivatives, weights
+ double precision, dimension(:,:,:), allocatable :: shape2D_x,shape2D_y,shape2D_bottom,shape2D_top
+ double precision, dimension(:,:,:,:), allocatable :: dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top
+ double precision, dimension(:,:), allocatable :: wgllwgll_xy,wgllwgll_xz,wgllwgll_yz
+
+! absorbing boundary arrays (for all boundaries) - keeps all infos, allowing for irregular surfaces
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: abs_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: abs_boundary_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: abs_boundary_ijk
+ integer, dimension(:), allocatable :: abs_boundary_ispec
+ integer :: num_abs_boundary_faces
+
+! free surface arrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: free_surface_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: free_surface_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: free_surface_ijk
+ integer, dimension(:), allocatable :: free_surface_ispec
+ integer :: num_free_surface_faces
+
+! acoustic-elastic coupling surface
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: coupling_ac_el_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: coupling_ac_el_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: coupling_ac_el_ijk
+ integer, dimension(:), allocatable :: coupling_ac_el_ispec
+ integer :: num_coupling_ac_el_faces
+
+! for stacey
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
+
+! anisotropy
+ integer :: NSPEC_ANISO
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store
+
+! material domain flags
+ logical, dimension(:), allocatable :: ispec_is_acoustic,ispec_is_elastic,ispec_is_poroelastic
+
+! name of the database file
+ character(len=256) prname
+
+end module create_regions_mesh_ext_par
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! main routine
+
+subroutine create_regions_mesh_ext(ibool, &
+ xstore,ystore,zstore,nspec,npointot,myrank,LOCAL_PATH, &
+ nnodes_ext_mesh,nelmnts_ext_mesh, &
+ 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, &
+ 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, &
+ 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, &
+ SAVE_MESH_FILES,nglob, &
+ ANISOTROPY,NPROC,OCEANS, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION,NX_TOPO,NY_TOPO, &
+ ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO, &
+ itopo_bathy)
+
! create the different regions of the mesh
+ use create_regions_mesh_ext_par
implicit none
+ !include "constants.h"
- include "constants.h"
-
! number of spectral elements in each block
integer :: nspec
@@ -59,8 +149,9 @@
! proc numbers for MPI
integer :: myrank
+ integer :: NPROC
- character(len=150) :: LOCAL_PATH
+ character(len=256) :: LOCAL_PATH
! data from the external mesh
integer :: nnodes_ext_mesh,nelmnts_ext_mesh
@@ -74,10 +165,12 @@
!pll
integer :: nmat_ext_mesh,nundefMat_ext_mesh
- double precision, dimension(5,nmat_ext_mesh) :: materials_ext_mesh
- character (len=30), dimension(5,nundefMat_ext_mesh):: undef_mat_prop
+ double precision, dimension(6,nmat_ext_mesh) :: materials_ext_mesh
+ character (len=30), dimension(6,nundefMat_ext_mesh):: undef_mat_prop
! double precision, external :: materials_ext_mesh
+
+! MPI communication
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
@@ -102,118 +195,28 @@
integer, dimension(4,NSPEC2D_BOTTOM) :: nodes_ibelm_bottom
integer, dimension(4,NSPEC2D_TOP) :: nodes_ibelm_top
- logical :: SAVE_MESH_FILES
integer :: nglob
+ logical :: SAVE_MESH_FILES
logical :: ANISOTROPY
+ logical :: OCEANS
+! use integer array to store topography values
+ integer :: UTM_PROJECTION_ZONE
+ logical :: SUPPRESS_UTM_PROJECTION
+ integer :: NX_TOPO,NY_TOPO
+ double precision :: ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
+ integer, dimension(NX_TOPO,NY_TOPO) :: itopo_bathy
+
! local parameters
-!-----------------------
-! for MPI buffers
-! integer, dimension(:), allocatable :: reorder_interface_ext_mesh,ind_ext_mesh,ninseg_ext_mesh,iwork_ext_mesh
-! integer, dimension(:), allocatable :: nibool_interfaces_ext_mesh_true
- !integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy
-! integer, dimension(:), allocatable :: ibool_interface_ext_mesh_dummy
-! double precision, dimension(:), allocatable :: work_ext_mesh
-
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore_dummy
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: ystore_dummy
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: zstore_dummy
-
-! Gauss-Lobatto-Legendre points and weights of integration
- double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
-
-! 3D shape functions and their derivatives
- double precision, dimension(:,:,:,:), allocatable :: shape3D
- double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
-
- double precision, dimension(:), allocatable :: xelm,yelm,zelm
-
! static memory size needed by the solver
double precision :: static_memory_size
-! arrays with mesh parameters
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore,jacobianstore
-
-! for model density
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,kappastore,mustore !,vpstore,vsstore
-! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
-
-! attenuation
- integer, dimension(:,:,:,:), allocatable :: iflag_attenuation_store
-
-! 2D shape functions and their derivatives, weights
- double precision, dimension(:,:,:), allocatable :: shape2D_x,shape2D_y,shape2D_bottom,shape2D_top
- double precision, dimension(:,:,:,:), allocatable :: dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top
- double precision, dimension(:,:), allocatable :: wgllwgll_xy,wgllwgll_xz,wgllwgll_yz
-
-! absorbing boundaries
-! pll
-! logical, dimension(:,:),allocatable :: iboun
-! real(kind=CUSTOM_REAL), dimension(:,:,:),allocatable :: xcoord_iboun,ycoord_iboun,zcoord_iboun
-! 2-D jacobians and normals
-! real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
-! jacobian2D_xmin,jacobian2D_xmax, &
-! jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_top
-
-! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
-! normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_top
-
-! ! local indices i,j,k of all GLL points on xmin boundary in the element
-! integer,dimension(:,:,:,:),allocatable :: ibelm_gll_xmin,ibelm_gll_xmax, &
-! ibelm_gll_ymin,ibelm_gll_ymax, &
-! ibelm_gll_bottom,ibelm_gll_top
-! integer, dimension(:,:), allocatable :: nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta
-
-! absorbing boundary arrays (for all boundaries) - keeps all infos, allowing for irregular surfaces
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: absorbing_boundary_normal
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: absorbing_boundary_jacobian2D
- integer, dimension(:,:,:), allocatable :: absorbing_boundary_ijk
- integer, dimension(:), allocatable :: absorbing_boundary_ispec
- integer :: num_absorbing_boundary_faces
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
-
-! variables for creating array ibool (some arrays also used for AVS or DX files)
-! integer, dimension(:), allocatable :: locval !,iglob
-! logical, dimension(:), allocatable :: ifseg
-! double precision, dimension(:), allocatable :: xp,yp,zp
-
-! integer :: ilocnum,ier,iinterface !,ieoff
- integer, dimension(:), allocatable :: elem_flag
- integer :: ier
- integer :: i,j,k,ispec,iglobnum
-! integer :: ispec2D
-
-! name of the database file
- character(len=150) prname
- character(len=150) prname_file
-
-! anisotropy
- integer :: NSPEC_ANISO
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- c11store,c12store,c13store,c14store,c15store,c16store,&
- c22store,c23store,c24store,c25store,c26store,c33store,&
- c34store,c35store,c36store,c44store,c45store,c46store,&
- c55store,c56store,c66store
-
-
-! mask to sort ibool
-! integer, dimension(:), allocatable :: mask_ibool
-! integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
-! integer :: inumber
-
-! memory test
-! logical,dimension(:),allocatable :: test_mem
-
-
! for vtk output
+! character(len=256) prname_file
! integer,dimension(:),allocatable :: itest_flag
+! integer, dimension(:), allocatable :: elem_flag
! For Piero Basini :
! integer :: doubling_value_found_for_Piero
@@ -232,28 +235,226 @@
! ! store bedrock values
! integer :: icornerlat,icornerlong
! double precision :: lat,long,elevation_bedrock
-! double precision :: lat_corner,long_corner,ratio_xi,ratio_eta
+! double precision :: lat_corner,long_corner,ratio_xi,ratio_eta
+!real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: ibedrock
+
+! initializes arrays
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' ...allocating arrays '
+ endif
+ call crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ nspec2D_bottom,nspec2D_top,ANISOTROPY)
-! ! size of topography and bathymetry file for Piero Basini's model
-! integer, parameter :: NX_TOPO = 787, NY_TOPO = 793
-! double precision, parameter :: ORIG_LAT_TOPO = -102352.d0
-! double precision, parameter :: ORIG_LONG_TOPO = 729806.d0
-! character(len=150), parameter :: TOPO_FILE = 'DATA/piero_model/dem_EV_UTM_regular_250_reordered.dat'
-! ! for Piero Basini's model this is the resolution in meters of the topo file
-! double precision, parameter :: DEGREES_PER_CELL_TOPO = 250.d0
-!real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: ibedrock
+! fills location and weights for Gauss-Lobatto-Legendre points, shape and derivations,
+! returns jacobianstore,xixstore,...gammazstore
+! and GLL-point locations in xstore,ystore,zstore
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...setting up jacobian '
+ endif
+ call crm_ext_setup_jacobian(myrank, &
+ xstore,ystore,zstore,nspec, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh,&
+ elmnts_ext_mesh,nelmnts_ext_mesh)
+
+! sets material velocities
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...determining velocity model'
+ endif
+ call crm_ext_determine_velocity(nspec,&
+ mat_ext_mesh,nelmnts_ext_mesh, &
+ materials_ext_mesh,nmat_ext_mesh, &
+ undef_mat_prop,nundefMat_ext_mesh, &
+ ANISOTROPY)
+
+! creates ibool index array for projection from local to global points
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...indexing global points'
+ endif
+ call crm_ext_setup_indexing(ibool, &
+ xstore,ystore,zstore,nspec,nglob,npointot, &
+ nnodes_ext_mesh,nodes_coords_ext_mesh,myrank)
+! sets up MPI interfaces between partitions
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...preparing MPI interfaces '
+ endif
+ call crm_ext_prepare_MPI(myrank,nglob,nspec,ibool, &
+ nelmnts_ext_mesh,elmnts_ext_mesh, &
+ my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
+ ibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC)
-! **************
+! creates mass matrix
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...creating mass matrix '
+ endif
+ call crm_ext_create_mass_matrix(nglob,nspec,ibool)
+
+! sets up absorbing/free surface boundaries
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...setting up absorbing boundaries '
+ endif
+ call crm_ext_setup_abs_boundary(myrank,nspec,nglob,ibool, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh, &
+ 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, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ nspec2D_bottom,nspec2D_top)
+
+! sets up acoustic-elastic coupling surfaces
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...detecting acoustic-elastic surfaces '
+ endif
+ call crm_ext_detect_ac_el_surface(myrank, &
+ nspec,nglob,ibool,NPROC, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
+ my_neighbours_ext_mesh)
+! creates ocean load mass matrix
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...creating ocean load mass matrix '
+ endif
+ call crm_ext_create_ocean_load_mass(nglob,nspec,ibool,OCEANS,&
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION,NX_TOPO,NY_TOPO, &
+ ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO, &
+ itopo_bathy)
+
+! saves the binary mesh files
call sync_all()
if( myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) ' ...allocating arrays '
+ write(IMAIN,*) ' ...saving databases'
endif
+ !call create_name_database(prname,myrank,LOCAL_PATH)
+ call save_arrays_solver_ext_mesh(nspec,nglob, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore, &
+ jacobianstore, rho_vp,rho_vs,iflag_attenuation_store, &
+ rhostore,kappastore,mustore, &
+ rmass,rmass_acoustic,rmass_solid_poroelastic,rmass_fluid_poroelastic, &
+ OCEANS,rmass_ocean_load,NGLOB_OCEAN,&
+ ibool, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ abs_boundary_normal,abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ free_surface_normal,free_surface_jacobian2Dw, &
+ free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ coupling_ac_el_normal,coupling_ac_el_jacobian2Dw, &
+ coupling_ac_el_ijk,coupling_ac_el_ispec, &
+ num_coupling_ac_el_faces, &
+ 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, &
+ ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, &
+ c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store, &
+ ispec_is_acoustic,ispec_is_elastic,ispec_is_poroelastic)
+! computes the approximate amount of static memory needed to run the solver
+ 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)
+
+! checks the mesh, stability and resolved period
+ call sync_all()
+ call check_mesh_resolution(myrank,nspec,nglob,ibool,&
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ kappastore,mustore,rho_vp,rho_vs, &
+ -1.0d0 )
+
+! VTK file output
+! if( SAVE_MESH_FILES ) then
+! ! saves material flag assigned for each spectral element into a vtk file
+! prname_file = prname(1:len_trim(prname))//'material_flag'
+! allocate(elem_flag(nspec))
+! elem_flag(:) = mat_ext_mesh(1,:)
+! call write_VTK_data_elem_i(nspec,nglob, &
+! xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+! elem_flag,prname_file)
+! deallocate(elem_flag)
+!
+! !plotting abs boundaries
+! ! allocate(itest_flag(nspec))
+! ! itest_flag(:) = 0
+! ! do ispec=1,nspec
+! ! if( iboun(1,ispec) ) itest_flag(ispec) = 1
+! ! enddo
+! ! prname_file = prname(1:len_trim(prname))//'iboundary1_flag'
+! ! call write_VTK_data_elem_i(nspec,nglob, &
+! ! xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+! ! itest_flag,prname_file)
+! ! deallocate(itest_flag)
+! endif
+
+! AVS/DX file output
+! create AVS or DX mesh data for the slice, edges and faces
+! if(SAVE_MESH_FILES) then
+! check: no idoubling
+! call write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
+! call write_AVS_DX_mesh_quality_data(prname,nspec,xstore,ystore,zstore, &
+! kappastore,mustore,rhostore)
+! check: no iMPIcut_xi,iMPIcut_eta,idoubling
+! call write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
+! idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
+! check: no idoubling
+! call write_AVS_DX_surface_data(myrank,prname,nspec,iboun,ibool, &
+! idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
+! endif
+
+! cleanup
+ deallocate(xixstore,xiystore,xizstore,&
+ etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore)
+ deallocate(jacobianstore,iflag_attenuation_store)
+ deallocate(xstore_dummy,ystore_dummy,zstore_dummy)
+ deallocate(kappastore,mustore,rho_vp,rho_vs)
+
+end subroutine create_regions_mesh_ext
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ nspec2D_bottom,nspec2D_top,ANISOTROPY)
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+ integer :: nspec,myrank
+ integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ nspec2D_bottom,nspec2D_top
+
+ character(len=256) :: LOCAL_PATH
+
+ logical :: ANISOTROPY
+
+! local parameters
+ integer :: ier
+
+! memory test
+! logical,dimension(:),allocatable :: test_mem
+!
! tests memory availability (including some small buffer of 10*1024 byte)
! allocate( test_mem(int(max_static_memory_size)+10*1024),stat=ier)
! if(ier /= 0) then
@@ -265,7 +466,6 @@
! deallocate( test_mem, stat=ier)
! if(ier /= 0) call exit_MPI(myrank,'error to allocate arrays')
! call sync_all()
-
allocate( xelm(NGNOD),yelm(NGNOD),zelm(NGNOD),stat=ier)
@@ -327,45 +527,33 @@
jacobianstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
-! allocates arrays for Stacey boundaries
-! allocate( nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX), &
-! njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX), &
-! nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX),stat=ier)
-! if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+! absorbing boundary
+ ! absorbing faces
+ num_abs_boundary_faces = nspec2D_xmin + nspec2D_xmax + nspec2D_ymin + nspec2D_ymax + nspec2D_bottom
+ ! adds faces of free surface if it also absorbs
+ if( ABSORB_FREE_SURFACE ) num_abs_boundary_faces = num_abs_boundary_faces + nspec2D_top
-! ! local indices i,j,k of all GLL points on xmin boundary in the element
-! allocate(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),stat=ier)
-! if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+ ! allocates arrays to store info for each face (assumes NGLLX=NGLLY=NGLLZ)
+ allocate( abs_boundary_ispec(num_abs_boundary_faces), &
+ abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces), &
+ abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces), &
+ abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces),stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
-! ! pll 2-D jacobians and normals
-! allocate(jacobian2D_xmin(NGLLY,NGLLZ,nspec2D_xmin),jacobian2D_xmax(NGLLY,NGLLZ,nspec2D_xmax), &
-! jacobian2D_ymin(NGLLX,NGLLZ,nspec2D_ymin),jacobian2D_ymax(NGLLX,NGLLZ,nspec2D_ymax), &
-! jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM),jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
-! if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
-
-! allocate(normal_xmin(NDIM,NGLLY,NGLLZ,nspec2D_xmin),normal_xmax(NDIM,NGLLY,NGLLZ,nspec2D_xmax), &
-! normal_ymin(NDIM,NGLLX,NGLLZ,nspec2D_ymin),normal_ymax(NDIM,NGLLX,NGLLZ,nspec2D_ymax), &
-! normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM),normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
-! if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
-
! free surface
- allocate(jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP),&
- normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
- if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+ ! free surface faces
+ if( ABSORB_FREE_SURFACE ) then
+ ! no free surface - uses a dummy size
+ num_free_surface_faces = 1
+ else
+ num_free_surface_faces = nspec2D_top
+ endif
-! absorbing boundary
- ! absorbing faces
- num_absorbing_boundary_faces = nspec2D_xmin + nspec2D_xmax + nspec2D_ymin + nspec2D_ymax + nspec2D_bottom
- ! free surface also absorbs
- if( ABSORB_FREE_SURFACE ) num_absorbing_boundary_faces = num_absorbing_boundary_faces + nspec2D_top
-
! allocates arrays to store info for each face (assumes NGLLX=NGLLY=NGLLZ)
- allocate( absorbing_boundary_ispec(num_absorbing_boundary_faces), &
- absorbing_boundary_ijk(3,NGLLSQUARE,num_absorbing_boundary_faces), &
- absorbing_boundary_jacobian2D(NGLLSQUARE,num_absorbing_boundary_faces), &
- absorbing_boundary_normal(NDIM,NGLLSQUARE,num_absorbing_boundary_faces),stat=ier)
+ allocate( free_surface_ispec(num_free_surface_faces), &
+ free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces), &
+ free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces), &
+ free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces),stat=ier)
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
! array with anisotropy
@@ -397,269 +585,43 @@
c66store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier)
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
-! fills location and weights for Gauss-Lobatto-Legendre points, shape and derivations,
-! returns jacobianstore,xixstore,...gammazstore
-! and GLL-point locations in xstore,ystore,zstore
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...setting up jacobian '
- endif
+! material flags
+ allocate( ispec_is_acoustic(nspec), &
+ ispec_is_elastic(nspec), &
+ ispec_is_poroelastic(nspec), stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
- call create_regions_mesh_ext_mesh_setup_jacobian(xigll,yigll,zigll,wxgll,wygll,wzgll, &
- myrank,shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- xstore,ystore,zstore,nspec,xelm,yelm,zelm, &
- nodes_coords_ext_mesh,nnodes_ext_mesh,elmnts_ext_mesh,nelmnts_ext_mesh, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- jacobianstore)
+end subroutine crm_ext_allocate_arrays
-! sets material velocities
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...determining velocity model'
- endif
- call create_regions_mesh_ext_mesh_determine_velocity(nspec,mat_ext_mesh,nelmnts_ext_mesh, &
- materials_ext_mesh,nmat_ext_mesh, &
- undef_mat_prop,nundefMat_ext_mesh, &
- rhostore,kappastore,mustore, &
- iflag_attenuation_store,rho_vp,rho_vs, &
- ANISOTROPY,NSPEC_ANISO, &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store, &
- c34store,c35store,c36store,c44store,c45store,c46store, &
- c55store,c56store,c66store)
- !,vpstore,vsstore,
-
-! creates ibool index array for projection from local to global points
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...indexing global points'
- endif
-
- call create_regions_mesh_ext_mesh_setup_global_indexing(ibool, &
- xstore,ystore,zstore,nspec,nglob,npointot, &
- nnodes_ext_mesh,nodes_coords_ext_mesh,myrank)
-
-! unique global point locations
- allocate(xstore_dummy(nglob), &
- ystore_dummy(nglob), &
- zstore_dummy(nglob),stat=ier)
- if(ier /= 0) stop 'error in allocate'
- do ispec = 1, nspec
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglobnum = ibool(i,j,k,ispec)
- xstore_dummy(iglobnum) = xstore(i,j,k,ispec)
- ystore_dummy(iglobnum) = ystore(i,j,k,ispec)
- zstore_dummy(iglobnum) = zstore(i,j,k,ispec)
- enddo
- enddo
- enddo
- enddo
-
-! creating mass matrix (will be fully assembled with MPI in the solver)
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...creating mass matrix '
- endif
-
- allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
-
- call create_regions_mesh_ext_mesh_create_mass_matrix(nglob,rmass,&
- nspec,wxgll,wygll,wzgll,ibool,jacobianstore,rhostore)
-
-! sets up absorbing/free surface boundaries
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...setting up absorbing boundaries '
- endif
-
- call create_regions_mesh_ext_mesh_setup_absorbing_bound(myrank,nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- nodes_coords_ext_mesh,nnodes_ext_mesh, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- 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, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,nspec2D_bottom,nspec2D_top, &
- normal_top,jacobian2D_top, &
- absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
- absorbing_boundary_ijk,absorbing_boundary_ispec, &
- num_absorbing_boundary_faces)
-
-! sets up MPI interfaces between partitions
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...preparing MPI interfaces '
- endif
-
- call create_regions_mesh_ext_mesh_prepare_MPI_interfaces(nglob,nspec,ibool, &
- nelmnts_ext_mesh,elmnts_ext_mesh, &
- my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
- ibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh, &
- num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
- xstore_dummy,ystore_dummy,zstore_dummy)
-
-! saves the binary files
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...saving databases'
- endif
-
- call create_name_database(prname,myrank,LOCAL_PATH)
- call save_arrays_solver_ext_mesh(nspec,nglob, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore, &
- jacobianstore, rho_vp,rho_vs,iflag_attenuation_store, &
- kappastore,mustore,rmass,ibool, &
- xstore_dummy,ystore_dummy,zstore_dummy, &
- NSPEC2D_TOP,ibelm_top,normal_top,jacobian2D_top, &
- absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
- absorbing_boundary_ijk,absorbing_boundary_ispec, &
- num_absorbing_boundary_faces, &
- 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, &
- ANISOTROPY,NSPEC_ANISO, &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store, &
- c34store,c35store,c36store,c44store,c45store,c46store, &
- c55store,c56store,c66store)
-
-! computes the approximate amount of static memory needed to run the solver
- 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)
-
-
-! checks the mesh, stability and resolved period
- call sync_all()
- call check_mesh_resolution(myrank,nspec,nglob,ibool,&
- xstore_dummy,ystore_dummy,zstore_dummy, &
- kappastore,mustore,rho_vp,rho_vs, &
- -1.0d0 )
-
-! VTK file output
- if( SAVE_MESH_FILES ) then
- ! saves material flag assigned for each spectral element into a vtk file
- prname_file = prname(1:len_trim(prname))//'material_flag'
- allocate(elem_flag(nspec))
- elem_flag(:) = mat_ext_mesh(1,:)
- call save_arrays_solver_ext_mesh_elem_vtk(nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- elem_flag,prname_file)
- deallocate(elem_flag)
-
- ! saves attenuation flag assigned on each gll point into a vtk file
- prname_file = prname(1:len_trim(prname))//'attenuation_flag'
- call save_arrays_solver_ext_mesh_glldata_vtk(nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- iflag_attenuation_store,prname_file)
-
- !daniel
- !plotting abs boundaries
- ! allocate(itest_flag(nspec))
- ! itest_flag(:) = 0
- ! do ispec=1,nspec
- ! if( iboun(1,ispec) ) itest_flag(ispec) = 1
- ! enddo
- ! prname_file = prname(1:len_trim(prname))//'iboundary1_flag'
- ! call save_arrays_solver_ext_mesh_elem_vtk(nspec,nglob, &
- ! xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- ! itest_flag,prname_file)
- ! deallocate(itest_flag)
- endif
-
-! AVS/DX file output
-! create AVS or DX mesh data for the slice, edges and faces
-! if(SAVE_MESH_FILES) then
-! check: no idoubling
-! call write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-! call write_AVS_DX_mesh_quality_data(prname,nspec,xstore,ystore,zstore, &
-! kappastore,mustore,rhostore)
-! check: no iMPIcut_xi,iMPIcut_eta,idoubling
-! call write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
-! idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-! check: no idoubling
-! call write_AVS_DX_surface_data(myrank,prname,nspec,iboun,ibool, &
-! idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-! endif
-
-! cleanup
- deallocate(xixstore,xiystore,xizstore,&
- etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore)
- deallocate(jacobianstore,iflag_attenuation_store)
- deallocate(xstore_dummy,ystore_dummy,zstore_dummy)
- deallocate(kappastore,mustore,rho_vp,rho_vs)
-
- end subroutine create_regions_mesh_ext_mesh
-
!
-!----
+!-------------------------------------------------------------------------------------------------
!
-subroutine create_regions_mesh_ext_mesh_setup_jacobian(xigll,yigll,zigll,wxgll,wygll,wzgll, &
- myrank,shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- xstore,ystore,zstore,nspec,xelm,yelm,zelm, &
- nodes_coords_ext_mesh,nnodes_ext_mesh,elmnts_ext_mesh,nelmnts_ext_mesh, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore,&
- jacobianstore)
+subroutine crm_ext_setup_jacobian(myrank, &
+ xstore,ystore,zstore,nspec, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh,&
+ elmnts_ext_mesh,nelmnts_ext_mesh)
+ use create_regions_mesh_ext_par
implicit none
- include 'constants.h'
-
! number of spectral elements in each block
integer :: nspec
-! Gauss-Lobatto-Legendre points and weights of integration
- double precision :: xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ),wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
-
-! 3D shape functions and their derivatives
- double precision :: shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
- double precision :: dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
-
-! 2D shape functions and their derivatives
- double precision :: shape2D_x(NGNOD2D,NGLLY,NGLLZ),shape2D_y(NGNOD2D,NGLLX,NGLLZ),&
- shape2D_bottom(NGNOD2D,NGLLX,NGLLY),shape2D_top(NGNOD2D,NGLLX,NGLLY)
- double precision :: dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ),&
- dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
-
- double precision, dimension(NGLLX,NGLLY) :: wgllwgll_xy
- double precision, dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- double precision, dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision,dimension(NGNOD) :: xelm,yelm,zelm
-
! data from the external mesh
integer :: nnodes_ext_mesh,nelmnts_ext_mesh
double precision, dimension(NDIM,nnodes_ext_mesh) :: nodes_coords_ext_mesh
integer, dimension(ESIZE,nelmnts_ext_mesh) :: elmnts_ext_mesh
-! arrays with mesh parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- jacobianstore
-
! proc numbers for MPI
integer :: myrank
+! local parameters
integer :: ispec,ia,i,j,k
-! integer :: ielm
-! logical :: inorder
-
! set up coordinates of the Gauss-Lobatto-Legendre points
call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
@@ -709,199 +671,8 @@
zelm(ia) = nodes_coords_ext_mesh(3,elmnts_ext_mesh(ia,ispec))
enddo
-
-!daniel
-! ! do we have to test CUBIT order - or will 3D jacobian be defined?
-!
-! ! bottom - top?
-! ! point 1 (0,0,0) vs point 5 (0,0,1)
-! inorder = .true.
-! if( nodes_coords(3,elmnts(1,num_elmnt)) > nodes_coords(3,elmnts(5,num_elmnt)) ) then
-! print*,num_elmnt,'z1-5 :',nodes_coords(3,elmnts(1,num_elmnt)),nodes_coords(3,elmnts(5,num_elmnt))
-! inorder = .false.
-! endif
-! if( inorder .eqv. .false. ) then
-! ielm = elmnts(1,num_elmnt)
-! elmnts(1,num_elmnt) = elmnts(5,num_elmnt)
-! elmnts(5,num_elmnt) = ielm
-!
-! ! assumes to switch the others as well
-! ielm = elmnts(2,num_elmnt)
-! elmnts(2,num_elmnt) = elmnts(6,num_elmnt)
-! elmnts(6,num_elmnt) = ielm
-!
-! ielm = elmnts(3,num_elmnt)
-! elmnts(3,num_elmnt) = elmnts(7,num_elmnt)
-! elmnts(7,num_elmnt) = ielm
-!
-! ielm = elmnts(4,num_elmnt)
-! elmnts(4,num_elmnt) = elmnts(8,num_elmnt)
-! elmnts(8,num_elmnt) = ielm
-!
-! endif
-! ! makes sure bottom - top is o.k.
-! ! point 2 (0,1,0) vs point 6 (0,1,1)
-! inorder = .true.
-! if( nodes_coords(3,elmnts(2,num_elmnt)) > nodes_coords(3,elmnts(6,num_elmnt)) ) then
-! print*,num_elmnt,'z2-6 :',nodes_coords(3,elmnts(2,num_elmnt)),nodes_coords(3,elmnts(6,num_elmnt))
-! inorder = .false.
-! endif
-! if( inorder .eqv. .false. ) then
-! ielm = elmnts(2,num_elmnt)
-! elmnts(2,num_elmnt) = elmnts(6,num_elmnt)
-! elmnts(6,num_elmnt) = ielm
-! endif
-!
-! ! point 3 (1,1,0) vs point 7 (1,1,1)
-! inorder = .true.
-! if( nodes_coords(3,elmnts(3,num_elmnt)) > nodes_coords(3,elmnts(7,num_elmnt)) ) then
-! print*,num_elmnt,'z3-7 :',nodes_coords(3,elmnts(3,num_elmnt)),nodes_coords(3,elmnts(7,num_elmnt))
-! inorder = .false.
-! endif
-! if( inorder .eqv. .false. ) then
-! ielm = elmnts(3,num_elmnt)
-! elmnts(3,num_elmnt) = elmnts(7,num_elmnt)
-! elmnts(7,num_elmnt) = ielm
-! endif
-!
-! ! point 4 (1,0,0) vs point 8 (1,0,1)
-! inorder = .true.
-! if( nodes_coords(3,elmnts(4,num_elmnt)) > nodes_coords(3,elmnts(8,num_elmnt)) ) then
-! print*,num_elmnt,'z4-8 :',nodes_coords(3,elmnts(4,num_elmnt)),nodes_coords(3,elmnts(8,num_elmnt))
-! inorder = .false.
-! endif
-! if( inorder .eqv. .false. ) then
-! ielm = elmnts(4,num_elmnt)
-! elmnts(4,num_elmnt) = elmnts(8,num_elmnt)
-! elmnts(8,num_elmnt) = ielm
-! endif
-!
-! ! clock-wise order?
-! ! point 1 (0,0,0) vs point 3 (1,1,0)
-! inorder = .true.
-! if( nodes_coords(1,elmnts(1,num_elmnt)) > nodes_coords(1,elmnts(3,num_elmnt)) ) then
-! print*,num_elmnt,'x1-3 :',nodes_coords(1,elmnts(1,num_elmnt)),nodes_coords(1,elmnts(3,num_elmnt))
-! inorder = .false.
-! endif
-! if( nodes_coords(2,elmnts(1,num_elmnt)) > nodes_coords(2,elmnts(3,num_elmnt)) ) then
-! print*,num_elmnt,'y1-3 :',nodes_coords(2,elmnts(1,num_elmnt)),nodes_coords(2,elmnts(3,num_elmnt))
-! inorder = .false.
-! endif
-! if( inorder .eqv. .false. ) then
-! ielm = elmnts(1,num_elmnt)
-! elmnts(1,num_elmnt) = elmnts(3,num_elmnt)
-! elmnts(3,num_elmnt) = ielm
-! endif
-!
-! ! point 2 (0,1,0) vs point 4 (1,0,0)
-! inorder = .true.
-! if( nodes_coords(1,elmnts(2,num_elmnt)) > nodes_coords(1,elmnts(4,num_elmnt)) ) then
-! print*,num_elmnt,'x2-4 :',nodes_coords(1,elmnts(2,num_elmnt)),nodes_coords(1,elmnts(4,num_elmnt))
-! inorder = .false.
-! endif
-! if( nodes_coords(2,elmnts(2,num_elmnt)) < nodes_coords(2,elmnts(4,num_elmnt)) ) then
-! print*,num_elmnt,'y2-4 :',nodes_coords(2,elmnts(2,num_elmnt)),nodes_coords(2,elmnts(4,num_elmnt))
-! inorder = .false.
-! endif
-! if( inorder .eqv. .false. ) then
-! ielm = elmnts(2,num_elmnt)
-! elmnts(2,num_elmnt) = elmnts(4,num_elmnt)
-! elmnts(4,num_elmnt) = ielm
-! endif
-!
-! ! point 5 (0,0,1) vs point 7 (1,1,1)
-! inorder = .true.
-! if( nodes_coords(1,elmnts(5,num_elmnt)) > nodes_coords(1,elmnts(7,num_elmnt)) ) then
-! print*,num_elmnt,'x5-7 :',nodes_coords(1,elmnts(5,num_elmnt)),nodes_coords(1,elmnts(7,num_elmnt))
-! inorder = .false.
-! endif
-! if( nodes_coords(2,elmnts(5,num_elmnt)) > nodes_coords(2,elmnts(7,num_elmnt)) ) then
-! print*,num_elmnt,'y5-7 :',nodes_coords(2,elmnts(5,num_elmnt)),nodes_coords(2,elmnts(7,num_elmnt))
-! inorder = .false.
-! endif
-! if( inorder .eqv. .false. ) then
-! ielm = elmnts(5,num_elmnt)
-! elmnts(5,num_elmnt) = elmnts(7,num_elmnt)
-! elmnts(7,num_elmnt) = ielm
-! endif
-!
-! ! point 6 (0,1,1) vs point 8 (1,0,1)
-! inorder = .true.
-! if( nodes_coords(1,elmnts(6,num_elmnt)) > nodes_coords(1,elmnts(8,num_elmnt)) ) then
-! print*,num_elmnt,'x6-8 :',nodes_coords(1,elmnts(6,num_elmnt)),nodes_coords(1,elmnts(8,num_elmnt))
-! inorder = .false.
-! endif
-! if( nodes_coords(2,elmnts(6,num_elmnt)) < nodes_coords(2,elmnts(8,num_elmnt)) ) then
-! print*,num_elmnt,'y6-8 :',nodes_coords(2,elmnts(6,num_elmnt)),nodes_coords(2,elmnts(8,num_elmnt))
-! inorder = .false.
-! endif
-! if( inorder .eqv. .false. ) then
-! ielm = elmnts(6,num_elmnt)
-! elmnts(6,num_elmnt) = elmnts(8,num_elmnt)
-! elmnts(8,num_elmnt) = ielm
-! endif
-!
-! or
-! if( .false. ) then
-! ! trys to order points in increasing z direction first, then y and x
-! inorder = .false.
-! do while (inorder .eqv. .false.)
-! inorder = .true.
-! do i=1,8
-! ! If z needs to be swapped, do so
-! if (nodes_coords(3,elmnts(i,num_elmnt)) > nodes_coords(3,elmnts(i+1,num_elmnt)) )then
-! i_temp = elmnts(i,num_elmnt)
-! elmnts(i,num_elmnt) = elmnts(i+1,num_elmnt)
-! elmnts(i+1,num_elmnt) = i_temp
-! inorder = .false.
-! exit
-! endif
-! ! Check Equilivant Points and swap those on Y
-! if (nodes_coords(3,elmnts(i,num_elmnt)) == nodes_coords(3,elmnts(i+1,num_elmnt))) then
-! if (nodes_coords(2,elmnts(i,num_elmnt)) > nodes_coords(2,elmnts(i+1,num_elmnt)) ) then
-! i_temp = elmnts(i,num_elmnt)
-! elmnts(i,num_elmnt) = elmnts(i+1,num_elmnt)
-! elmnts(i+1,num_elmnt) = i_temp
-! inorder = .false.
-! exit
-! endif
-! endif
-! ! Check Equilivant Points and swap those on X
-! if (nodes_coords(3,elmnts(i,num_elmnt)) == nodes_coords(3,elmnts(i+1,num_elmnt))) then
-! if (nodes_coords(2,elmnts(i,num_elmnt)) == nodes_coords(2,elmnts(i+1,num_elmnt)) ) then
-! if (nodes_coords(1,elmnts(i,num_elmnt)) > nodes_coords(1,elmnts(i+1,num_elmnt)) )then
-! i_temp = elmnts(i,num_elmnt)
-! elmnts(i,num_elmnt) = elmnts(i+1,num_elmnt)
-! elmnts(i+1,num_elmnt) = i_temp
-! inorder = .false.
-! exit
-! endif
-! endif
-! endif
-! enddo
-! enddo
-! ! respect anti-clockwise ordering bottom face
-! i_temp = elmnts(3,num_elmnt)
-! elmnts(3,num_elmnt) = elmnts(4,num_elmnt)
-! elmnts(4,num_elmnt) = i_temp
-! ! respect anti-clockwise ordering top face
-! i_temp = elmnts(7,num_elmnt)
-! elmnts(7,num_elmnt) = elmnts(8,num_elmnt)
-! elmnts(8,num_elmnt) = i_temp
-! if( nodes_coords(1,elmnts(1,num_elmnt)) > nodes_coords(1,elmnts(2,num_elmnt)) ) then
-! print*,'elem:',num_elmnt
-! stop 'error sorting x'
-! endif
-! if( nodes_coords(2,elmnts(1,num_elmnt)) > nodes_coords(2,elmnts(4,num_elmnt)) ) then
-! print*,'elem:',num_elmnt
-! stop 'error sorting y'
-! endif
-! if( nodes_coords(3,elmnts(1,num_elmnt)) > nodes_coords(3,elmnts(5,num_elmnt)) ) then
-! print*,'elem:',num_elmnt
-! stop 'error sorting z'
-! endif
-! endif
-
+ ! CUBIT should provide a mesh ordering such that the 3D jacobian is defined
+ ! (otherwise mesh would be degenerated)
call calc_jacobian(myrank,xixstore,xiystore,xizstore, &
etaxstore,etaystore,etazstore, &
gammaxstore,gammaystore,gammazstore,jacobianstore, &
@@ -910,28 +681,22 @@
enddo
-end subroutine create_regions_mesh_ext_mesh_setup_jacobian
+end subroutine crm_ext_setup_jacobian
+
!
-!----
+!-------------------------------------------------------------------------------------------------
!
-subroutine create_regions_mesh_ext_mesh_determine_velocity(nspec,mat_ext_mesh,nelmnts_ext_mesh, &
+subroutine crm_ext_determine_velocity(nspec,&
+ mat_ext_mesh,nelmnts_ext_mesh, &
materials_ext_mesh,nmat_ext_mesh, &
undef_mat_prop,nundefMat_ext_mesh, &
- rhostore,kappastore,mustore, &
- iflag_attenuation_store,rho_vp,rho_vs, &
- ANISOTROPY,NSPEC_ANISO, &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store, &
- c34store,c35store,c36store,c44store,c45store,c46store, &
- c55store,c56store,c66store)
- ! vpstore,vsstore,
+ ANISOTROPY)
+ use create_regions_mesh_ext_par
implicit none
- include 'constants.h'
-
! number of spectral elements in each block
integer :: nspec
@@ -940,26 +705,11 @@
integer :: nmat_ext_mesh,nundefMat_ext_mesh
integer, dimension(2,nelmnts_ext_mesh) :: mat_ext_mesh
- double precision, dimension(5,nmat_ext_mesh) :: materials_ext_mesh
- character (len=30), dimension(5,nundefMat_ext_mesh):: undef_mat_prop
+ double precision, dimension(6,nmat_ext_mesh) :: materials_ext_mesh
+ character (len=30), dimension(6,nundefMat_ext_mesh):: undef_mat_prop
-! for model density
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- rhostore,kappastore,mustore !,vpstore,vsstore
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rho_vp,rho_vs
-
-! attenuation
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: iflag_attenuation_store
-
! anisotropy
logical :: ANISOTROPY
- integer :: NSPEC_ANISO
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO) :: &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store, &
- c34store,c35store,c36store,c44store,c45store,c46store, &
- c55store,c56store,c66store
-
! local parameters
real(kind=CUSTOM_REAL) :: vp,vs,rho
@@ -968,7 +718,7 @@
integer :: ispec,i,j,k,iundef,iflag_atten
integer :: iflag,flag_below,flag_above
- integer :: iflag_aniso
+ integer :: iflag_aniso,idomain_id
! ! Piero, read bedrock file
! allocate(ibedrock(NX_TOPO_ANT,NY_TOPO_ANT))
@@ -982,6 +732,10 @@
! ! call MPI_BCAST(ibedrock,NX_TOPO_ANT*NY_TOPO_ANT,MPI_REAL,0,MPI_COMM_WORLD,ier)
! call bcast_all_cr(ibedrock,NX_TOPO_ANT*NY_TOPO_ANT)
+ ispec_is_acoustic(:) = .false.
+ ispec_is_elastic(:) = .false.
+ ispec_is_poroelastic(:) = .false.
+
! material properties on all GLL points: taken from material values defined for
! each spectral element in input mesh
do ispec = 1, nspec
@@ -1013,6 +767,9 @@
! anisotropy
iflag_aniso = materials_ext_mesh(5,mat_ext_mesh(1,ispec))
+ ! material domain_id
+ idomain_id = materials_ext_mesh(6,mat_ext_mesh(1,ispec))
+
else if (mat_ext_mesh(2,ispec) == 1) then
stop 'material: interface not implemented yet'
@@ -1037,7 +794,8 @@
! else
! iflag_attenuation_store(i,j,k,ispec) = 2
! endif
- iflag_aniso = 0
+ iflag_aniso = materials_ext_mesh(5,iflag)
+ idomain_id = materials_ext_mesh(6,iflag)
else
stop 'material: tomography not implemented yet'
! call tomography()
@@ -1075,28 +833,48 @@
rhostore(i,j,k,ispec) = rho
! kappa, mu
- !kappastore(i,j,k,ispec) = rhostore(i,j,k,ispec)* &
- ! ( vpstore(i,j,k,ispec)*vpstore(i,j,k,ispec) &
- ! - FOUR_THIRDS*vsstore(i,j,k,ispec)*vsstore(i,j,k,ispec) )
- !mustore(i,j,k,ispec) = rhostore(i,j,k,ispec)*vsstore(i,j,k,ispec)*vsstore(i,j,k,ispec)
kappastore(i,j,k,ispec) = rho*( vp*vp - FOUR_THIRDS*vs*vs )
mustore(i,j,k,ispec) = rho*vs*vs
! attenuation
iflag_attenuation_store(i,j,k,ispec) = iflag_atten
! Stacey, a completer par la suite
- !rho_vp(i,j,k,ispec) = rhostore(i,j,k,ispec)*vpstore(i,j,k,ispec)
- !rho_vs(i,j,k,ispec) = rhostore(i,j,k,ispec)*vsstore(i,j,k,ispec)
rho_vp(i,j,k,ispec) = rho*vp
rho_vs(i,j,k,ispec) = rho*vs
!end pll
+! material domain
+ !print*,'velocity model:',ispec,idomain_id
+ if( idomain_id == IDOMAIN_ACOUSTIC ) then
+ ispec_is_acoustic(ispec) = .true.
+ else if( idomain_id == IDOMAIN_ELASTIC ) then
+ ispec_is_elastic(ispec) = .true.
+ else if( idomain_id == IDOMAIN_POROELASTIC ) then
+ stop 'poroelastic material domain not implemented yet'
+ ispec_is_poroelastic(ispec) = .true.
+ else
+ stop 'error material domain index'
+ endif
enddo
enddo
enddo
!print*,myrank,'ispec:',ispec,'rho:',rhostore(1,1,1,ispec),'vp:',vpstore(1,1,1,ispec),'vs:',vsstore(1,1,1,ispec)
enddo
+! checks material domains
+ do ispec=1,nspec
+ if( (ispec_is_acoustic(ispec) .eqv. .false.) &
+ .and. (ispec_is_elastic(ispec) .eqv. .false.) &
+ .and. (ispec_is_poroelastic(ispec) .eqv. .false.) ) then
+ print*,'error material domain not assigned to element:',ispec
+ print*,'acoustic: ',ispec_is_acoustic(ispec)
+ print*,'elastic: ',ispec_is_elastic(ispec)
+ print*,'poroelastic: ',ispec_is_poroelastic(ispec)
+ stop 'error material domain index element'
+ endif
+ enddo
+
+
! !! DK DK store the position of the six stations to be able to
! !! DK DK exclude circles around each station to make sure they are on the bedrock
! !! DK DK and not in the ice
@@ -1265,22 +1043,22 @@
! enddo
! enddo
-end subroutine create_regions_mesh_ext_mesh_determine_velocity
+end subroutine crm_ext_determine_velocity
+
!
-!----
+!-------------------------------------------------------------------------------------------------
!
-subroutine create_regions_mesh_ext_mesh_setup_global_indexing(ibool, &
+subroutine crm_ext_setup_indexing(ibool, &
xstore,ystore,zstore,nspec,nglob,npointot, &
nnodes_ext_mesh,nodes_coords_ext_mesh,myrank)
! creates global indexing array ibool
+ use create_regions_mesh_ext_par
implicit none
- include "constants.h"
-
! number of spectral elements in each block
integer :: nspec,nglob,npointot,myrank
@@ -1299,7 +1077,7 @@
logical, dimension(:), allocatable :: ifseg
integer :: ieoff,ilocnum,ier
- integer :: i,j,k,ispec
+ integer :: i,j,k,ispec,iglobnum
! allocate memory for arrays
allocate(locval(npointot), &
@@ -1345,114 +1123,369 @@
deallocate(locval,stat=ier); if(ier /= 0) stop 'error in deallocate'
deallocate(ifseg,stat=ier); if(ier /= 0) stop 'error in deallocate'
-end subroutine create_regions_mesh_ext_mesh_setup_global_indexing
+! unique global point locations
+ allocate(xstore_dummy(nglob), &
+ ystore_dummy(nglob), &
+ zstore_dummy(nglob),stat=ier)
+ if(ier /= 0) stop 'error in allocate'
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglobnum = ibool(i,j,k,ispec)
+ xstore_dummy(iglobnum) = xstore(i,j,k,ispec)
+ ystore_dummy(iglobnum) = ystore(i,j,k,ispec)
+ zstore_dummy(iglobnum) = zstore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+end subroutine crm_ext_setup_indexing
+
!
-!----
+!-------------------------------------------------------------------------------------------------
!
-subroutine create_regions_mesh_ext_mesh_create_mass_matrix(nglob,rmass,&
- nspec,wxgll,wygll,wzgll,ibool,jacobianstore,rhostore)
+subroutine crm_ext_prepare_MPI(myrank,nglob,nspec,ibool, &
+ nelmnts_ext_mesh,elmnts_ext_mesh, &
+ my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
+ ibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
+ my_neighbours_ext_mesh,NPROC)
-! returns precomputed mass matrix in rmass array
+! sets up the MPI interface for communication between partitions
+ use create_regions_mesh_ext_par
implicit none
- include 'constants.h'
+ integer :: myrank,nglob,nspec,NPROC
-! number of spectral elements in each block
- integer :: nglob,nspec
+! global indexing
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-! mass matrix
- real(kind=CUSTOM_REAL), dimension(nglob) :: rmass
+! external mesh, element indexing
+ integer :: nelmnts_ext_mesh
+ integer, dimension(ESIZE,nelmnts_ext_mesh) :: elmnts_ext_mesh
+
+ integer :: num_interfaces_ext_mesh,max_interface_size_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
-! Gauss-Lobatto-Legendre weights of integration
- double precision :: wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
+ integer, dimension(num_interfaces_ext_mesh) :: my_neighbours_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
-! arrays with the mesh
+
+ !integer :: nnodes_ext_mesh
+ !double precision, dimension(NDIM,nnodes_ext_mesh) :: nodes_coords_ext_mesh
+
+!local parameters
+ double precision, dimension(:), allocatable :: xp,yp,zp
+ double precision, dimension(:), allocatable :: work_ext_mesh
+
+ integer, dimension(:), allocatable :: locval
+ integer, dimension(:), allocatable :: nibool_interfaces_ext_mesh_true
+
+ ! for MPI buffers
+ integer, dimension(:), allocatable :: reorder_interface_ext_mesh,ind_ext_mesh,ninseg_ext_mesh,iwork_ext_mesh
+ integer, dimension(:), allocatable :: ibool_interface_ext_mesh_dummy
+ logical, dimension(:), allocatable :: ifseg
+ integer :: iinterface,ilocnum
+ integer :: num_points1, num_points2
+
+ ! assembly test
+ integer :: i,j,k,ispec,iglob,count,inum
+ integer :: max_nibool_interfaces_ext_mesh
+ integer,dimension(:),allocatable :: test_flag
+ real(kind=CUSTOM_REAL), dimension(:),allocatable :: test_flag_cr
+ integer, dimension(:,:), allocatable :: ibool_interfaces_dummy
+
+! gets global indices for points on MPI interfaces (defined by my_interfaces_ext_mesh) between different partitions
+! and stores them in ibool_interfaces_ext_mesh & nibool_interfaces_ext_mesh (number of total points)
+ call prepare_assemble_MPI( nelmnts_ext_mesh,elmnts_ext_mesh, &
+ ibool,nglob,ESIZE, &
+ 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(num_interfaces_ext_mesh))
+
+! sorts ibool comm buffers lexicographically for all MPI interfaces
+ num_points1 = 0
+ num_points2 = 0
+ do iinterface = 1, num_interfaces_ext_mesh
+
+ allocate(xp(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(yp(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(zp(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(locval(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(ifseg(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(reorder_interface_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(ibool_interface_ext_mesh_dummy(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(ind_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(ninseg_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(iwork_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(work_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+
+ ! gets x,y,z coordinates of global points on MPI interface
+ do ilocnum = 1, nibool_interfaces_ext_mesh(iinterface)
+ xp(ilocnum) = xstore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
+ yp(ilocnum) = ystore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
+ zp(ilocnum) = zstore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
+ enddo
+
+ ! sorts (lexicographically?) ibool_interfaces_ext_mesh and updates value
+ ! of total number of points nibool_interfaces_ext_mesh_true(iinterface)
+ call sort_array_coordinates(nibool_interfaces_ext_mesh(iinterface),xp,yp,zp, &
+ ibool_interfaces_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ reorder_interface_ext_mesh,locval,ifseg,nibool_interfaces_ext_mesh_true(iinterface), &
+ ind_ext_mesh,ninseg_ext_mesh,iwork_ext_mesh,work_ext_mesh)
+
+ ! checks that number of MPI points are still the same
+ num_points1 = num_points1 + nibool_interfaces_ext_mesh(iinterface)
+ num_points2 = num_points2 + nibool_interfaces_ext_mesh_true(iinterface)
+ if( num_points1 /= num_points2 ) then
+ write(*,*) 'error sorting MPI interface points:',myrank
+ write(*,*) ' interface:',iinterface,num_points1,num_points2
+ call exit_mpi(myrank,'error sorting MPI interface')
+ endif
+ !write(*,*) myrank,'intfc',iinterface,num_points2,nibool_interfaces_ext_mesh_true(iinterface)
+
+ ! cleanup temporary arrays
+ deallocate(xp)
+ deallocate(yp)
+ deallocate(zp)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(reorder_interface_ext_mesh)
+ deallocate(ibool_interface_ext_mesh_dummy)
+ deallocate(ind_ext_mesh)
+ deallocate(ninseg_ext_mesh)
+ deallocate(iwork_ext_mesh)
+ deallocate(work_ext_mesh)
+
+ enddo
+
+ ! cleanup
+ deallocate(nibool_interfaces_ext_mesh_true)
+
+ ! outputs total number of MPI interface points
+ call sum_all_i(num_points2,ilocnum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' total MPI interface points: ',ilocnum
+ endif
+
+! checks with assembly of test fields
+ allocate(test_flag(nglob),test_flag_cr(nglob))
+ test_flag(:) = 0
+ test_flag_cr(:) = 0._CUSTOM_REAL
+ count = 0
+ do ispec = 1, nspec
+ ! sets flags on global points
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ! global index
+ iglob = ibool(i,j,k,ispec)
+
+ ! counts number of unique global points to set
+ if( test_flag(iglob) == 0 ) count = count+1
+
+ ! sets identifier
+ test_flag(iglob) = myrank + 1
+ test_flag_cr(iglob) = myrank + 1.0
+ enddo
+ enddo
+ enddo
+ enddo
+ call sync_all()
+
+ ! collects contributions from different MPI partitions
+ ! sets up MPI communications
+ max_nibool_interfaces_ext_mesh = maxval( nibool_interfaces_ext_mesh(:) )
+ allocate(ibool_interfaces_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+
+ count = 0
+ do iinterface = 1, num_interfaces_ext_mesh
+ ibool_interfaces_dummy(:,iinterface) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,iinterface)
+ count = count + nibool_interfaces_ext_mesh(iinterface)
+ !write(*,*) myrank,'interfaces ',iinterface,nibool_interfaces_ext_mesh(iinterface),max_nibool_interfaces_ext_mesh
+ enddo
+ call sync_all()
+
+ call sum_all_i(count,iglob)
+ if( myrank == 0 ) then
+ if( iglob /= ilocnum ) call exit_mpi(myrank,'error total global MPI interface points')
+ endif
+
+ ! adds contributions from different partitions to flag arrays
+ ! integer arrays
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,test_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_dummy,&
+ my_neighbours_ext_mesh)
+ ! custom_real arrays
+ call assemble_MPI_scalar_ext_mesh(NPROC,nglob,test_flag_cr, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_dummy, &
+ my_neighbours_ext_mesh)
+
+ ! checks number of interface points
+ i = 0
+ j = 0
+ do iglob=1,nglob
+ ! only counts flags with MPI contributions
+ if( test_flag(iglob) > myrank+1 ) i = i + 1
+ if( test_flag_cr(iglob) > myrank+1.0) j = j + 1
+ enddo
+ call sum_all_i(i,inum)
+ call sum_all_i(j,iglob)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' total assembled MPI interface points:',inum
+ if( inum /= iglob .or. inum > ilocnum ) call exit_mpi(myrank,'error MPI assembly')
+ endif
+
+end subroutine crm_ext_prepare_MPI
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine crm_ext_create_mass_matrix(nglob,nspec,ibool)
+
+! returns precomputed mass matrix in rmass array
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+! number of spectral elements in each block
+ integer :: nspec
+ integer :: nglob
+
+! arrays with the mesh global indices
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-! arrays with mesh parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: jacobianstore,rhostore
-
! local parameters
double precision :: weight
real(kind=CUSTOM_REAL) :: jacobianl
- integer :: ispec,i,j,k,iglobnum
+ integer :: ispec,i,j,k,iglob,ier
+! allocates memory
+ allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(rmass_acoustic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(rmass_solid_poroelastic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(rmass_fluid_poroelastic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+
! creates mass matrix
rmass(:) = 0._CUSTOM_REAL
-
+ rmass_acoustic(:) = 0._CUSTOM_REAL
+ rmass_solid_poroelastic(:) = 0._CUSTOM_REAL
+ rmass_fluid_poroelastic(:) = 0._CUSTOM_REAL
+
do ispec=1,nspec
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
- weight=wxgll(i)*wygll(j)*wzgll(k)
- iglobnum=ibool(i,j,k,ispec)
+ iglob = ibool(i,j,k,ispec)
- jacobianl=jacobianstore(i,j,k,ispec)
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglobnum) = rmass(iglobnum) + &
- sngl((dble(rhostore(i,j,k,ispec))) * dble(jacobianl) * weight)
- else
- rmass(iglobnum) = rmass(iglobnum) + rhostore(i,j,k,ispec) * jacobianl * weight
+! acoustic mass matrix
+ if( ispec_is_acoustic(ispec) ) then
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass_acoustic(iglob) = rmass_acoustic(iglob) + &
+ sngl( dble(jacobianl) * weight / dble(kappastore(i,j,k,ispec)) )
+ else
+ rmass_acoustic(iglob) = rmass_acoustic(iglob) + &
+ jacobianl * weight / kappastore(i,j,k,ispec)
+ endif
endif
+! elastic mass matrix
+ if( ispec_is_elastic(ispec) ) then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(rhostore(i,j,k,ispec)) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * rhostore(i,j,k,ispec)
+ endif
+ endif
+
+! poroelastic mass matrices
+ if( ispec_is_poroelastic(ispec) ) then
+
+ stop 'poroelastic mass matrices not implemented yet'
+
+ !rho_solid = density(1,kmato(ispec))
+ !rho_fluid = density(2,kmato(ispec))
+ !phi = porosity(kmato(ispec))
+ !tort = tortuosity(kmato(ispec))
+ !rho_bar = (1._CUSTOM_REAL-phil)*rhol_s + phil*rhol_f
+ !
+ !if(CUSTOM_REAL == SIZE_REAL) then
+ ! ! for the solid mass matrix
+ ! rmass_solid_poroelastic(iglob) = rmass_solid_poroelastic(iglob) + &
+ ! sngl( dble(jacobianl) * weight * dble(rho_bar - phi*rho_fluid/tort) )
+ !
+ ! ! for the fluid mass matrix
+ ! rmass_fluid_poroelastic(iglob) = rmass_fluid_poroelastic(iglob) + &
+ ! sngl( dble(jacobianl) * weight * dble(rho_bar*rho_fluid*tort - &
+ ! phi*rho_fluid*rho_fluid)/dble(rho_bar*phi) )
+ !else
+ ! rmass_solid_poroelastic(iglob) = rmass_solid_poroelastic(iglob) + &
+ ! jacobianl * weight * (rho_bar - phi*rho_fluid/tort)
+ !
+ ! rmass_fluid_poroelastic(iglob) = rmass_fluid_poroelastic(iglob) + &
+ ! jacobianl * weight * (rho_bar*rho_fluid*tort - &
+ ! phi*rho_fluid*rho_fluid) / (rho_bar*phi)
+ !endif
+ endif
+
enddo
enddo
enddo
- enddo
+ enddo ! nspec
+end subroutine crm_ext_create_mass_matrix
-end subroutine create_regions_mesh_ext_mesh_create_mass_matrix
!
-!----
+!-------------------------------------------------------------------------------------------------
!
-subroutine create_regions_mesh_ext_mesh_setup_absorbing_bound(myrank,nspec,nglob,&
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+subroutine crm_ext_setup_abs_boundary(myrank,nspec,nglob,ibool, &
nodes_coords_ext_mesh,nnodes_ext_mesh, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
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, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,nspec2D_bottom,nspec2D_top, &
- normal_top,jacobian2D_top, &
- absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
- absorbing_boundary_ijk,absorbing_boundary_ispec, &
- num_absorbing_boundary_faces)
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ nspec2D_bottom,nspec2D_top)
! determines absorbing boundaries/free-surface, 2D jacobians, face normals for Stacey conditions
+
+ use create_regions_mesh_ext_par
implicit none
- include "constants.h"
-
! number of spectral elements in each block
integer :: myrank,nspec,nglob
! arrays with the mesh
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-! double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
-! global point locations
- real(kind=CUSTOM_REAL) :: xstore_dummy(nglob),ystore_dummy(nglob),zstore_dummy(nglob)
-! 2D shape functions derivatives and weights
- double precision :: dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ), &
- dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
- double precision, dimension(NGLLX,NGLLY) :: wgllwgll_xy
- double precision, dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- double precision, dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
! data from the external mesh
- integer :: nnodes_ext_mesh !,nelmnts_ext_mesh
+ integer :: nnodes_ext_mesh
double precision, dimension(NDIM,nnodes_ext_mesh) :: nodes_coords_ext_mesh
-! integer, dimension(ESIZE,nelmnts_ext_mesh) :: elmnts_ext_mesh
-! absorbing boundaries
+! absorbing boundaries (as defined in CUBIT)
integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, NSPEC2D_BOTTOM, NSPEC2D_TOP
! element indices containing a boundary
integer, dimension(nspec2D_xmin) :: ibelm_xmin
@@ -1469,48 +1502,12 @@
integer, dimension(4,nspec2D_ymax) :: nodes_ibelm_ymax
integer, dimension(4,NSPEC2D_BOTTOM) :: nodes_ibelm_bottom
integer, dimension(4,NSPEC2D_TOP) :: nodes_ibelm_top
-
- ! local indices i,j,k of all GLL points on an absorbing boundary in the element,
- ! defines all gll points located on the absorbing surfaces
-! 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)
-
-! overlap indices for elements at corners and edges with more than one aborbing boundary face
-! integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
-! integer :: nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX), &
-! njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX), &
-! nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX)
-
- ! 2-D jacobians and normals
-! real(kind=CUSTOM_REAL) :: jacobian2D_xmin(NGLLY,NGLLZ,nspec2D_xmin),&
-! jacobian2D_xmax(NGLLY,NGLLZ,nspec2D_xmax), &
-! jacobian2D_ymin(NGLLX,NGLLZ,nspec2D_ymin), &
-! jacobian2D_ymax(NGLLX,NGLLZ,nspec2D_ymax),&
-! jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM),&
- real(kind=CUSTOM_REAL):: jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
-
-! absorbing boundary arrays (for all boundaries) - keeps all infos, allowing for irregular surfaces
- 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
- ! normals for all GLL points on boundaries
-! real(kind=CUSTOM_REAL) :: normal_xmin(NDIM,NGLLY,NGLLZ,nspec2D_xmin),&
-! normal_xmax(NDIM,NGLLY,NGLLZ,nspec2D_xmax), &
-! normal_ymin(NDIM,NGLLX,NGLLZ,nspec2D_ymin), &
-! normal_ymax(NDIM,NGLLX,NGLLZ,nspec2D_ymax), &
-! normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM),
- real(kind=CUSTOM_REAL) :: normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
-
! local parameters
-! pll
- logical, dimension(:,:),allocatable :: iboun
+ logical, dimension(:,:),allocatable :: iboun ! pll
! (assumes NGLLX=NGLLY=NGLLZ)
- real(kind=CUSTOM_REAL) :: jacobian2D_face(NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL) :: jacobian2Dw_face(NGLLX,NGLLY)
real(kind=CUSTOM_REAL) :: normal_face(NDIM,NGLLX,NGLLY)
integer:: ijk_face(3,NGLLX,NGLLY)
@@ -1519,7 +1516,7 @@
! face corner locations
real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
- integer :: ispec,ispec2D,icorner,ier,iabs,iface,igll,i,j
+ integer :: ispec,ispec2D,icorner,ier,iabs,iface,igll,i,j,igllfree,ifree
! allocate temporary flag array
allocate(iboun(6,nspec), &
@@ -1566,7 +1563,7 @@
xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
- ispec,iface,jacobian2D_face,normal_face,NGLLX,NGLLZ)
+ ispec,iface,jacobian2Dw_face,normal_face,NGLLX,NGLLZ)
! normal convention: points away from element
! switch normal direction if necessary
@@ -1579,31 +1576,18 @@
enddo
enddo
- !daniel
- ! checks: layered halfspace normals
- ! for boundary on xmin, outward direction must be (-1,0,0)
- !if( myrank == 0 ) then
- !if( abs(normal_face(1,1,1) + 1.0 ) > 0.1 ) then
- ! print*,'error normal xmin',myrank,ispec
- ! print*,sngl(normal_face(:,1,1))
- ! stop
- !endif
- !if( abs(xstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) - 0.0) > 0.1 ) &
- ! print*,'error element xmin:',ispec,xstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
- !endif
-
! sets face infos
iabs = iabs + 1
- absorbing_boundary_ispec(iabs) = ispec
+ abs_boundary_ispec(iabs) = ispec
! gll points -- assuming NGLLX = NGLLY = NGLLZ
igll = 0
do j=1,NGLLZ
do i=1,NGLLX
igll = igll+1
- absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
- absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
- absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
enddo
enddo
@@ -1637,7 +1621,7 @@
xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
- ispec,iface,jacobian2D_face,normal_face,NGLLX,NGLLZ)
+ ispec,iface,jacobian2Dw_face,normal_face,NGLLX,NGLLZ)
! normal convention: points away from element
! switch normal direction if necessary
@@ -1650,28 +1634,18 @@
enddo
enddo
- !daniel
- ! checks: layered halfspace normals
- ! for boundary on xmin, outward direction must be (1,0,0)
- !if( abs(normal_face(1,1,1) - 1.0 ) > 0.1 ) then
- ! print*,'error normal xmax',myrank,ispec
- ! print*,sngl(normal_face(:,1,1))
- !endif
- !if( abs(xstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) - 134000.0) > 0.1 ) &
- ! print*,'error element xmax:',ispec,xstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
-
! sets face infos
iabs = iabs + 1
- absorbing_boundary_ispec(iabs) = ispec
+ abs_boundary_ispec(iabs) = ispec
! gll points -- assuming NGLLX = NGLLY = NGLLZ
igll = 0
do j=1,NGLLZ
do i=1,NGLLX
igll = igll+1
- absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
- absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
- absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
enddo
enddo
@@ -1705,7 +1679,7 @@
xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
- ispec,iface,jacobian2D_face,normal_face,NGLLY,NGLLZ)
+ ispec,iface,jacobian2Dw_face,normal_face,NGLLY,NGLLZ)
! normal convention: points away from element
! switch normal direction if necessary
@@ -1718,28 +1692,18 @@
enddo
enddo
- !daniel
- ! checks: layered halfspace normals
- ! for boundary on xmin, outward direction must be (0,-1,0)
- !if( abs(normal_face(2,1,1) + 1.0 ) > 0.1 ) then
- ! print*,'error normal ymin',myrank,ispec
- ! print*,sngl(normal_face(:,1,1))
- !endif
- !if( abs(ystore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) - 0.0) > 0.1 ) &
- ! print*,'error element ymin:',ispec,ystore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
-
! sets face infos
iabs = iabs + 1
- absorbing_boundary_ispec(iabs) = ispec
+ abs_boundary_ispec(iabs) = ispec
! gll points -- assuming NGLLX = NGLLY = NGLLZ
igll = 0
do j=1,NGLLZ
do i=1,NGLLY
igll = igll+1
- absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
- absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
- absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
enddo
enddo
@@ -1773,7 +1737,7 @@
xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob, &
dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- ispec,iface,jacobian2D_face,normal_face,NGLLY,NGLLZ)
+ ispec,iface,jacobian2Dw_face,normal_face,NGLLY,NGLLZ)
! normal convention: points away from element
! switch normal direction if necessary
@@ -1786,28 +1750,18 @@
enddo
enddo
- !daniel
- ! checks: layered halfspace normals
- ! for boundary on xmin, outward direction must be (0,1,0)
- !if( abs(normal_face(2,1,1) - 1.0 ) > 0.1 ) then
- ! print*,'error normal ymax',myrank,ispec
- ! print*,sngl(normal_face(:,1,1))
- !endif
- !if( abs(ystore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) - 134000.0) > 0.1 ) &
- ! print*,'error element ymax:',ispec,ystore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
-
! sets face infos
iabs = iabs + 1
- absorbing_boundary_ispec(iabs) = ispec
+ abs_boundary_ispec(iabs) = ispec
! gll points -- assuming NGLLX = NGLLY = NGLLZ
igll = 0
do j=1,NGLLY
do i=1,NGLLX
igll = igll+1
- absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
- absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
- absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
enddo
enddo
@@ -1841,7 +1795,7 @@
xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob, &
dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- ispec,iface,jacobian2D_face,normal_face,NGLLX,NGLLY)
+ ispec,iface,jacobian2Dw_face,normal_face,NGLLX,NGLLY)
! normal convention: points away from element
! switch normal direction if necessary
@@ -1854,34 +1808,26 @@
enddo
enddo
- !daniel
- ! checks: layered halfspace normals
- ! for boundary on xmin, outward direction must be (0,0,-1)
- !if( abs(normal_face(3,1,1) + 1.0 ) > 0.1 ) then
- ! print*,'error normal bottom',myrank,ispec
- ! print*,sngl(normal_face(:,1,1))
- !endif
- !if( abs(zstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) + 60000.0) > 0.1 ) &
- ! print*,'error element bottom:',ispec,zstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
-
! sets face infos
iabs = iabs + 1
- absorbing_boundary_ispec(iabs) = ispec
+ abs_boundary_ispec(iabs) = ispec
! gll points -- assuming NGLLX = NGLLY = NGLLZ
igll = 0
do j=1,NGLLY
do i=1,NGLLX
igll = igll+1
- absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
- absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
- absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
enddo
enddo
enddo
- ! top
+ ! top
+ ! free surface face counter
+ ifree = 0
do ispec2D = 1, NSPEC2D_TOP
! sets element
ispec = ibelm_top(ispec2D)
@@ -1909,7 +1855,7 @@
xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob, &
dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- ispec,iface,jacobian2D_face,normal_face,NGLLX,NGLLY)
+ ispec,iface,jacobian2Dw_face,normal_face,NGLLX,NGLLY)
! normal convention: points away from element
! switch normal direction if necessary
@@ -1922,45 +1868,63 @@
enddo
enddo
- !daniel
- ! checks: layered halfspace normals
- ! for boundary on xmin, outward direction must be (0,0,1)
- !if( abs(normal_face(3,1,1) - 1.0 ) > 0.1 ) then
- ! print*,'error normal top',myrank,ispec
- ! print*,sngl(normal_face(:,1,1))
- !endif
- !if( abs(zstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) - 0.0) > 0.1 ) &
- ! print*,'error element top:',ispec,zstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
+ ! stores surface infos
+ if( .not. ABSORB_FREE_SURFACE ) then
+ ! store for free surface
+ !jacobian2D_top(:,:,ispec2D) = jacobian2Dw_face(:,:)
+ !normal_top(:,:,:,ispec2D) = normal_face(:,:,:)
- ! store for free surface
- jacobian2D_top(:,:,ispec2D) = jacobian2D_face(:,:)
- normal_top(:,:,:,ispec2D) = normal_face(:,:,:)
-
- ! store for absorbing boundaries
- if( ABSORB_FREE_SURFACE ) then
! sets face infos
+ ifree = ifree + 1
+ free_surface_ispec(ifree) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igllfree = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ igllfree = igllfree+1
+ free_surface_ijk(:,igllfree,ifree) = ijk_face(:,i,j)
+ free_surface_jacobian2Dw(igllfree,ifree) = jacobian2Dw_face(i,j)
+ free_surface_normal(:,igllfree,ifree) = normal_face(:,i,j)
+ enddo
+ enddo
+ else
+ ! adds face infos to absorbing boundary surface
iabs = iabs + 1
- absorbing_boundary_ispec(iabs) = ispec
+ abs_boundary_ispec(iabs) = ispec
! gll points -- assuming NGLLX = NGLLY = NGLLZ
igll = 0
do j=1,NGLLY
do i=1,NGLLX
igll = igll+1
- absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
- absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
- absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
enddo
enddo
+
+ ! resets free surface
+ ifree = 1
+ free_surface_ispec(:) = 0
+ free_surface_ijk(:,:,:) = 0
+ free_surface_jacobian2Dw(:,:) = 0.0
+ free_surface_normal(:,:,:) = 0.0
endif
enddo
- if( iabs /= num_absorbing_boundary_faces ) then
- print*,'error number of absorbing faces:',iabs,num_absorbing_boundary_faces
+! checks counters
+ if( ifree /= num_free_surface_faces ) then
+ print*,'error number of free surface faces:',ifree,num_free_surface_faces
+ stop 'error number of free surface faces'
+ endif
+
+ if( iabs /= num_abs_boundary_faces ) then
+ print*,'error number of absorbing faces:',iabs,num_abs_boundary_faces
stop 'error number of absorbing faces'
endif
- call sum_all_i(num_absorbing_boundary_faces,iabs)
+ call sum_all_i(num_abs_boundary_faces,iabs)
if( myrank == 0 ) then
write(IMAIN,*) ' absorbing boundary:'
write(IMAIN,*) ' total number of faces = ',iabs
@@ -1991,113 +1955,444 @@
! nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
-end subroutine create_regions_mesh_ext_mesh_setup_absorbing_bound
+end subroutine crm_ext_setup_abs_boundary
+
!
-!----
+!-------------------------------------------------------------------------------------------------
!
-subroutine create_regions_mesh_ext_mesh_prepare_MPI_interfaces(nglob,nspec,ibool, &
- nelmnts_ext_mesh,elmnts_ext_mesh, &
- my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
- ibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh, &
- num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
- xstore_dummy,ystore_dummy,zstore_dummy)
+subroutine crm_ext_detect_ac_el_surface(myrank, &
+ nspec,nglob,ibool,NPROC, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+! determines coupling surface for acoustic-elastic domains
-! sets up the MPI interface for communication between partitions
-
+ use create_regions_mesh_ext_par
implicit none
- include "constants.h"
+! number of spectral elements in each block
+ integer :: myrank,nspec,nglob,NPROC
- integer :: nglob,nspec
+! arrays with the mesh
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+! MPI communication
+ integer :: num_interfaces_ext_mesh,max_interface_size_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: my_neighbours_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
+
+! local parameters
+ ! (assumes NGLLX=NGLLY=NGLLZ)
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
+ real(kind=CUSTOM_REAL) :: jacobian2Dw_face(NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL) :: normal_face(NDIM,NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL),dimension(:,:,:),allocatable :: tmp_normal
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: tmp_jacobian2Dw
+ integer :: ijk_face(3,NGLLX,NGLLY)
+ integer,dimension(:,:,:),allocatable :: tmp_ijk
+ integer,dimension(:),allocatable :: tmp_ispec
+
+ integer,dimension(NGNOD2D) :: iglob_corners_ref !,iglob_corners
+ integer :: ispec,i,j,k,igll,ier,iglob
+ integer :: inum,iface_ref,icorner,iglob_midpoint ! iface,ispec_neighbor
+ integer :: count_elastic,count_acoustic
- integer :: nelmnts_ext_mesh
- integer, dimension(ESIZE,nelmnts_ext_mesh) :: elmnts_ext_mesh
+ ! mpi interface communication
+ integer, dimension(:), allocatable :: elastic_flag,acoustic_flag,test_flag
+ integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy
+ integer :: max_nibool_interfaces_ext_mesh
+ logical, dimension(:), allocatable :: mask_ibool
- integer :: num_interfaces_ext_mesh,max_interface_size_ext_mesh
+ ! corners indices of reference cube faces
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape( (/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape( (/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape( (/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape( (/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape( (/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ ! midpoint indices for each face (xmin,xmax,ymin,ymax,zmin,zmax)
+ integer,dimension(3,6),parameter :: iface_all_midpointijk = &
+ reshape( (/ 1,2,2, NGLLX,2,2, 2,1,2, 2,NGLLY,2, 2,2,1, 2,2,NGLLZ /),(/3,6/)) ! top
+
- 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
+ ! test vtk output
+ !integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: gll_data
+ !character(len=256):: prname_file
- 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
+! allocates temporary arrays
+ allocate(tmp_normal(NDIM,NGLLSQUARE,nspec*6))
+ allocate(tmp_jacobian2Dw(NGLLSQUARE,nspec*6))
+ allocate(tmp_ijk(3,NGLLSQUARE,nspec*6))
+ allocate(tmp_ispec(nspec*6))
+ tmp_ispec(:) = 0
+ tmp_ijk(:,:,:) = 0
+ tmp_normal(:,:,:) = 0.0
+ tmp_jacobian2Dw(:,:) = 0.0
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
-
-!local parameters
- double precision, dimension(:), allocatable :: xp,yp,zp
- double precision, dimension(:), allocatable :: work_ext_mesh
+ ! sets flags for acoustic / elastic on global points
+ allocate(elastic_flag(nglob),stat=ier)
+ allocate(acoustic_flag(nglob),stat=ier)
+ allocate(test_flag(nglob),stat=ier)
+ allocate(mask_ibool(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocate flag array'
+ elastic_flag(:) = 0
+ acoustic_flag(:) = 0
+ test_flag(:) = 0
+ count_elastic = 0
+ count_acoustic = 0
+ do ispec = 1, nspec
+ ! counts elements
+ if( ispec_is_elastic(ispec) ) count_elastic = count_elastic + 1
+ if( ispec_is_acoustic(ispec) ) count_acoustic = count_acoustic + 1
+
+ ! sets flags on global points
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ! global index
+ iglob = ibool(i,j,k,ispec)
+ ! sets elastic flag
+ if( ispec_is_elastic(ispec) ) elastic_flag(iglob) = myrank+1
+ ! sets acoustic flag
+ if( ispec_is_acoustic(ispec) ) acoustic_flag(iglob) = myrank+1
+ ! sets test flag
+ test_flag(iglob) = myrank+1
+ enddo
+ enddo
+ enddo
+ enddo
+ call sum_all_i(count_acoustic,inum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' total acoustic elements:',inum
+ endif
+ call sum_all_i(count_elastic,inum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' total elastic elements :',inum
+ endif
- integer, dimension(:), allocatable :: locval !,iglob
- integer, dimension(:), allocatable :: nibool_interfaces_ext_mesh_true
+ ! collects contributions from different MPI partitions
+ ! sets up MPI communications
+ 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(:,i) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,i)
+ enddo
+ ! sums elastic flags
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,elastic_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh_dummy,&
+ my_neighbours_ext_mesh)
+ ! sums acoustic flags
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,acoustic_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh_dummy,&
+ my_neighbours_ext_mesh)
-! for MPI buffers
- integer, dimension(:), allocatable :: reorder_interface_ext_mesh,ind_ext_mesh,ninseg_ext_mesh,iwork_ext_mesh
- integer, dimension(:), allocatable :: ibool_interface_ext_mesh_dummy
+ ! sums test flags
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,test_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh_dummy,&
+ my_neighbours_ext_mesh)
- logical, dimension(:), allocatable :: ifseg
+ ! loops over all element faces and
+ ! counts number of coupling faces between acoustic and elastic elements
+ mask_ibool(:) = .false.
+ inum = 0
+ do ispec=1,nspec
- integer :: iinterface,ilocnum
+ ! loops over each face
+ do iface_ref= 1, 6
+
+ ! takes indices of corners of reference face
+ do icorner = 1,NGNOD2D
+ i = iface_all_corner_ijk(1,icorner,iface_ref)
+ j = iface_all_corner_ijk(2,icorner,iface_ref)
+ k = iface_all_corner_ijk(3,icorner,iface_ref)
+ ! global reference indices
+ iglob_corners_ref(icorner) = ibool(i,j,k,ispec)
+
+ ! reference corner coordinates
+ xcoord(icorner) = xstore_dummy(iglob_corners_ref(icorner))
+ ycoord(icorner) = ystore_dummy(iglob_corners_ref(icorner))
+ zcoord(icorner) = zstore_dummy(iglob_corners_ref(icorner))
+ enddo
+
+ ! checks if face has acoustic side
+ if( acoustic_flag( iglob_corners_ref(1) ) >= 1 .and. &
+ acoustic_flag( iglob_corners_ref(2) ) >= 1 .and. &
+ acoustic_flag( iglob_corners_ref(3) ) >= 1 .and. &
+ acoustic_flag( iglob_corners_ref(4) ) >= 1) then
+ ! checks if face is has an elastic side
+ if( elastic_flag( iglob_corners_ref(1) ) >= 1 .and. &
+ elastic_flag( iglob_corners_ref(2) ) >= 1 .and. &
+ elastic_flag( iglob_corners_ref(3) ) >= 1 .and. &
+ elastic_flag( iglob_corners_ref(4) ) >= 1) then
+
+ ! reference midpoint on face (used to avoid redundant face counting)
+ i = iface_all_midpointijk(1,iface_ref)
+ j = iface_all_midpointijk(2,iface_ref)
+ k = iface_all_midpointijk(3,iface_ref)
+ iglob_midpoint = ibool(i,j,k,ispec)
+
+ ! checks if points on this face are masked already
+ if( .not. mask_ibool(iglob_midpoint) ) then
+
+ ! gets face GLL points i,j,k indices from element face
+ call get_element_face_gll_indices(iface_ref,ijk_face,NGLLX,NGLLY)
+
+ ! takes each element face only once, if it lies on an MPI interface
+ ! note: this is not exactly load balanced
+ ! lowest rank process collects as many faces as possible, second lowest as so forth
+ if( (test_flag(iglob_midpoint) == myrank+1) .or. &
+ (test_flag(iglob_midpoint) > 2*(myrank+1)) ) then
+
+ ! gets face GLL 2Djacobian, weighted from element face
+ call get_jacobian_boundary_face(myrank,nspec, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ ispec,iface_ref,jacobian2Dw_face,normal_face,NGLLX,NGLLY)
+
+ ! normal convention: points away from acoustic, reference element
+ ! switch normal direction if necessary
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! directs normals such that they point outwards of element
+ call get_element_face_normal(ispec,iface_ref,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ ! makes sure that it always points away from acoustic element, otherwise switch direction
+ if( ispec_is_elastic(ispec) ) normal_face(:,i,j) = - normal_face(:,i,j)
+ enddo
+ enddo
+
+ ! stores informations about this face
+ inum = inum + 1
+ tmp_ispec(inum) = ispec
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! adds all gll points on this face
+ igll = igll + 1
+
+ ! do we need to store local i,j,k,ispec info? or only global indices iglob?
+ tmp_ijk(:,igll,inum) = ijk_face(:,i,j)
+
+ ! stores weighted jacobian and normals
+ tmp_jacobian2Dw(igll,inum) = jacobian2Dw_face(i,j)
+ tmp_normal(:,igll,inum) = normal_face(:,i,j)
+
+ ! masks global points ( to avoid redundant counting of faces)
+ iglob = ibool(ijk_face(1,i,j),ijk_face(2,i,j),ijk_face(3,i,j),ispec)
+ mask_ibool(iglob) = .true.
+ enddo
+ enddo
+ else
+ ! assumes to be already collected by lower rank process, masks face points
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(ijk_face(1,i,j),ijk_face(2,i,j),ijk_face(3,i,j),ispec)
+ mask_ibool(iglob) = .true.
+ enddo
+ enddo
+ endif ! test_flag
+ endif ! mask_ibool
+ endif ! elastic_flag
+ endif ! acoustic_flag
+ enddo ! iface_ref
+ enddo ! ispec
+
+! stores completed coupling face informations
+!
+! note: no need to store material parameters on these coupling points
+! for acoustic-elastic interface
+ num_coupling_ac_el_faces = inum
+ allocate(coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_ispec(num_coupling_ac_el_faces))
+ do inum = 1,num_coupling_ac_el_faces
+ coupling_ac_el_normal(:,:,inum) = tmp_normal(:,:,inum)
+ coupling_ac_el_jacobian2Dw(:,inum) = tmp_jacobian2Dw(:,inum)
+ coupling_ac_el_ijk(:,:,inum) = tmp_ijk(:,:,inum)
+ coupling_ac_el_ispec(inum) = tmp_ispec(inum)
+ enddo
+
+! user output
+ call sum_all_i(num_coupling_ac_el_faces,inum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' acoustic-elastic coupling:'
+ write(IMAIN,*) ' total number of faces = ',inum
+ endif
+
+end subroutine crm_ext_detect_ac_el_surface
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine crm_ext_create_ocean_load_mass(nglob,nspec,ibool,OCEANS,&
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION,NX_TOPO,NY_TOPO, &
+ ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO, &
+ itopo_bathy)
+
+! returns precomputed mass matrix in rmass array
+ use create_regions_mesh_ext_par
+ implicit none
-! get global indices for MPI interfaces between different partitions
- call prepare_assemble_MPI (nelmnts_ext_mesh,ibool, &
- elmnts_ext_mesh, ESIZE, &
- nglob, &
- 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 &
- )
+! number of spectral elements in each block
+ integer :: nspec
+ integer :: nglob
+
+! arrays with the mesh global indices
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ logical :: OCEANS
- allocate(nibool_interfaces_ext_mesh_true(num_interfaces_ext_mesh))
+! use integer array to store topography values
+ integer :: UTM_PROJECTION_ZONE
+ logical :: SUPPRESS_UTM_PROJECTION
+ integer :: NX_TOPO,NY_TOPO
+ double precision :: ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
+ integer, dimension(NX_TOPO,NY_TOPO) :: itopo_bathy
-! sort ibool comm buffers lexicographically
- do iinterface = 1, num_interfaces_ext_mesh
+
+! local parameters
+ double precision :: weight
+ double precision :: xval,yval,long,lat,elevation
+ double precision :: height_oceans
+ double precision :: long_corner,lat_corner,ratio_xi,ratio_eta
+ integer :: ix_oceans,iy_oceans,iz_oceans,ispec_oceans,ispec2D,igll,iglobnum
+ integer :: icornerlong,icornerlat
- allocate(xp(nibool_interfaces_ext_mesh(iinterface)))
- allocate(yp(nibool_interfaces_ext_mesh(iinterface)))
- allocate(zp(nibool_interfaces_ext_mesh(iinterface)))
- allocate(locval(nibool_interfaces_ext_mesh(iinterface)))
- allocate(ifseg(nibool_interfaces_ext_mesh(iinterface)))
- allocate(reorder_interface_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
- allocate(ibool_interface_ext_mesh_dummy(nibool_interfaces_ext_mesh(iinterface)))
- allocate(ind_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
- allocate(ninseg_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
- allocate(iwork_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
- allocate(work_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+! creates ocean load mass matrix
+ if(OCEANS) then
- do ilocnum = 1, nibool_interfaces_ext_mesh(iinterface)
- xp(ilocnum) = xstore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
- yp(ilocnum) = ystore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
- zp(ilocnum) = zstore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
- enddo
+ ! adding ocean load mass matrix at ocean bottom
+ NGLOB_OCEAN = nglob
+ allocate(rmass_ocean_load(NGLOB_OCEAN))
- call sort_array_coordinates(nibool_interfaces_ext_mesh(iinterface),xp,yp,zp, &
- ibool_interfaces_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
- reorder_interface_ext_mesh,locval,ifseg,nibool_interfaces_ext_mesh_true(iinterface), &
- ind_ext_mesh,ninseg_ext_mesh,iwork_ext_mesh,work_ext_mesh)
+ ! create ocean load mass matrix for degrees of freedom at ocean bottom
+ rmass_ocean_load(:) = 0._CUSTOM_REAL
- deallocate(xp)
- deallocate(yp)
- deallocate(zp)
- deallocate(locval)
- deallocate(ifseg)
- deallocate(reorder_interface_ext_mesh)
- deallocate(ibool_interface_ext_mesh_dummy)
- deallocate(ind_ext_mesh)
- deallocate(ninseg_ext_mesh)
- deallocate(iwork_ext_mesh)
- deallocate(work_ext_mesh)
+ ! add contribution of the oceans for surface elements exactly at ocean bottom
+ do ispec2D = 1,num_free_surface_faces
- enddo
+ ispec_oceans = free_surface_ispec(ispec2D)
-end subroutine create_regions_mesh_ext_mesh_prepare_MPI_interfaces
+ ! only adds contribution if top boundary is elastic, no need to add this approximate calculation
+ ! if top is already acoustic/poroelastic
+ if( ispec_is_elastic(ispec_oceans) ) then
+ do igll=1,NGLLSQUARE
+ ix_oceans = free_surface_ijk(1,igll,ispec2D)
+ iy_oceans = free_surface_ijk(1,igll,ispec2D)
+ iz_oceans = free_surface_ijk(1,igll,ispec2D)
+
+
+! iz_oceans = NGLLZ
+! do ix_oceans = 1,NGLLX
+! do iy_oceans = 1,NGLLY
+
+ iglobnum=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+
+ ! compute local height of oceans
+
+ ! get coordinates of current point
+ xval = xstore_dummy(iglobnum)
+ yval = ystore_dummy(iglobnum)
+
+ ! project x and y in UTM back to long/lat since topo file is in long/lat
+ call utm_geo(long,lat,xval,yval,UTM_PROJECTION_ZONE,IUTM2LONGLAT,SUPPRESS_UTM_PROJECTION)
+
+ ! get coordinate of corner in bathy/topo model
+ icornerlong = int((long - ORIG_LONG_TOPO) / DEGREES_PER_CELL_TOPO) + 1
+ icornerlat = int((lat - ORIG_LAT_TOPO) / DEGREES_PER_CELL_TOPO) + 1
+
+ ! avoid edge effects and extend with identical point if outside model
+ if(icornerlong < 1) icornerlong = 1
+ if(icornerlong > NX_TOPO-1) icornerlong = NX_TOPO-1
+ if(icornerlat < 1) icornerlat = 1
+ if(icornerlat > NY_TOPO-1) icornerlat = NY_TOPO-1
+
+ ! compute coordinates of corner
+ long_corner = ORIG_LONG_TOPO + (icornerlong-1)*DEGREES_PER_CELL_TOPO
+ lat_corner = ORIG_LAT_TOPO + (icornerlat-1)*DEGREES_PER_CELL_TOPO
+
+ ! compute ratio for interpolation
+ ratio_xi = (long - long_corner) / DEGREES_PER_CELL_TOPO
+ ratio_eta = (lat - lat_corner) / DEGREES_PER_CELL_TOPO
+
+ ! avoid edge effects
+ if(ratio_xi < 0.) ratio_xi = 0.
+ if(ratio_xi > 1.) ratio_xi = 1.
+ if(ratio_eta < 0.) ratio_eta = 0.
+ if(ratio_eta > 1.) ratio_eta = 1.
+
+ ! interpolate elevation at current point
+ elevation = &
+ itopo_bathy(icornerlong,icornerlat)*(1.-ratio_xi)*(1.-ratio_eta) + &
+ itopo_bathy(icornerlong+1,icornerlat)*ratio_xi*(1.-ratio_eta) + &
+ itopo_bathy(icornerlong+1,icornerlat+1)*ratio_xi*ratio_eta + &
+ itopo_bathy(icornerlong,icornerlat+1)*(1.-ratio_xi)*ratio_eta
+
+ ! suppress positive elevation, which means no oceans
+ if(elevation >= - MINIMUM_THICKNESS_3D_OCEANS) then
+ height_oceans = 0.d0
+ else
+ height_oceans = dabs(elevation)
+ endif
+
+ ! take into account inertia of water column
+ !weight = wxgll(ix_oceans)*wygll(iy_oceans) &
+ ! * dble(jacobian2D_top(ix_oceans,iy_oceans,ispec2D_ocean_bottom)) &
+ ! * dble(RHO_OCEANS) * height_oceans
+
+ weight = dble( free_surface_jacobian2Dw(igll,ispec2D)) &
+ * dble(RHO_OCEANS) * height_oceans
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + sngl(weight)
+ else
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + weight
+ endif
+
+ enddo ! igll
+ endif ! ispec_is_elastic
+ enddo ! num_free_surface_faces
+
+ ! add regular mass matrix to ocean load contribution
+ rmass_ocean_load(:) = rmass_ocean_load(:) + rmass(:)
+
+ else
+
+ ! allocate dummy array if no oceans
+ NGLOB_OCEAN = 1
+ allocate(rmass_ocean_load(NGLOB_OCEAN))
+
+ endif
+
+end subroutine crm_ext_create_ocean_load_mass
+
+
!pll
! subroutine interface(iflag,flag_below,flag_above,ispec,nspec,i,j,k,xstore,ystore,zstore,ibedrock)
@@ -2206,3 +2501,34 @@
! end subroutine interface
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine bubble_sort( arr, ndim )
+
+! sorts values in array arr[ndim] in increasing order
+
+ implicit none
+
+ integer :: ndim
+ integer :: arr(ndim)
+
+ logical :: swapped
+ integer :: j,tmp
+
+ swapped = .true.
+ do while( swapped )
+ swapped = .false.
+ do j = 1, ndim-1
+ if( arr(j+1) < arr(j) ) then
+ tmp = arr(j)
+ arr(j) = arr(j+1)
+ arr(j+1) = tmp
+ swapped = .true.
+ endif
+ enddo
+ enddo
+
+end subroutine bubble_sort
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_serial_name_database.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_serial_name_database.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_serial_name_database.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -34,7 +34,7 @@
integer iproc,NPROC
! name of the database file
- character(len=150) prname,procname,LOCAL_PATH,clean_LOCAL_PATH,serial_prefix,OUTPUT_FILES
+ character(len=256) prname,procname,LOCAL_PATH,clean_LOCAL_PATH,serial_prefix,OUTPUT_FILES
integer iprocloop,nproc_max_loop
integer, dimension(:), allocatable :: num_active_proc
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/OUTPUT_FILES/cubit2specfem3d.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/OUTPUT_FILES/cubit2specfem3d.py 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/OUTPUT_FILES/cubit2specfem3d.py 2009-11-21 02:18:44 UTC (rev 16023)
@@ -33,7 +33,8 @@
# automatically using the module boundary_definition (see boundary_definition.py for more information)
#or
# manually following the convention:
-# - each material should have a block defined by name,flag of the material (integer),p velocity
+# - each material should have a block defined by:
+# material domain_flag (acoustic/elastic/poroelastic)name,flag of the material (integer),p velocity
# (or the full description: name, flag, vp, vs, rho, Q ... if not present these last 3 parameters will be
# interpolated by module mat_parameter)
# - each mesh should have the block definition for the face on the free_surface (topography),
@@ -371,20 +372,35 @@
for block in blocks:
name=cubit.get_exodus_entity_name('block',block)
ty=cubit.get_block_element_type(block)
- print block,blocks,ty,self.hex,self.face
+ print block,name,blocks,ty,self.hex,self.face
if ty == self.hex:
- nattrib=cubit.get_block_attribute_count(block)
flag=None
vel=None
vs=None
rho=None
- q=None
- ani=None
+ q=0
+ ani=0
+ # material domain id
+ if name == "acoustic" :
+ imaterial = 1
+ elif name == "elastic" :
+ imaterial = 2
+ elif name == "poroelastic" :
+ imaterial = 3
+ else :
+ imaterial = 0
+
+ nattrib=cubit.get_block_attribute_count(block)
if nattrib != 0:
- flag=int(cubit.get_block_attribute_value(block,0))
+ # material flag:
+ # positive => material properties,
+ # negative => interface/tomography domain
+ flag=int(cubit.get_block_attribute_value(block,0))
if flag > 0 and nattrib >= 2:
+ # vp
vel=cubit.get_block_attribute_value(block,1)
if nattrib >= 3:
+ # vs
vs=cubit.get_block_attribute_value(block,2)
if nattrib >= 4:
#density
@@ -402,6 +418,7 @@
#anisotropy_flag
ani=cubit.get_block_attribute_value(block,5)
elif flag < 0:
+ # velocity model
vel=name
attrib=cubit.get_block_attribute_value(block,1)
if attrib == 1:
@@ -416,19 +433,19 @@
block_flag.append(int(flag))
block_mat.append(block)
if flag > 0:
- par=tuple([flag,vel,vs,rho,q,ani])
+ par=tuple([imaterial,flag,vel,vs,rho,q,ani])
elif flag < 0:
if kind=='interface':
- par=tuple([flag,kind,name,flag_down,flag_up])
+ par=tuple([imaterial,flag,kind,name,flag_down,flag_up])
elif kind=='tomography':
- par=tuple([flag,kind,name])
+ par=tuple([imaterial,flag,kind,name])
elif flag==0:
- par=tuple([flag,name])
- material[name]=par
+ par=tuple([imaterial,flag,name])
+ material[block]=par
elif ty == self.face: #Stacey condition, we need hex here for pml
block_bc_flag.append(4)
block_bc.append(block)
- bc[name]=4 #face has connectivity = 4
+ bc[block]=4 #face has connectivity = 4
if name == self.topo: topography_face=block
else:
print 'blocks no properly defined',ty
@@ -463,36 +480,39 @@
#TODO: material property acoustic/elastic/poroelastic ? .... where?
print "#material properties:"
print properties
- flag=properties[0]
+ imaterial=properties[0]
+ flag=properties[1]
if flag > 0:
- vel=properties[1]
- if properties[2] is None and type(vel) != str:
+ vel=properties[2]
+ if properties[3] is None and type(vel) != str:
+ # velocity model scales with given vp value
if vel >= 30:
m2km=1000.
else:
m2km=1.
vp=vel/m2km
rho=(1.6612*vp-0.472*vp**2+0.0671*vp**3-0.0043*vp**4+0.000106*vp**4)*m2km
- txt='%3i %20f %20f %20f %1i %1i\n' % (properties[0],rho,vel,vel/(3**.5),0,0)
+ txt='%1i %3i %20f %20f %20f %1i %1i\n' % (properties[0],properties[1],rho,vel,vel/(3**.5),0,0)
elif type(vel) != str:
- #format nummaterials file: #material_id #rho #vp #vs #Q_flag #anisotropy_flag
- txt='%3i %20f %20f %20f %2i %2i\n' % (properties[0],properties[3], \
- properties[1],properties[2],properties[4],properties[5])
+ # velocity model given as vp,vs,rho,..
+ #format nummaterials file: #material_domain_id #material_id #rho #vp #vs #Q_flag #anisotropy_flag
+ txt='%1i %3i %20f %20f %20f %2i %2i\n' % (properties[0],properties[1],properties[4], \
+ properties[2],properties[3],properties[5],properties[6])
else:
- txt='%3i %s \n' % (properties[0],properties[1])
+ txt='%1i %3i %s \n' % (properties[0],properties[1],properties[2])
elif flag < 0:
- if properties[1] == 'tomography':
- txt='%3i %s %s\n' % (properties[0],properties[1],properties[2])
- elif properties[1] == 'interface':
- txt='%3i %s %s %1i %1i\n' % (properties[0],properties[1],properties[2],\
- properties[3],properties[4])
+ if properties[2] == 'tomography':
+ txt='%1i %3i %s %s\n' % (properties[0],properties[1],properties[2],properties[3])
+ elif properties[2] == 'interface':
+ txt='%1i %3i %s %s %1i %1i\n' % (properties[0],properties[1],properties[2],properties[3],\
+ properties[4],properties[5])
return txt
def nummaterial_write(self,nummaterial_name):
print 'Writing '+nummaterial_name+'.....'
nummaterial=open(nummaterial_name,'w')
for block in self.block_mat:
- name=cubit.get_exodus_entity_name('block',block)
- nummaterial.write(self.mat_parameter(self.material[name]))
+ #name=cubit.get_exodus_entity_name('block',block)
+ nummaterial.write(self.mat_parameter(self.material[block]))
nummaterial.close()
print 'Ok'
def mesh_write(self,mesh_name):
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/README
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/README 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/README 2009-11-21 02:18:44 UTC (rev 16023)
@@ -13,7 +13,7 @@
to compile this executable xdecompose_mesh_SCOTCH for partitioning your mesh files
****
- 1. create mesh using CUBIT and scripts boundary_definity.py and
+ 1. create mesh using CUBIT and scripts boundary_definition.py and
cubit2specfem3D.py to generate all mesh files
2. compile executable "xdecompose_mesh_SCOTCH" in this directory decompose_mesh_SCOTCH/:
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-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -9,8 +9,7 @@
include './scotchf.h'
! number of partitions
-! integer, parameter :: nparts = 4
- integer :: nparts != 4
+ integer :: nparts ! e.g. 4 for partitioning for 4 processes/CPUs
! mesh arrays
integer(long) :: nspec
@@ -25,6 +24,7 @@
integer, dimension(:), allocatable :: adjncy
integer, dimension(:), allocatable :: nnodes_elmnts
integer, dimension(:), allocatable :: nodes_elmnts
+ integer, dimension(:), allocatable :: elmnts_load
integer, dimension(:), pointer :: glob2loc_elmnts
integer, dimension(:), pointer :: glob2loc_nodes_nparts
@@ -63,7 +63,7 @@
double precision, dimension(SCOTCH_GRAPHDIM) :: scotchgraph
double precision, dimension(SCOTCH_STRATDIM) :: scotchstrat
character(len=256), parameter :: scotch_strategy='b{job=t,map=t,poli=S,sep=h{pass=30}}'
- integer :: ierr
+ integer :: ierr,idummy
!integer :: i
!pll
@@ -75,6 +75,9 @@
character(len=256) :: localpath_name ! './OUTPUT_FILES'
character(len=256) :: outputpath_name ! './OUTPUT_FILES'
+ integer :: q_flag,aniso_flag,idomain_id
+ double precision :: vp,vs,rho
+
contains
!----------------------------------------------------------------------------------------------
@@ -167,7 +170,8 @@
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
+ ! note: format #material_domain_id #material_id #...
+ read(98,*,iostat=ierr) idummy,num_mat
print *,'materials:'
! counts materials (defined/undefined)
do while (ierr == 0)
@@ -177,7 +181,7 @@
else
count_undef_mat = count_undef_mat + 1
end if
- read(98,*,iostat=ierr) num_mat
+ read(98,*,iostat=ierr) idummy,num_mat
end do
close(98)
print*, ' defined = ',count_def_mat, 'undefined = ',count_undef_mat
@@ -188,15 +192,23 @@
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))
+ allocate(mat_prop(6,count_def_mat))
+ allocate(undef_mat_prop(6,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)
+ ! format: #(6) material_domain_id #(0) material_id #(1) rho #(2) vp #(3) vs #(4) Q_flag #(5) anisotropy_flag
+ read(98,*) idomain_id,num_mat,rho,vp,vs,q_flag,aniso_flag
+ !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)
+ mat_prop(1,num_mat) = rho
+ mat_prop(2,num_mat) = vp
+ mat_prop(3,num_mat) = vs
+ mat_prop(4,num_mat) = q_flag
+ mat_prop(5,num_mat) = aniso_flag
+ mat_prop(6,num_mat) = idomain_id
+
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, ....
@@ -206,9 +218,8 @@
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)
+ read(98,'(6A30)') undef_mat_prop(6,imat),undef_mat_prop(1,imat),undef_mat_prop(2,imat),&
+ undef_mat_prop(3,imat),undef_mat_prop(4,imat),undef_mat_prop(5,imat)
end do
close(98)
@@ -373,14 +384,16 @@
!----------------------------------------------------------------------------------------------
subroutine scotch_partitioning
-
+
+ implicit none
+
elmnts(:,:) = elmnts(:,:) - 1
+ ! determines maximum neighbors based on 1 common node
allocate(xadj(1:nspec+1))
allocate(adjncy(1:sup_neighbour*nspec))
allocate(nnodes_elmnts(1:nnodes))
- allocate(nodes_elmnts(1:nsize*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: '
@@ -392,48 +405,84 @@
allocate(part(1:nspec))
part(:) = -1
-
+ ! initializes
+ ! elements load array
+ allocate(elmnts_load(1:nspec))
+
+ ! uniform load
+ elmnts_load(:) = 1
+
+ ! in case of acoustic/elastic simulation, weights elements accordingly
+ call acoustic_elastic_load(elmnts_load,nspec,count_def_mat,mat(1,:),mat_prop)
+
! SCOTCH partitioning
- call scotchfstratinit (scotchstrat(1), ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Cannot initialize strat'
- endif
+ 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
+ call scotchfstratgraphmap (scotchstrat(1), trim(scotch_strategy), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot build strat'
+ endif
- call scotchfgraphinit (scotchgraph (1), ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Cannot initialize graph'
- endif
+ call scotchfgraphinit (scotchgraph (1), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot initialize graph'
+ 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
+ ! fills graph structure : see user manual (scotch_user5.1.pdf, page 72/73)
+ ! arguments: #(1) graph_structure #(2) baseval(either 0/1) #(3) number_of_vertices
+ ! #(4) adjacency_index_array #(5) adjacency_end_index_array (optional)
+ ! #(6) vertex_load_array (optional) #(7) vertex_label_array
+ ! #(7) number_of_arcs #(8) adjacency_array
+ ! #(9) arc_load_array (optional) #(10) ierror
+ call scotchfgraphbuild (scotchgraph (1), 0, nspec, &
+ xadj (1), xadj (1), &
+ elmnts_load (1), xadj (1), &
+ nb_edges, adjncy (1), &
+ adjncy (1), ierr)
- call scotchfgraphcheck (scotchgraph (1), ierr)
- if (ierr /= 0) then
- stop 'ERROR : MAIN : Invalid check'
- endif
+ ! w/out element load, but adjacency array
+ !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
+ call scotchfgraphexit (scotchgraph (1), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot destroy graph'
+ endif
+
+ call scotchfstratexit (scotchstrat(1), ierr)
+ if (ierr /= 0) then
+ stop 'ERROR : MAIN : Cannot destroy strat'
+ endif
+
+
+ ! re-partitioning puts acoustic-elastic coupled elements into same partition
+ ! integer :: nfaces_coupled
+ ! integer, dimension(:,:), pointer :: faces_coupled
+ ! call acoustic_elastic_repartitioning (nspec, nnodes, elmnts, &
+ ! count_def_mat, mat(1,:) , mat_prop, &
+ ! sup_neighbour, nsize, &
+ ! nproc, part, nfaces_coupled, faces_coupled)
! local number of each element for each partition
call Construct_glob2loc_elmnts(nspec, part, glob2loc_elmnts,nparts)
@@ -442,10 +491,18 @@
call Construct_glob2loc_nodes(nspec, nnodes,nsize, nnodes_elmnts, nodes_elmnts, part, &
glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes, nparts)
+ ! mpi interfaces
+ ! acoustic/elastic boundaries WILL BE SEPARATED into different MPI partitions
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)
+ tab_size_interfaces, ninterfaces, &
+ nparts)
+ !or: acoustic/elastic boundaries will NOT be separated into different MPI partitions
+ !call Construct_interfaces_no_acoustic_elastic_separation(nspec, &
+ ! sup_neighbour, part, elmnts, xadj, adjncy, tab_interfaces, &
+ ! tab_size_interfaces, ninterfaces, &
+ ! count_def_mat, mat_prop(3,:), mat(1,:), nparts)
+
end subroutine scotch_partitioning
!----------------------------------------------------------------------------------------------
@@ -457,8 +514,10 @@
allocate(my_interfaces(0:ninterfaces-1))
allocate(my_nb_interfaces(0:ninterfaces-1))
+ ! writes out Database file for each partition
do ipart = 0, nparts-1
+ ! opens output file
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)
@@ -469,13 +528,17 @@
stop 'error file open Database'
endif
+ ! gets number of nodes
call write_glob2loc_nodes_database(15, ipart, nnodes_loc, nodes_coords, &
glob2loc_nodes_nparts, glob2loc_nodes_parts, &
glob2loc_nodes, nnodes, 1)
+
+ ! gets number of spectral elements
call write_partition_database(15, ipart, nspec_loc, nspec, elmnts, &
glob2loc_elmnts, glob2loc_nodes_nparts, &
glob2loc_nodes_parts, glob2loc_nodes, part, mat, ngnod, 1)
+ ! writes out node coordinate locations
write(15,*) nnodes_loc
call write_glob2loc_nodes_database(15, ipart, nnodes_loc, nodes_coords,&
@@ -484,13 +547,15 @@
call write_material_properties_database(15,count_def_mat,count_undef_mat, &
mat_prop, undef_mat_prop)
-
+
+ ! writes out spectral element indices
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)
-
+
+ ! writes out absorbing/free-surface boundaries
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, &
@@ -500,11 +565,13 @@
glob2loc_elmnts, glob2loc_nodes_nparts, &
glob2loc_nodes_parts, glob2loc_nodes, part)
+ ! gets number of MPI 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, 1, nparts)
-
+
+ ! writes out MPI interfaces elements
write(15,*) my_ninterface, maxval(my_nb_interfaces)
call Write_interfaces_database(15, tab_interfaces, tab_size_interfaces, ipart, ninterfaces, &
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-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -14,6 +14,11 @@
! very large and very small values
double precision, parameter :: HUGEVAL = 1.d+30,TINYVAL = 1.d-9
+! acoustic-elastic load balancing:
+! assumes that elastic at least ~6 times more expensive than acoustic
+ integer, parameter :: ACOUSTIC_LOAD = 1
+ integer, parameter :: ELASTIC_LOAD = 4
+
! include './constants_decompose_mesh_SCOTCH.h'
contains
@@ -21,8 +26,10 @@
!-----------------------------------------------
! Creating dual graph (adjacency is defined by 'ncommonnodes' between two elements).
!-----------------------------------------------
- subroutine mesh2dual_ncommonnodes(nelmnts, nnodes, nsize, sup_neighbour, elmnts, xadj, adjncy, &
- nnodes_elmnts, nodes_elmnts, max_neighbour, ncommonnodes)
+ subroutine mesh2dual_ncommonnodes(nelmnts, nnodes, nsize, sup_neighbour, elmnts,&
+ xadj, adjncy, &
+ nnodes_elmnts, nodes_elmnts, &
+ max_neighbour, ncommonnodes)
! include './constants_decompose_mesh_SCOTCH.h'
@@ -56,7 +63,6 @@
do i = 0, esize*nelmnts-1
nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/esize
nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
-
end do
! checking which elements are neighbours ('ncommonnodes' criteria)
@@ -242,11 +248,127 @@
! Two adjacent elements in distinct partitions make an entry in array tab_interfaces :
! 1/ first element, 2/ second element, 3/ number of common nodes, 4/ first node,
! 5/ second node, if relevant.
- ! No interface between acoustic and elastic elements.
+
+ ! interface ignores acoustic and elastic elements
+
! 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, &
+ nparts)
+
+ integer(long), intent(in) :: nelmnts, sup_neighbour
+ integer, dimension(0:nelmnts-1), intent(in) :: part
+ integer, dimension(0:esize*nelmnts-1), intent(in) :: elmnts
+ integer, dimension(0:nelmnts), intent(in) :: xadj
+ integer, dimension(0:sup_neighbour*nelmnts-1), intent(in) :: adjncy
+ integer, dimension(:),pointer :: tab_size_interfaces, tab_interfaces
+ integer, intent(out) :: ninterfaces
+
+ integer, intent(in) :: nparts
+
+ ! local parameters
+ integer :: num_part, num_part_bis, el, el_adj, num_interface, num_edge, ncommon_nodes, &
+ num_node, num_node_bis
+ integer :: i, j
+
+ ! counts number of interfaces between partitions
+ ninterfaces = 0
+ do i = 0, nparts-1
+ do j = i+1, nparts-1
+ ninterfaces = ninterfaces + 1
+ end do
+ end do
+
+ allocate(tab_size_interfaces(0:ninterfaces))
+ tab_size_interfaces(:) = 0
+
+ num_interface = 0
+ num_edge = 0
+
+! determines acoustic/elastic elements based upon given vs velocities
+! and counts same elements for each interface
+ do num_part = 0, nparts-1
+ do num_part_bis = num_part+1, nparts-1
+ do el = 0, nelmnts-1
+ if ( part(el) == num_part ) then
+ ! looks at all neighbor elements
+ do el_adj = xadj(el), xadj(el+1)-1
+ ! adds element if neighbor element lies in next partition
+ if ( part(adjncy(el_adj)) == num_part_bis ) then
+ num_edge = num_edge + 1
+ end if
+
+ end do
+ end if
+ end do
+ ! stores number of elements at interface
+ tab_size_interfaces(num_interface+1) = tab_size_interfaces(num_interface) + num_edge
+ num_edge = 0
+ num_interface = num_interface + 1
+
+ end do
+ end do
+
+
+! stores element indices for elements from above search at each interface
+ num_interface = 0
+ num_edge = 0
+
+ allocate(tab_interfaces(0:(tab_size_interfaces(ninterfaces)*7-1)))
+ tab_interfaces(:) = 0
+
+ do num_part = 0, nparts-1
+ do num_part_bis = num_part+1, nparts-1
+ do el = 0, nelmnts-1
+ if ( part(el) == num_part ) then
+ do el_adj = xadj(el), xadj(el+1)-1
+ ! adds element if in adjacent partition
+ if ( part(adjncy(el_adj)) == num_part_bis ) then
+ tab_interfaces(tab_size_interfaces(num_interface)*7+num_edge*7+0) = el
+ tab_interfaces(tab_size_interfaces(num_interface)*7+num_edge*7+1) = adjncy(el_adj)
+ ncommon_nodes = 0
+ do num_node = 0, esize-1
+ do num_node_bis = 0, esize-1
+ if ( elmnts(el*esize+num_node) == elmnts(adjncy(el_adj)*esize+num_node_bis) ) then
+ tab_interfaces(tab_size_interfaces(num_interface)*7+num_edge*7+3+ncommon_nodes) &
+ = elmnts(el*esize+num_node)
+ ncommon_nodes = ncommon_nodes + 1
+ end if
+ end do
+ end do
+ if ( ncommon_nodes > 0 ) then
+ tab_interfaces(tab_size_interfaces(num_interface)*7+num_edge*7+2) = ncommon_nodes
+ else
+ print *, "Error while building interfaces!", ncommon_nodes
+ end if
+ num_edge = num_edge + 1
+ end if
+ end do
+ end if
+
+ end do
+ num_edge = 0
+ num_interface = num_interface + 1
+ end do
+ end do
+
+ end subroutine Construct_interfaces
+
+
+ !--------------------------------------------------
+ ! Construct interfaces between each partitions.
+ ! Two adjacent elements in distinct partitions make an entry in array tab_interfaces :
+ ! 1/ first element, 2/ second element, 3/ number of common nodes, 4/ first node,
+ ! 5/ second node, if relevant.
+
+ ! No interface between acoustic and elastic elements.
+
+ ! Elements with undefined material are considered as elastic elements.
+ !--------------------------------------------------
+ subroutine Construct_interfaces_no_acoustic_elastic_separation(nelmnts, &
+ sup_neighbour, part, elmnts, xadj, adjncy, &
+ tab_interfaces, tab_size_interfaces, ninterfaces, &
nb_materials, cs_material, num_material,nparts)
! include './constants_decompose_mesh_SCOTCH.h'
@@ -259,15 +381,18 @@
integer, dimension(:),pointer :: tab_size_interfaces, tab_interfaces
integer, intent(out) :: ninterfaces
integer, dimension(1:nelmnts), intent(in) :: num_material
+ ! vs velocities
double precision, dimension(1:nb_materials), intent(in) :: cs_material
+
integer, intent(in) :: nb_materials,nparts
-
+ ! local parameters
integer :: num_part, num_part_bis, el, el_adj, num_interface, num_edge, ncommon_nodes, &
num_node, num_node_bis
integer :: i, j
logical :: is_acoustic_el, is_acoustic_el_adj
+ ! counts number of interfaces between partitions
ninterfaces = 0
do i = 0, nparts-1
do j = i+1, nparts-1
@@ -281,10 +406,13 @@
num_interface = 0
num_edge = 0
+! determines acoustic/elastic elements based upon given vs velocities
+! and counts same elements for each interface
do num_part = 0, nparts-1
do num_part_bis = num_part+1, nparts-1
do el = 0, nelmnts-1
if ( part(el) == num_part ) then
+ ! determines whether element is acoustic or not
if(num_material(el+1) > 0) then
if ( cs_material(num_material(el+1)) < TINYVAL) then
is_acoustic_el = .true.
@@ -294,7 +422,9 @@
else
is_acoustic_el = .false.
end if
+ ! looks at all neighbor elements
do el_adj = xadj(el), xadj(el+1)-1
+ ! determines whether neighbor element is acoustic or not
if(num_material(adjncy(el_adj)+1) > 0) then
if ( cs_material(num_material(adjncy(el_adj)+1)) < TINYVAL) then
is_acoustic_el_adj = .true.
@@ -304,13 +434,14 @@
else
is_acoustic_el_adj = .false.
end if
+ ! adds element if neighbor element has same material acoustic/not-acoustic and lies in next partition
if ( (part(adjncy(el_adj)) == num_part_bis) .and. (is_acoustic_el .eqv. is_acoustic_el_adj) ) then
num_edge = num_edge + 1
-
end if
end do
end if
end do
+ ! stores number of elements at interface
tab_size_interfaces(num_interface+1) = tab_size_interfaces(num_interface) + num_edge
num_edge = 0
num_interface = num_interface + 1
@@ -318,6 +449,8 @@
end do
end do
+
+! stores element indices for elements from above search at each interface
num_interface = 0
num_edge = 0
@@ -376,11 +509,10 @@
end do
end do
+ end subroutine Construct_interfaces_no_acoustic_elastic_separation
- end subroutine Construct_interfaces
-
!--------------------------------------------------
! Write nodes (their coordinates) pertaining to iproc partition in the corresponding Database
!--------------------------------------------------
@@ -399,8 +531,8 @@
integer :: i, j
if ( num_phase == 1 ) then
+ ! counts number of points in partition
npgeo = 0
-
do i = 0, nnodes-1
do j = glob2loc_nodes_nparts(i), glob2loc_nodes_nparts(i+1)-1
if ( glob2loc_nodes_parts(j) == iproc ) then
@@ -411,6 +543,7 @@
end do
end do
else
+ ! writes out point coordinates
do i = 0, nnodes-1
do j = glob2loc_nodes_nparts(i), glob2loc_nodes_nparts(i+1)-1
if ( glob2loc_nodes_parts(j) == iproc ) then
@@ -430,18 +563,20 @@
integer, intent(in) :: IIN_database
integer, intent(in) :: count_def_mat,count_undef_mat
- double precision, dimension(5,count_def_mat) :: mat_prop
- character (len=30), dimension(5,count_undef_mat) :: undef_mat_prop
+ double precision, dimension(6,count_def_mat) :: mat_prop
+ character (len=30), dimension(6,count_undef_mat) :: undef_mat_prop
integer :: i
write(IIN_database,*) count_def_mat,count_undef_mat
do i = 1, count_def_mat
- ! format: # rho # vp # vs # Q_flag # 0
- write(IIN_database,*) mat_prop(1,i), mat_prop(2,i), mat_prop(3,i), mat_prop(4,i), mat_prop(5,i)
+ ! format: #rho #vp #vs #Q_flag #anisotropy_flag #domain_id
+ write(IIN_database,*) mat_prop(1,i), mat_prop(2,i), mat_prop(3,i), &
+ mat_prop(4,i), mat_prop(5,i), mat_prop(6,i)
end do
do i = 1, count_undef_mat
- write(IIN_database,*) trim(undef_mat_prop(1,i)),trim(undef_mat_prop(2,i)),trim(undef_mat_prop(3,i)), &
- trim(undef_mat_prop(4,i)),trim(undef_mat_prop(5,i))
+ write(IIN_database,*) trim(undef_mat_prop(1,i)),trim(undef_mat_prop(2,i)), &
+ trim(undef_mat_prop(3,i)),trim(undef_mat_prop(4,i)), &
+ trim(undef_mat_prop(5,i)),trim(undef_mat_prop(6,i))
end do
end subroutine write_material_properties_database
@@ -723,16 +858,16 @@
integer, dimension(0:ngnod-1) :: loc_nodes
if ( num_phase == 1 ) then
+ ! counts number of spectral elements in this partition
nspec = 0
-
do i = 0, nelmnts-1
if ( part(i) == iproc ) then
nspec = nspec + 1
-
end if
end do
else
+ ! writes out element corner indices
do i = 0, nelmnts-1
if ( part(i) == iproc ) then
@@ -741,7 +876,6 @@
if ( glob2loc_nodes_parts(k) == iproc ) then
loc_nodes(j) = glob2loc_nodes(k)
-
end if
end do
@@ -785,18 +919,24 @@
integer :: i, j, k, l
integer :: num_interface
+ integer :: count_faces
+
num_interface = 0
if ( num_phase == 1 ) then
-
+ ! counts number of interfaces to neighbouring partitions
my_interfaces(:) = 0
my_nb_interfaces(:) = 0
-
- do i = 0, nparts-1
+
+ ! double loops over all partitions
+ do i = 0, nparts-1
do j = i+1, nparts-1
+ ! only counts if specified partition (iproc) appears and interface elements increment
if ( (tab_size_interfaces(num_interface) < tab_size_interfaces(num_interface+1)) .and. &
(i == iproc .or. j == iproc) ) then
+ ! sets flag
my_interfaces(num_interface) = 1
+ ! sets number of elements on interface
my_nb_interfaces(num_interface) = tab_size_interfaces(num_interface+1) - tab_size_interfaces(num_interface)
end if
num_interface = num_interface + 1
@@ -805,7 +945,7 @@
my_ninterface = sum(my_interfaces(:))
else
-
+ ! writes out MPI interface elements
do i = 0, nparts-1
do j = i+1, nparts-1
if ( my_interfaces(num_interface) == 1 ) then
@@ -814,7 +954,8 @@
else
write(IIN_database,*) i, my_nb_interfaces(num_interface)
end if
-
+
+ count_faces = 0
do k = tab_size_interfaces(num_interface), tab_size_interfaces(num_interface+1)-1
if ( i == iproc ) then
local_elmnt = glob2loc_elmnts(tab_interfaces(k*7+0))+1
@@ -852,6 +993,7 @@
!!$ end if
select case (tab_interfaces(k*7+2))
case (1)
+ ! single point element
do l = glob2loc_nodes_nparts(tab_interfaces(k*7+3)), &
glob2loc_nodes_nparts(tab_interfaces(k*7+3)+1)-1
if ( glob2loc_nodes_parts(l) == iproc ) then
@@ -860,6 +1002,7 @@
end do
write(IIN_database,*) local_elmnt, tab_interfaces(k*7+2), local_nodes(1), -1, -1, -1
case (2)
+ ! edge element
do l = glob2loc_nodes_nparts(tab_interfaces(k*7+3)), &
glob2loc_nodes_nparts(tab_interfaces(k*7+3)+1)-1
if ( glob2loc_nodes_parts(l) == iproc ) then
@@ -874,6 +1017,8 @@
end do
write(IIN_database,*) local_elmnt, tab_interfaces(k*7+2), local_nodes(1), local_nodes(2), -1, -1
case (4)
+ ! face element
+ count_faces = count_faces + 1
do l = glob2loc_nodes_nparts(tab_interfaces(k*7+3)), &
glob2loc_nodes_nparts(tab_interfaces(k*7+3)+1)-1
if ( glob2loc_nodes_parts(l) == iproc ) then
@@ -904,7 +1049,11 @@
print *, "error in write_interfaces_database!", tab_interfaces(k*7+2), iproc
end select
end do
-
+
+ ! outputs infos
+ !print*,' partition MPI interface:',iproc,num_interface
+ !print*,' element faces: ',count_faces
+
end if
num_interface = num_interface + 1
@@ -913,7 +1062,175 @@
end if
- end subroutine write_interfaces_database
+ end subroutine write_interfaces_database
+ !--------------------------------------------------
+ ! loading : sets weights for acoustic/elastic elements to account for different
+ ! expensive calculations in specfem simulations
+ !--------------------------------------------------
+
+ subroutine acoustic_elastic_load (elmnts_load,nelmnts,nb_materials,num_material,mat_prop)
+
+ implicit none
+
+ integer(long),intent(in) :: nelmnts
+ integer, intent(in) :: nb_materials
+
+ ! load weights
+ integer,dimension(1:nelmnts),intent(out) :: elmnts_load
+
+ ! materials
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+ double precision, dimension(6,nb_materials),intent(in) :: mat_prop
+
+ ! local parameters
+ logical, dimension(nb_materials) :: is_acoustic, is_elastic
+ integer :: i,el
+
+ ! sets acoustic/elastic flags for materials
+ is_acoustic(:) = .false.
+ is_elastic(:) = .false.
+ do i = 1, nb_materials
+ if (mat_prop(6,i) == 1 ) then
+ is_acoustic(i) = .true.
+ endif
+ if (mat_prop(6,i) == 2 ) then
+ is_elastic(i) = .true.
+ endif
+ enddo
+
+ ! sets weights for elements
+ do el = 0, nelmnts-1
+ ! acoustic element (cheap)
+ if ( is_acoustic(num_material(el+1)) ) then
+ elmnts_load(el+1) = elmnts_load(el+1)*ACOUSTIC_LOAD
+ endif
+ ! elastic element (expensive)
+ if ( is_elastic(num_material(el+1)) ) then
+ elmnts_load(el+1) = elmnts_load(el+1)*ELASTIC_LOAD
+ endif
+ enddo
+
+ end subroutine acoustic_elastic_load
+
+
+ !--------------------------------------------------
+ ! Repartitioning : two coupled acoustic/elastic elements are transfered to the same partition
+ !--------------------------------------------------
+
+ subroutine acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, &
+ nb_materials, num_material, mat_prop, &
+ sup_neighbour, nsize, &
+ nproc, part, nfaces_coupled, faces_coupled)
+
+ implicit none
+
+ integer(long),intent(in) :: nelmnts
+ integer, intent(in) :: nnodes, nproc, nb_materials
+ integer(long), intent(in) :: sup_neighbour,nsize
+
+ !double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+
+ double precision, dimension(6,nb_materials),intent(in) :: mat_prop
+
+ !integer, dimension(:), pointer :: elmnts
+ !integer, dimension(:), pointer :: part
+ integer, dimension(0:nelmnts-1) :: part
+ integer, dimension(0:esize*nelmnts-1) :: elmnts
+
+ integer, intent(out) :: nfaces_coupled
+ integer, dimension(:,:), pointer :: faces_coupled
+
+
+ logical, dimension(nb_materials) :: is_acoustic, is_elastic
+
+ ! neighbors
+ !integer, dimension(:), pointer :: xadj
+ !integer, dimension(:), pointer :: adjncy
+ !integer, dimension(:), pointer :: nodes_elmnts
+ !integer, dimension(:), pointer :: nnodes_elmnts
+ integer, dimension(:), allocatable :: xadj
+ integer, dimension(:), allocatable :: adjncy
+ integer, dimension(:), allocatable :: nnodes_elmnts
+ integer, dimension(:), allocatable :: nodes_elmnts
+ integer :: max_neighbour
+
+ integer :: i, iface
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ ! sets acoustic/elastic flags for materials
+ is_acoustic(:) = .false.
+ is_elastic(:) = .false.
+ do i = 1, nb_materials
+ if (mat_prop(6,i) == 1 ) then
+ is_acoustic(i) = .true.
+ endif
+ if (mat_prop(6,i) == 2 ) then
+ is_elastic(i) = .true.
+ endif
+ enddo
+
+ ! gets neighbors by 4 common nodes (face)
+ allocate(xadj(1:nelmnts+1))
+ allocate(adjncy(1:sup_neighbour*nelmnts))
+ allocate(nnodes_elmnts(1:nnodes))
+ allocate(nodes_elmnts(1:nsize*nnodes))
+ !call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,4)
+ call mesh2dual_ncommonnodes(nelmnts, nnodes, nsize, sup_neighbour, elmnts, xadj, adjncy, nnodes_elmnts, &
+ nodes_elmnts, max_neighbour, 4)
+
+ ! counts coupled elements
+ nfaces_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj(el), xadj(el+1) - 1
+ if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
+ nfaces_coupled = nfaces_coupled + 1
+ endif
+ enddo
+ endif
+ enddo
+
+ ! coupled elements
+ allocate(faces_coupled(2,nfaces_coupled))
+
+ ! stores elements indices
+ nfaces_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj(el), xadj(el+1) - 1
+ if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
+ nfaces_coupled = nfaces_coupled + 1
+ faces_coupled(1,nfaces_coupled) = el
+ faces_coupled(2,nfaces_coupled) = adjncy(el_adj)
+ endif
+ enddo
+ endif
+ enddo
+
+ ! puts coupled elements into same partition
+ do i = 1, nfaces_coupled*nproc
+ is_repartitioned = .false.
+ do iface = 1, nfaces_coupled
+ if ( part(faces_coupled(1,iface)) /= part(faces_coupled(2,iface)) ) then
+ if ( part(faces_coupled(1,iface)) < part(faces_coupled(2,iface)) ) then
+ part(faces_coupled(2,iface)) = part(faces_coupled(1,iface))
+ else
+ part(faces_coupled(1,iface)) = part(faces_coupled(2,iface))
+ endif
+ is_repartitioned = .true.
+ endif
+ enddo
+ if ( .not. is_repartitioned ) then
+ exit
+ endif
+ enddo
+
+ end subroutine acoustic_elastic_repartitioning
+
+
+
end module part_decompose_mesh_SCOTCH
Added: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/scotch_user5.1.pdf
===================================================================
(Binary files differ)
Property changes on: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/scotch_user5.1.pdf
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -28,8 +28,9 @@
subroutine detect_mesh_surfaces()
use specfem_par
+ use specfem_par_movie
implicit none
-
+
! detecting surface points/elements (based on valence check on NGLL points) for external mesh
@@ -52,12 +53,92 @@
my_neighbours_ext_mesh, &
ibool_interfaces_ext_mesh)
endif
+
+! takes cross-section surfaces instead
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
+ if( PLOT_CROSS_SECTIONS ) then
+ call detect_surface_cross_section(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,&
+ CROSS_SECTION_X,CROSS_SECTION_Y,CROSS_SECTION_Z, &
+ xstore,ystore,zstore,myrank)
+ endif
+ endif
+ ! takes number of faces for top, free surface only
+ if( MOVIE_SURFACE .or. CREATE_SHAKEMAP ) then
+ nfaces_surface_external_mesh = num_free_surface_faces
+ ! face corner indices
+ iorderi(1) = 1
+ iorderi(2) = NGLLX
+ iorderi(3) = NGLLX
+ iorderi(4) = 1
+ iorderj(1) = 1
+ iorderj(2) = 1
+ iorderj(3) = NGLLY
+ iorderj(4) = NGLLY
+ endif
+
! handles movies and shakemaps
- if (EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) then
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. &
+ EXTERNAL_MESH_CREATE_SHAKEMAP .or. &
+ MOVIE_SURFACE .or. &
+ CREATE_SHAKEMAP ) then
call setup_movie_meshes()
endif
+ if (MOVIE_VOLUME) then
+ allocate(div(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(curl_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(curl_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(curl_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ div(:,:,:,:) = 0._CUSTOM_REAL
+ curl_x(:,:,:,:) = 0._CUSTOM_REAL
+ curl_y(:,:,:,:) = 0._CUSTOM_REAL
+ curl_z(:,:,:,:) = 0._CUSTOM_REAL
+ endif
+
+
+! obsolete...
+! allocate files to save movies and shaking map
+! if(MOVIE_SURFACE .or. CREATE_SHAKEMAP) then
+! if (USE_HIGHRES_FOR_MOVIES) then
+! !nmovie_points = NGLLX * NGLLY * NSPEC2D_TOP
+! nmovie_points = NGLLX * NGLLY * num_free_surface_faces
+! else
+! !nmovie_points = NGNOD2D * NSPEC2D_TOP
+! nmovie_points = NGNOD2D * num_free_surface_faces
+! endif
+! allocate(store_val_x(nmovie_points))
+! allocate(store_val_y(nmovie_points))
+! allocate(store_val_z(nmovie_points))
+! allocate(store_val_ux(nmovie_points))
+! allocate(store_val_uy(nmovie_points))
+! allocate(store_val_uz(nmovie_points))
+! allocate(store_val_norm_displ(nmovie_points))
+! allocate(store_val_norm_veloc(nmovie_points))
+! allocate(store_val_norm_accel(nmovie_points))
+!
+! allocate(store_val_x_all(nmovie_points,0:NPROC-1))
+! allocate(store_val_y_all(nmovie_points,0:NPROC-1))
+! allocate(store_val_z_all(nmovie_points,0:NPROC-1))
+! allocate(store_val_ux_all(nmovie_points,0:NPROC-1))
+! allocate(store_val_uy_all(nmovie_points,0:NPROC-1))
+! allocate(store_val_uz_all(nmovie_points,0:NPROC-1))
+!
+! ! to compute max of norm for shaking map
+! store_val_norm_displ(:) = -1.
+! store_val_norm_veloc(:) = -1.
+! store_val_norm_accel(:) = -1.
+! 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))
!!$ ispec_is_regolith(:) = .false.
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -60,12 +60,7 @@
!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)
@@ -91,23 +86,13 @@
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)
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_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)
-
+! determines spectral elements containing surface points
do ispec = 1, nspec
! loops over GLL points not on edges or corners
@@ -154,7 +139,7 @@
enddo ! nspec
-! counts faces for movies and shakemaps
+! counts faces for external-mesh movies and shakemaps
nfaces_surface_external_mesh = 0
do ispec = 1, nspec
iglob = ibool(2,2,1,ispec)
@@ -184,4 +169,226 @@
enddo
end subroutine detect_surface
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine detect_surface_cross_section(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,&
+ x_section,y_section,z_section, &
+ xstore,ystore,zstore,myrank)
+
+! instead of surface of model, this returns cross-section surfaces through model
+! at specified x,y,z - coordinates
+!
+! note: x,y,z coordinates must coincide with the element (outer-)faces, no planes inside element are taken
+! (this is only a quick & dirty cross-section implementation, no sophisticated interpolation of points considered...)
+!
+! 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,myrank
+ 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
+
+! specified x,y,z - coordinates
+ real(kind=CUSTOM_REAL):: x_section,y_section,z_section
+
+! mesh global point coordinates
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+!local parameters
+ real(kind=CUSTOM_REAL) :: mindist
+ integer, dimension(:), allocatable :: valence_external_mesh
+ integer :: ispec,i,j,k,ii,jj,kk,iglob,ier,count
+ logical :: has_face
+
+! 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
+
+! an estimation of the minimum distance between global points
+ mindist = minval( (xstore(ibool(1,1,1,:)) - xstore(ibool(2,1,1,:)))**2 &
+ + (ystore(ibool(1,1,1,:)) - ystore(ibool(2,1,1,:)))**2 &
+ + (zstore(ibool(1,1,1,:)) - zstore(ibool(2,1,1,:)))**2 )
+ mindist = sqrt(mindist)
+
+! sets valence to corresponding to process rank for points on cross-sections
+ count = 0
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! x cross-section
+ if( abs( xstore(iglob) - x_section ) < 0.5*mindist ) then
+ ! sets valence to 1 for points on cross-sections
+ valence_external_mesh(iglob) = myrank+1
+ count = count + 1
+ endif
+
+ ! y cross-section
+ if( abs( ystore(iglob) - y_section ) < 0.5*mindist ) then
+ ! sets valence to 1 for points on cross-sections
+ valence_external_mesh(iglob) = myrank+1
+ count = count + 1
+ endif
+
+ ! z cross-section
+ if( abs( zstore(iglob) - z_section ) < 0.5*mindist ) then
+ ! sets valence to 1 for points on cross-sections
+ valence_external_mesh(iglob) = myrank+1
+ count = count + 1
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+! adds contributions from different partitions to valence_external_mesh
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,valence_external_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+
+! determines spectral elements containing surface points
+! (only counts element outer faces, no planes inside element)
+ count = 0
+ do ispec = 1, nspec
+
+ ! loops over GLL points not on edges or corners, but inside faces
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ if ( ((k == 1 .or. k == NGLLZ) .and. (j == 2 .and. i == 2)) .or. &
+ ((j == 1 .or. j == NGLLY) .and. (k == 2 .and. i == 2)) .or. &
+ ((i == 1 .or. i == NGLLX) .and. (k == 2 .and. j == 2)) ) then
+
+ iglob = ibool(i,j,k,ispec)
+
+ ! considers only points in same process or, if point is shared between two processes,
+ ! only with higher process ranks than itself
+ if (valence_external_mesh(iglob) == myrank+1 .or. valence_external_mesh(iglob) > 2*(myrank+1) ) then
+
+ has_face = .false.
+
+
+ ! sets flags for all gll points on a face and makes sure it's not inside the element
+ ! zmin & zmax face
+ if ((k == 1 .or. k == NGLLZ) .and. valence_external_mesh(ibool(3,3,k,ispec)) >= 1 ) then
+ has_face = .true.
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ iglob_is_surface_external_mesh(ibool(ii,jj,k,ispec)) = .true.
+ ! resets valence to count face only once
+ valence_external_mesh(ibool(ii,jj,k,ispec)) = 0
+ enddo
+ enddo
+ endif
+
+ ! ymin & ymax
+ if ((j == 1 .or. j == NGLLY) .and. valence_external_mesh(ibool(3,j,3,ispec)) >= 1) then
+ has_face = .true.
+ do kk = 1, NGLLZ
+ do ii = 1, NGLLX
+ iglob_is_surface_external_mesh(ibool(ii,j,kk,ispec)) = .true.
+ ! resets valence to count face only once
+ valence_external_mesh(ibool(ii,j,kk,ispec)) = 0
+ enddo
+ enddo
+ endif
+
+ ! xmin & xmax
+ if ((i == 1 .or. i == NGLLX) .and. valence_external_mesh(ibool(i,3,3,ispec)) >= 1) then
+ has_face = .true.
+ do kk = 1, NGLLZ
+ do jj = 1, NGLLY
+ iglob_is_surface_external_mesh(ibool(i,jj,kk,ispec)) = .true.
+ ! resets valence to count face only once
+ valence_external_mesh(ibool(i,jj,kk,ispec)) = 0
+ enddo
+ enddo
+ endif
+
+
+ ! sets flag for element
+ if( has_face ) then
+ ispec_is_surface_external_mesh(ispec) = .true.
+ count = count+1
+ endif
+
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ enddo ! nspec
+
+! counts faces for external-mesh movies and shakemaps
+ nfaces_surface_external_mesh = 0
+ do ispec = 1, nspec
+ if( ispec_is_surface_external_mesh(ispec) ) then
+ ! zmin face
+ if (iglob_is_surface_external_mesh(ibool(2,2,1,ispec))) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ ! zmax
+ if (iglob_is_surface_external_mesh(ibool(2,2,NGLLZ,ispec))) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ ! ymin
+ if (iglob_is_surface_external_mesh(ibool(2,1,2,ispec))) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ ! ymax
+ if (iglob_is_surface_external_mesh(ibool(2,NGLLY,2,ispec))) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ !xmin
+ if (iglob_is_surface_external_mesh(ibool(1,2,2,ispec))) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ !xmax
+ if (iglob_is_surface_external_mesh(ibool(NGLLX,2,2,ispec))) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ endif
+ enddo
+
+ end subroutine detect_surface_cross_section
+
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/exit_mpi.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/exit_mpi.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/exit_mpi.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -38,7 +38,7 @@
character(len=*) error_msg
character(len=80) outputname
- character(len=150) OUTPUT_FILES
+ character(len=256) OUTPUT_FILES
! write error message to screen
write(*,*) error_msg(1:len(error_msg))
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -32,6 +32,8 @@
implicit none
+ integer :: irec_local
+
! 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-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -201,36 +201,39 @@
double precision, dimension(:,:,:,:), allocatable :: xstore,ystore,zstore
! proc numbers for MPI
- integer myrank,sizeprocs,ier
+ integer :: myrank,sizeprocs,ier
! use integer array to store topography values
- integer NX_TOPO,NY_TOPO
- double precision ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
- character(len=100) topo_file
+ integer :: UTM_PROJECTION_ZONE
+ logical :: SUPPRESS_UTM_PROJECTION
+ integer :: NX_TOPO,NY_TOPO
+ double precision :: ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
+ character(len=100) :: topo_file
integer, dimension(:,:), allocatable :: itopo_bathy
-
+
! use integer array to store Moho depth
! integer imoho_depth(NX_MOHO,NY_MOHO)
! timer MPI
double precision, external :: wtime
- double precision time_start,tCPU
+ double precision :: time_start,tCPU
! parameters read from parameter file
- integer NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,SIMULATION_TYPE,UTM_PROJECTION_ZONE
- integer NSOURCES
+ integer :: NPROC_XI,NPROC_ETA
+ integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,SIMULATION_TYPE
+ integer :: NSOURCES
- double precision DT,HDUR_MOVIE
+ double precision :: DT,HDUR_MOVIE
- logical TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
+ logical :: TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
OCEANS, SAVE_FORWARD
- logical ANISOTROPY,ABSORBING_CONDITIONS,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+ logical :: ANISOTROPY,ABSORBING_CONDITIONS,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
- logical MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
- integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+ logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ USE_HIGHRES_FOR_MOVIES
+ integer :: NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
- character(len=150) OUTPUT_FILES,LOCAL_PATH
+ character(len=256) OUTPUT_FILES,LOCAL_PATH
! parameters deduced from parameters read from file
integer NPROC
@@ -252,17 +255,17 @@
! for tapered basement map
! integer iz_basement
! double precision z_basement(NX_BASEMENT,NY_BASEMENT)
-! character(len=150) BASEMENT_MAP_FILE
+! character(len=256) BASEMENT_MAP_FILE
! to filter list of stations
! integer nrec,nrec_filtered
! double precision stlat,stlon,stele,stbur
! character(len=MAX_LENGTH_STATION_NAME) station_name
! character(len=MAX_LENGTH_NETWORK_NAME) network_name
-! character(len=150) rec_filename!,filtered_rec_filename
+! character(len=256) rec_filename!,filtered_rec_filename
! for Databases of external meshes
- character(len=150) prname
+ character(len=256) prname
integer :: dummy_node
integer :: dummy_elmnt
integer :: ispec, inode, num_interface, ie,imat !pll
@@ -343,13 +346,13 @@
endif
! read the parameter file
- call generate_databases_read_parameters()
+ call gd_read_parameters()
! makes sure processes are synchronized
call sync_all()
! reads topography and bathymetry file
- call generate_databases_read_topography()
+ call gd_read_topography()
if(myrank == 0) then
write(IMAIN,*)
@@ -360,13 +363,13 @@
endif
! reads Databases files
- call generate_databases_read_partition_files()
+ call gd_read_partition_files()
! external mesh creation
- call generate_databases_setup_mesh()
+ call gd_setup_mesh()
! finalize mesher
- call generate_databases_finalize()
+ call gd_finalize()
end subroutine generate_databases
@@ -374,7 +377,7 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine generate_databases_read_parameters
+ subroutine gd_read_parameters
! reads and checks user input parameters
@@ -453,6 +456,13 @@
! for the number of standard linear solids for attenuation
if(N_SLS /= 3) call exit_MPI(myrank,'number of SLS must be 3')
+ ! exclusive movie flags
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
+ MOVIE_SURFACE = .false.
+ CREATE_SHAKEMAP = .false.
+ endif
+
+
if(myrank == 0) then
! chris: I am not sure if we should suppress the following. topography should appear in the external mesh
! leave it for now
@@ -500,19 +510,21 @@
endif
- end subroutine generate_databases_read_parameters
+ end subroutine gd_read_parameters
!
!-------------------------------------------------------------------------------------------------
!
- subroutine generate_databases_read_topography
+ subroutine gd_read_topography
! reads in topography files
use generate_databases_par
implicit none
+ allocate(itopo_bathy(NX_TOPO,NY_TOPO))
+
if(TOPOGRAPHY .or. OCEANS) then
! for Southern California
@@ -523,8 +535,6 @@
DEGREES_PER_CELL_TOPO = DEGREES_PER_CELL_TOPO_SOCAL
topo_file = TOPO_FILE_SOCAL
- allocate(itopo_bathy(NX_TOPO,NY_TOPO))
-
call read_topo_bathy_file(itopo_bathy,NX_TOPO,NY_TOPO,topo_file)
if(myrank == 0) then
@@ -532,7 +542,6 @@
write(IMAIN,*) 'regional topography file read ranges in m from ',minval(itopo_bathy),' to ',maxval(itopo_bathy)
write(IMAIN,*)
endif
-
endif
!! read basement map
@@ -548,19 +557,21 @@
! close(55)
! endif
- end subroutine generate_databases_read_topography
+ end subroutine gd_read_topography
!
!-------------------------------------------------------------------------------------------------
!
- subroutine generate_databases_read_partition_files
+ subroutine gd_read_partition_files
! reads in proc***_Databases files
use generate_databases_par
implicit none
+ integer :: num_xmin,num_xmax,num_ymin,num_ymax,num_top,num_bottom,num
+
! read databases about external mesh simulation
! global node coordinates
call create_name_database(prname,myrank,LOCAL_PATH)
@@ -577,20 +588,24 @@
nodes_coords_ext_mesh(3,inode)
enddo
-
+ call sum_all_i(nnodes_ext_mesh,num)
if(myrank == 0) then
- write(IMAIN,*) ' external mesh points: ',nnodes_ext_mesh
+ write(IMAIN,*) ' external mesh points: ',num
endif
call sync_all()
! read materials' physical properties
read(IIN,*) nmat_ext_mesh, nundefMat_ext_mesh
- allocate(materials_ext_mesh(5,nmat_ext_mesh))
- allocate(undef_mat_prop(5,nundefMat_ext_mesh))
+ allocate(materials_ext_mesh(6,nmat_ext_mesh))
+ allocate(undef_mat_prop(6,nundefMat_ext_mesh))
do imat = 1, nmat_ext_mesh
- ! format: #(1) rho #(2) vp #(3) vs #(4) Q_flag #(5) anisotropy_flag
+ ! format: #(1) rho #(2) vp #(3) vs #(4) Q_flag #(5) anisotropy_flag #(6) material_domain_id
read(IIN,*) materials_ext_mesh(1,imat), materials_ext_mesh(2,imat), materials_ext_mesh(3,imat), &
- materials_ext_mesh(4,imat), materials_ext_mesh(5,imat)
+ materials_ext_mesh(4,imat), materials_ext_mesh(5,imat), materials_ext_mesh(6,imat)
+
+ ! output
+ !print*,'materials:',materials_ext_mesh(1,imat), materials_ext_mesh(2,imat), materials_ext_mesh(3,imat), &
+ ! materials_ext_mesh(4,imat), materials_ext_mesh(5,imat), materials_ext_mesh(6,imat)
end do
if(myrank == 0) then
@@ -600,7 +615,7 @@
do imat = 1, nundefMat_ext_mesh
read(IIN,*) undef_mat_prop(1,imat),undef_mat_prop(2,imat),undef_mat_prop(3,imat),undef_mat_prop(4,imat), &
- undef_mat_prop(5,imat)
+ undef_mat_prop(5,imat), undef_mat_prop(6,imat)
end do
if(myrank == 0) then
@@ -619,8 +634,9 @@
enddo
NSPEC_AB = nelmnts_ext_mesh
+ call sum_all_i(nspec_ab,num)
if(myrank == 0) then
- write(IMAIN,*) ' spectral elements: ',NSPEC_AB
+ write(IMAIN,*) ' spectral elements: ',num
endif
call sync_all()
@@ -675,44 +691,69 @@
read(IIN,*) ibelm_top(ispec2D),(nodes_ibelm_top(j,ispec2D),j=1,4)
end do
+ call sum_all_i(nspec2D_xmin,num_xmin)
+ call sum_all_i(nspec2D_xmax,num_xmax)
+ call sum_all_i(nspec2D_ymin,num_ymin)
+ call sum_all_i(nspec2D_ymax,num_ymax)
+ call sum_all_i(nspec2D_top_ext,num_top)
+ call sum_all_i(nspec2D_bottom_ext,num_bottom)
+
if(myrank == 0) then
write(IMAIN,*) ' absorbing boundaries: '
- write(IMAIN,*) ' xmin,xmax: ',nspec2D_xmin,nspec2D_xmax
- write(IMAIN,*) ' ymin,ymax: ',nspec2D_ymin,nspec2D_ymax
- write(IMAIN,*) ' bottom,top: ',nspec2D_bottom_ext,nspec2D_top_ext
+ write(IMAIN,*) ' xmin,xmax: ',num_xmin,num_xmax
+ write(IMAIN,*) ' ymin,ymax: ',num_ymin,num_ymax
+ write(IMAIN,*) ' bottom,top: ',num_bottom,num_top
!write(IMAIN,*) ' xmin_xmax,ymin_ymax: ',NSPEC2DMAX_XMIN_XMAX, NSPEC2DMAX_YMIN_YMAX
endif
call sync_all()
! MPI interfaces between different partitions
+ ! format: #number_of_MPI_interfaces #maximum_number_of_elements_on_each_interface
read(IIN,*) num_interfaces_ext_mesh, max_interface_size_ext_mesh
+
+ ! allocates interfaces
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))
+
+ ! loops over MPI interfaces with other partitions
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), &
- my_interfaces_ext_mesh(3,ie,num_interface), my_interfaces_ext_mesh(4,ie,num_interface), &
- my_interfaces_ext_mesh(5,ie,num_interface), my_interfaces_ext_mesh(6,ie,num_interface)
- enddo
+ ! format: #process_interface_id #number_of_elements_on_interface
+ ! where
+ ! process_interface_id = rank of (neighbor) process to share MPI interface with
+ ! number_of_elements_on_interface = number of interface elements
+ read(IIN,*) my_neighbours_ext_mesh(num_interface), my_nelmnts_neighbours_ext_mesh(num_interface)
+
+ ! loops over interface elements
+ do ie = 1, my_nelmnts_neighbours_ext_mesh(num_interface)
+ ! format: #(1)spectral_element_id #(2)interface_type #(3)node_id1 #(4)node_id2 #(5)...
+ !
+ ! interface types:
+ ! 1 - corner point only
+ ! 2 - element edge
+ ! 4 - element face
+ read(IIN,*) my_interfaces_ext_mesh(1,ie,num_interface), my_interfaces_ext_mesh(2,ie,num_interface), &
+ my_interfaces_ext_mesh(3,ie,num_interface), my_interfaces_ext_mesh(4,ie,num_interface), &
+ my_interfaces_ext_mesh(5,ie,num_interface), my_interfaces_ext_mesh(6,ie,num_interface)
+ enddo
enddo
close(IIN)
+ call sum_all_i(num_interfaces_ext_mesh,num)
if(myrank == 0) then
- write(IMAIN,*) ' number of MPI partition interfaces: ',num_interfaces_ext_mesh
+ write(IMAIN,*) ' number of MPI partition interfaces: ',num
endif
call sync_all()
- end subroutine generate_databases_read_partition_files
+ end subroutine gd_read_partition_files
!
!-------------------------------------------------------------------------------------------------
!
- subroutine generate_databases_setup_mesh
+ subroutine gd_setup_mesh
! mesh creation for static solver
@@ -734,10 +775,10 @@
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,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)
+ 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)
max_static_memory_size = max_static_memory_size_request
@@ -747,25 +788,27 @@
! main working routine to create all the regions of the mesh
if(myrank == 0) then
write(IMAIN,*) 'create regions: '
- endif
-
- call create_regions_mesh_ext_mesh(ibool, &
- xstore, ystore, zstore, nspec, npointot, myrank, LOCAL_PATH, &
- nnodes_ext_mesh, nelmnts_ext_mesh, &
- 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, &
- 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, &
- 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, &
- SAVE_MESH_FILES,nglob, &
- ANISOTROPY)
+ endif
+ call create_regions_mesh_ext(ibool, &
+ xstore, ystore, zstore, nspec, npointot, myrank, LOCAL_PATH, &
+ nnodes_ext_mesh, nelmnts_ext_mesh, &
+ 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, &
+ 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, &
+ 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, &
+ SAVE_MESH_FILES,nglob, &
+ ANISOTROPY,NPROC,OCEANS, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION,NX_TOPO,NY_TOPO, &
+ ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO, &
+ itopo_bathy)
call sync_all()
@@ -791,13 +834,13 @@
! make sure everybody is synchronized
call sync_all()
- end subroutine generate_databases_setup_mesh
+ end subroutine gd_setup_mesh
!
!-------------------------------------------------------------------------------------------------
!
- subroutine generate_databases_finalize
+ subroutine gd_finalize
! checks user input parameters
@@ -843,22 +886,26 @@
do i = 1, num_interfaces_ext_mesh
ibool_interfaces_ext_mesh_dummy(:,:) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,:)
enddo
- call sync_all()
-
+ call sync_all()
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 )
+ 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)
+
+ ! takes number of faces for top, free surface only
+ if( MOVIE_SURFACE .or. CREATE_SHAKEMAP ) then
+ nfaces_surface_external_mesh = NSPEC2D_TOP
+ endif
! number of surface faces for all partitions together
call sum_all_i(nfaces_surface_external_mesh,nfaces_surface_glob_ext_mesh)
@@ -932,5 +979,5 @@
! synchronize all the processes to make sure everybody has finished
call sync_all()
- end subroutine generate_databases_finalize
+ end subroutine gd_finalize
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_MPI_cutplanes_eta.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_MPI_cutplanes_eta.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_MPI_cutplanes_eta.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -59,7 +59,7 @@
integer nspec2Dtheor1,nspec2Dtheor2
! processor identification
- character(len=150) prname
+ character(len=256) prname
! theoretical number of surface elements in the buffers
! cut planes along eta=constant correspond to XI faces
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_MPI_cutplanes_xi.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_MPI_cutplanes_xi.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_MPI_cutplanes_xi.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -59,7 +59,7 @@
integer nspec2Dtheor1,nspec2Dtheor2
! processor identification
- character(len=150) prname
+ character(len=256) prname
! theoretical number of surface elements in the buffers
! cut planes along xi=constant correspond to ETA faces
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_absorb.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_absorb.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_absorb.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -51,7 +51,7 @@
integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5
! processor identification
- character(len=150) prname
+ character(len=256) prname
ispecb1=0
ispecb2=0
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_attenuation_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_attenuation_model.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_attenuation_model.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -220,7 +220,7 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine get_attenuation_model_Olsen_sediment( vs_val, iselected )
+ subroutine get_attenuation_model_olsen( vs_val, iselected )
! uses scaling rule similar to Olsen et al. (2003) to determine attenuation medium
!
@@ -275,4 +275,4 @@
! return sediment number
iselected = iattenuation_sediments
- end subroutine get_attenuation_model_Olsen_sediment
+ end subroutine get_attenuation_model_olsen
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_cmt.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_cmt.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_cmt.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -37,7 +37,7 @@
integer mo,da,julian_day,isource
character(len=5) datasource
- character(len=150) string, CMTSOLUTION
+ character(len=256) string, CMTSOLUTION
!
!---- read hypocenter info
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_jacobian_boundaries.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_jacobian_boundaries.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_jacobian_boundaries.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -25,12 +25,12 @@
subroutine get_jacobian_boundary_face(myrank,nspec, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
- ispec,iface,jacobian2D_face,normal_face,NGLLA,NGLLB)
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
+ ispec,iface,jacobian2Dw_face,normal_face,NGLLA,NGLLB)
-! returns jacobian2D_face and normal_face (pointing outwards of element)
+! returns jacobian2Dw_face and normal_face (pointing outwards of element)
implicit none
@@ -41,14 +41,10 @@
! arrays with the mesh
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
real(kind=CUSTOM_REAL) :: xstore_dummy(nglob),ystore_dummy(nglob),zstore_dummy(nglob)
-
-! double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
-! double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
-! double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! absorbing boundaries
+
+! face information
integer :: iface,ispec,NGLLA,NGLLB
- real(kind=CUSTOM_REAL) jacobian2D_face(NGLLA,NGLLB)
+ real(kind=CUSTOM_REAL) jacobian2Dw_face(NGLLA,NGLLB)
real(kind=CUSTOM_REAL) normal_face(NDIM,NGLLA,NGLLB)
double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ)
@@ -60,11 +56,10 @@
double precision, dimension(NGLLX,NGLLZ) :: wgllwgll_xz
double precision, dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+! local parameters
+! face corners
double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
-! element numbering
-! integer i,j
-
! check that the parameter file is correct
if(NGNOD /= 8) call exit_MPI(myrank,'elements should have 8 control nodes')
if(NGNOD2D /= 4) call exit_MPI(myrank,'surface elements should have 4 control nodes')
@@ -87,7 +82,7 @@
call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
dershape2D_x,wgllwgll_yz, &
- jacobian2D_face,normal_face,NGLLY,NGLLZ)
+ jacobian2Dw_face,normal_face,NGLLY,NGLLZ)
! on boundary: xmax
case(2)
@@ -106,7 +101,7 @@
call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
dershape2D_x,wgllwgll_yz, &
- jacobian2D_face,normal_face,NGLLY,NGLLZ)
+ jacobian2Dw_face,normal_face,NGLLY,NGLLZ)
! on boundary: ymin
case(3)
@@ -125,7 +120,7 @@
call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
dershape2D_y,wgllwgll_xz, &
- jacobian2D_face,normal_face,NGLLX,NGLLZ)
+ jacobian2Dw_face,normal_face,NGLLX,NGLLZ)
! on boundary: ymax
case(4)
@@ -144,7 +139,7 @@
call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
dershape2D_y, wgllwgll_xz, &
- jacobian2D_face,normal_face,NGLLX,NGLLZ)
+ jacobian2Dw_face,normal_face,NGLLX,NGLLZ)
! on boundary: bottom
@@ -164,7 +159,7 @@
call compute_jacobian_2D_face(myrank,xelm,yelm,zelm,&
dershape2D_bottom,wgllwgll_xy, &
- jacobian2D_face,normal_face,NGLLX,NGLLY)
+ jacobian2Dw_face,normal_face,NGLLX,NGLLY)
! on boundary: top
case(6)
@@ -183,7 +178,7 @@
call compute_jacobian_2D_face(myrank,xelm,yelm,zelm,&
dershape2D_top, wgllwgll_xy, &
- jacobian2D_face,normal_face,NGLLX,NGLLY)
+ jacobian2Dw_face,normal_face,NGLLX,NGLLY)
case default
stop 'error 2D jacobian'
@@ -196,7 +191,7 @@
subroutine compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
dershape2D,wgllwgll, &
- jacobian2D_face,normal_face,NGLLA,NGLLB)
+ jacobian2Dw_face,normal_face,NGLLA,NGLLB)
implicit none
@@ -211,7 +206,7 @@
double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
double precision wgllwgll(NGLLA,NGLLB)
- real(kind=CUSTOM_REAL) jacobian2D_face(NGLLA,NGLLB)
+ real(kind=CUSTOM_REAL) jacobian2Dw_face(NGLLA,NGLLB)
real(kind=CUSTOM_REAL) normal_face(NDIM,NGLLA,NGLLB)
integer i,j,ia
@@ -247,12 +242,12 @@
! distinguish if single or double precision for reals
if(CUSTOM_REAL == SIZE_REAL) then
- jacobian2D_face(i,j) = sngl(jacobian * wgllwgll(i,j) )
+ jacobian2Dw_face(i,j) = sngl(jacobian * wgllwgll(i,j) )
normal_face(1,i,j)=sngl(unx/jacobian)
normal_face(2,i,j)=sngl(uny/jacobian)
normal_face(3,i,j)=sngl(unz/jacobian)
else
- jacobian2D_face(i,j) = jacobian * wgllwgll(i,j)
+ jacobian2Dw_face(i,j) = jacobian * wgllwgll(i,j)
normal_face(1,i,j)=unx/jacobian
normal_face(2,i,j)=uny/jacobian
normal_face(3,i,j)=unz/jacobian
@@ -281,7 +276,7 @@
subroutine recalc_jacobian_gll2D(myrank,xstore,ystore,zstore, &
xigll,yigll,wgllwgll,NGLLA,NGLLB, &
- ispec,nspec,jacobian2D_face,normal_face)
+ ispec,nspec,jacobian2Dw_face,normal_face)
implicit none
@@ -296,7 +291,7 @@
double precision, dimension(NGLLB):: yigll
double precision:: wgllwgll(NGLLA,NGLLB)
- real(kind=CUSTOM_REAL) jacobian2D_face(NGLLA,NGLLB)
+ real(kind=CUSTOM_REAL) jacobian2Dw_face(NGLLA,NGLLB)
real(kind=CUSTOM_REAL) normal_face(NDIM,NGLLA,NGLLB)
! other parameters for this subroutine
@@ -395,12 +390,12 @@
! distinguish if single or double precision for reals
if(CUSTOM_REAL == SIZE_REAL) then
- jacobian2D_face(i,j) = sngl(jacobian * wgllwgll(i,j) )
+ jacobian2Dw_face(i,j) = sngl(jacobian * wgllwgll(i,j) )
normal_face(1,i,j)=sngl(unx/jacobian)
normal_face(2,i,j)=sngl(uny/jacobian)
normal_face(3,i,j)=sngl(unz/jacobian)
else
- jacobian2D_face(i,j) = jacobian * wgllwgll(i,j)
+ jacobian2Dw_face(i,j) = jacobian * wgllwgll(i,j)
normal_face(1,i,j)=unx/jacobian
normal_face(2,i,j)=uny/jacobian
normal_face(3,i,j)=unz/jacobian
@@ -549,17 +544,6 @@
!! zelm(i) = zcoord_iboun(i,1,ispec)
!! enddo
!
-! !daniel
-! ! checks points for layered_halfspace model:
-! ! xmin = zero, xmax = 134000.0, etc...
-! !if( myrank == 0 ) then
-! ! ! print*,'xmin: ',xelm(4),yelm(4),zelm(4)
-! ! if( abs(xelm(1) - 0.0) > 0.1) print*,'error xmin:',ispec,ispecb1,xelm(1),yelm(1),zelm(1)
-! ! if( abs(xelm(2) - 0.0) > 0.1) print*,'error xmin:',ispec,ispecb1,xelm(2),yelm(2),zelm(2)
-! ! if( abs(xelm(3) - 0.0) > 0.1) print*,'error xmin:',ispec,ispecb1,xelm(3),yelm(3),zelm(3)
-! ! if( abs(xelm(4) - 0.0) > 0.1) print*,'error xmin:',ispec,ispecb1,xelm(4),yelm(4),zelm(4)
-! !endif
-!
! call compute_jacobian_2D(myrank,ispecb1,xelm,yelm,zelm, &
! dershape2D_x,wgllwgll_yz, &
! jacobian2D_xmin,normal_xmin,NGLLY,NGLLZ,NSPEC2D_xmin)
@@ -575,26 +559,6 @@
! enddo
! enddo
!
-! !daniel
-! ! checks: layered halfspace
-! ! checks normal:
-! ! for boundary on xmin, outward direction must be (-1,0,0)
-! !if( myrank == 0 ) then
-! !i=1; j=1
-! !do i=1,NGLLY
-! ! do j=1,NGLLZ
-! ! if( abs(normal_xmin(1,i,j,ispecb1) + 1.0 ) > 0.1 ) then
-! ! print*,'error normal xmin',myrank,ispecb1
-! ! print*,sngl(normal_xmin(:,i,j,ispecb1))
-! ! !stop
-! ! endif
-! ! enddo
-! !enddo
-! ! print*,'normal xmin 1:',sngl(normal_xmin(:,1,1,ispecb1)),'jac',sngl(jacobian2D_xmin(1,1,ispecb1))
-! ! print*,'normal xmin 2:',sngl(normal_xmin(:,2,2,ispecb1)),'jac',sngl(jacobian2D_xmin(2,2,ispecb1))
-! ! print*,'normal xmin 3:',sngl(normal_xmin(:,3,3,ispecb1)),'jac',sngl(jacobian2D_xmin(3,3,ispecb1))
-! !endif
-!
! endif
!
!! on boundary: xmax
@@ -639,13 +603,6 @@
!! zelm(i) = zcoord_iboun(i,2,ispec)
!! enddo
!
-! !daniel
-! ! checks: for halfspace model
-! !if( myrank == 0 ) then
-! ! ! print*,'xmax: ',xelm(4),yelm(4),zelm(4)
-! ! if( abs(xelm(4) - 134000.0) > 0.1) print*,'error xmax:',myrank,ispec,ispecb2,xelm(4)
-! !endif
-!
! call compute_jacobian_2D(myrank,ispecb2,xelm,yelm,zelm, &
! dershape2D_x,wgllwgll_yz, &
! jacobian2D_xmax,normal_xmax,NGLLY,NGLLZ,NSPEC2D_xmax)
@@ -661,26 +618,6 @@
! enddo
! enddo
!
-! !daniel
-! ! checks: layered halfspace
-! ! checks normal:
-! ! for boundary on xmax, outward direction must be (1,0,0)
-! !if( myrank == 0 ) then
-! ! do i=1,NGLLY
-! ! do j=1,NGLLZ
-! i=1; j=1
-! if( abs(normal_xmax(1,i,j,ispecb2) - 1.0 ) > 0.1 ) then
-! print*,'error normal xmax',myrank,ispecb2
-! print*,sngl(normal_xmax(:,i,j,ispecb2))
-! !stop
-! endif
-! ! enddo
-! ! enddo
-! ! print*,'normal xmax 1:',sngl(normal_xmax(:,1,1,ispecb2)),'jac',sngl(jacobian2D_xmax(1,1,ispecb2))
-! ! print*,'normal xmax 2:',sngl(normal_xmax(:,2,2,ispecb2)),'jac',sngl(jacobian2D_xmax(2,2,ispecb2))
-! ! print*,'normal xmax 3:',sngl(normal_xmax(:,3,3,ispecb2)),'jac',sngl(jacobian2D_xmax(3,3,ispecb2))
-! !endif
-!
! endif
!
!! on boundary: ymin
@@ -725,13 +662,6 @@
!! zelm(i) = zcoord_iboun(i,3,ispec)
!! enddo
!
-! !daniel
-! ! checks: for layered halfspace
-! !if( myrank == 0 ) then
-! ! ! print*,'ymin: ',xelm(4),yelm(4),zelm(4)
-! ! if( abs(yelm(4) - 0.0) > 0.1) print*,'error ymin:',myrank,ispec,ispecb3,yelm(4)
-! !endif
-!
! call compute_jacobian_2D(myrank,ispecb3,xelm,yelm,zelm, &
! dershape2D_y,wgllwgll_xz, &
! jacobian2D_ymin,normal_ymin,NGLLX,NGLLZ,NSPEC2D_ymin)
@@ -747,25 +677,6 @@
! enddo
! enddo
!
-! !daniel
-! ! checks: layered halfspace
-! ! checks normal:
-! ! for boundary on ymin, outward direction must be (0,-1,0)
-! !if( myrank == 0 ) then
-! ! do i=1,NGLLX
-! ! do j=1,NGLLZ
-! !i=1; j=1
-! ! if( abs(normal_ymin(2,i,j,ispecb3) + 1.0 ) > 0.1 ) then
-! ! print*,'error normal ymin',myrank,ispecb3
-! ! print*,sngl(normal_ymin(:,i,j,ispecb3))
-! ! !stop
-! ! endif
-! ! enddo
-! ! enddo
-! ! print*,'normal ymin 1:',sngl(normal_ymin(:,1,1,ispecb3)),'jac',sngl(jacobian2D_ymin(1,1,ispecb3))
-! ! print*,'normal ymin 2:',sngl(normal_ymin(:,2,2,ispecb3)),'jac',sngl(jacobian2D_ymin(2,2,ispecb3))
-! ! print*,'normal ymin 3:',sngl(normal_ymin(:,3,3,ispecb3)),'jac',sngl(jacobian2D_ymin(3,3,ispecb3))
-! !endif
!
! endif
!
@@ -810,14 +721,7 @@
!! yelm(i) = ycoord_iboun(i,4,ispec)
!! zelm(i) = zcoord_iboun(i,4,ispec)
!! enddo
-!
-! !daniel
-! ! checks: for layered halfspace
-! !if( myrank == 0 ) then
-! ! !print*,'ymax: ',xelm(4),yelm(4),zelm(4)
-! ! if( abs(yelm(4) -134000.0) > 0.1 ) print*,'error ymax:',myrank,ispec,ispecb4,yelm(4)
-! !endif
-!
+!!
! call compute_jacobian_2D(myrank,ispecb4,xelm,yelm,zelm, &
! dershape2D_y, wgllwgll_xz, &
! jacobian2D_ymax,normal_ymax,NGLLX,NGLLZ,NSPEC2D_ymax)
@@ -833,26 +737,6 @@
! enddo
! enddo
!
-! !daniel
-! ! checks: layered halfspace
-! ! checks normal:
-! ! for boundary on ymax, outward direction must be (0,1,0)
-! !if( myrank == 0 ) then
-! ! do i=1,NGLLX
-! ! do j=1,NGLLZ
-! i=1; j=1
-! if( abs(normal_ymax(2,i,j,ispecb4) - 1.0 ) > 0.1 ) then
-! print*,'error normal ymax',myrank,ispecb4
-! print*,sngl(normal_ymax(:,i,j,ispecb4))
-! !stop
-! endif
-! ! enddo
-! ! enddo
-! ! print*,'normal ymax 1:',sngl(normal_ymax(:,1,1,ispecb4)),'jac',sngl(jacobian2D_ymax(1,1,ispecb4))
-! ! print*,'normal ymax 2:',sngl(normal_ymax(:,2,2,ispecb4)),'jac',sngl(jacobian2D_ymax(2,2,ispecb4))
-! ! print*,'normal ymax 3:',sngl(normal_ymax(:,3,3,ispecb4)),'jac',sngl(jacobian2D_ymax(3,3,ispecb4))
-! !endif
-!
! endif
!
!! on boundary: bottom
@@ -898,13 +782,6 @@
!! zelm(i) = zcoord_iboun(i,5,ispec)
!! enddo
!
-! !daniel
-! ! checks: layered halfspace
-! !if( myrank == 0 ) then
-! ! !print*,'bottom: ',xelm(4),yelm(4),zelm(4)
-! ! if( abs(zelm(4) + 60000.0) > 0.1) print*,'error bottom:',myrank,ispec,ispecb5,zelm(4)
-! !endif
-!
! call compute_jacobian_2D(myrank,ispecb5,xelm,yelm,zelm,&
! dershape2D_bottom,wgllwgll_xy, &
! jacobian2D_bottom,normal_bottom,NGLLX,NGLLY,NSPEC2D_BOTTOM)
@@ -920,26 +797,6 @@
! enddo
! enddo
!
-! !daniel
-! ! checks: layered halfspace
-! ! checks normal:
-! ! for boundary on bottom, outward direction must be (0,0,-1)
-! !if( myrank == 0 ) then
-! ! do i=1,NGLLX
-! ! do j=1,NGLLY
-! i=1; j=1
-! if( abs(normal_bottom(3,i,j,ispecb5) + 1.0 ) > 0.1 ) then
-! print*,'error normal bottom',myrank,ispecb5
-! print*,sngl(normal_bottom(:,i,j,ispecb5))
-! !stop
-! endif
-! ! enddo
-! ! enddo
-! ! print*,'normal bottom 1:',sngl(normal_bottom(:,1,1,ispecb5)),'jac',sngl(jacobian2D_bottom(1,1,ispecb5))
-! ! print*,'normal bottom 2:',sngl(normal_bottom(:,2,2,ispecb5)),'jac',sngl(jacobian2D_bottom(2,2,ispecb5))
-! ! print*,'normal bottom 3:',sngl(normal_bottom(:,3,3,ispecb5)),'jac',sngl(jacobian2D_bottom(3,3,ispecb5))
-! !endif
-!
! endif
!
!! on boundary: top
@@ -972,13 +829,6 @@
!! zelm(i) = zcoord_iboun(i,6,ispec)
!! enddo
!
-! !daniel
-! ! checks: layered halfspace
-! !if( myrank == 0 ) then
-! ! !print*,'top: ',xelm(4),yelm(4),zelm(4)
-! !if( abs(zelm(4) - 0.0) > 0.1 ) print*,'error top:',myrank,ispec,ispecb6,zelm(4)
-! !endif
-!
! call compute_jacobian_2D(myrank,ispecb6,xelm,yelm,zelm,&
! dershape2D_top, wgllwgll_xy, &
! jacobian2D_top,normal_top,NGLLX,NGLLY,NSPEC2D_TOP)
@@ -994,23 +844,6 @@
! enddo
! enddo
!
-! !daniel
-! ! checks: layered halfspace
-! ! checks normal:
-! ! for boundary on top, outward direction must be (0,0,1)
-! !if( myrank == 0 ) then
-! ! do i=1,NGLLX
-! ! do j=1,NGLLY
-! i=1; j=1
-! if( abs(normal_top(3,i,j,ispecb6) - 1.0 ) > 0.1 ) then
-! print*,'error normal top',myrank,ispecb6
-! print*,sngl(normal_top(:,i,j,ispecb6))
-! stop
-! endif
-! ! enddo
-! ! enddo
-! !endif
-!
! endif
!
! enddo
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_shape3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_shape3D.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_shape3D.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -150,3 +150,120 @@
end subroutine get_shape3D
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! 3D shape functions for given, single xi/eta/gamma location
+
+ subroutine get_shape3D_single(myrank,shape3D,xi,eta,gamma)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: myrank
+
+ ! 3D shape functions
+ double precision :: shape3D(NGNOD)
+
+ ! location
+ double precision :: xi,eta,gamma
+
+ ! local parameters
+ double precision :: ra1,ra2,rb1,rb2,rc1,rc2
+ double precision, parameter :: ONE_EIGHTH = 0.125d0
+ double precision :: sumshape
+ integer :: ia
+
+! check that the parameter file is correct
+ if(NGNOD /= 8) call exit_MPI(myrank,'elements should have 8 control nodes')
+
+!--- case of a 3D 8-node element (Dhatt-Touzot p. 115)
+ ra1 = one + xi
+ ra2 = one - xi
+
+ rb1 = one + eta
+ rb2 = one - eta
+
+ rc1 = one + gamma
+ rc2 = one - gamma
+
+ ! shape functions
+ shape3D(1) = ONE_EIGHTH*ra2*rb2*rc2
+ shape3D(2) = ONE_EIGHTH*ra1*rb2*rc2
+ shape3D(3) = ONE_EIGHTH*ra1*rb1*rc2
+ shape3D(4) = ONE_EIGHTH*ra2*rb1*rc2
+ shape3D(5) = ONE_EIGHTH*ra2*rb2*rc1
+ shape3D(6) = ONE_EIGHTH*ra1*rb2*rc1
+ shape3D(7) = ONE_EIGHTH*ra1*rb1*rc1
+ shape3D(8) = ONE_EIGHTH*ra2*rb1*rc1
+
+ ! check the shape functions
+ sumshape = ZERO
+ do ia=1,NGNOD
+ sumshape = sumshape + shape3D(ia)
+ enddo
+
+ ! sum of shape functions should be one
+ ! sum of derivative of shape functions should be zero
+ if(abs(sumshape-one) > TINYVAL) call exit_MPI(myrank,'error single shape functions')
+
+ end subroutine get_shape3D_single
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine get_shape3D_element_corners(xelm,yelm,zelm,ispec,&
+ ibool,xstore,ystore,zstore,NSPEC_AB,NGLOB_AB)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: ispec
+ integer :: NSPEC_AB,NGLOB_AB
+
+ real(kind=CUSTOM_REAL),dimension(NGNOD),intent(out) :: xelm,yelm,zelm
+
+ ! mesh coordinates
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB) :: xstore,ystore,zstore
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! 8 node corners
+ xelm(1)=xstore(ibool(1,1,1,ispec))
+ yelm(1)=ystore(ibool(1,1,1,ispec))
+ zelm(1)=zstore(ibool(1,1,1,ispec))
+
+ xelm(2)=xstore(ibool(NGLLX,1,1,ispec))
+ yelm(2)=ystore(ibool(NGLLX,1,1,ispec))
+ zelm(2)=zstore(ibool(NGLLX,1,1,ispec))
+
+ xelm(3)=xstore(ibool(NGLLX,NGLLY,1,ispec))
+ yelm(3)=ystore(ibool(NGLLX,NGLLY,1,ispec))
+ zelm(3)=zstore(ibool(NGLLX,NGLLY,1,ispec))
+
+ xelm(4)=xstore(ibool(1,NGLLY,1,ispec))
+ yelm(4)=ystore(ibool(1,NGLLY,1,ispec))
+ zelm(4)=zstore(ibool(1,NGLLY,1,ispec))
+
+ xelm(5)=xstore(ibool(1,1,NGLLZ,ispec))
+ yelm(5)=ystore(ibool(1,1,NGLLZ,ispec))
+ zelm(5)=zstore(ibool(1,1,NGLLZ,ispec))
+
+ xelm(6)=xstore(ibool(NGLLX,1,NGLLZ,ispec))
+ yelm(6)=ystore(ibool(NGLLX,1,NGLLZ,ispec))
+ zelm(6)=zstore(ibool(NGLLX,1,NGLLZ,ispec))
+
+ xelm(7)=xstore(ibool(NGLLX,NGLLY,NGLLZ,ispec))
+ yelm(7)=ystore(ibool(NGLLX,NGLLY,NGLLZ,ispec))
+ zelm(7)=zstore(ibool(NGLLX,NGLLY,NGLLZ,ispec))
+
+ xelm(8)=xstore(ibool(1,NGLLY,NGLLZ,ispec))
+ yelm(8)=ystore(ibool(1,NGLLY,NGLLZ,ispec))
+ zelm(8)=zstore(ibool(1,NGLLY,NGLLZ,ispec))
+
+ end subroutine get_shape3D_element_corners
+
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -29,8 +29,8 @@
use specfem_par
use specfem_par_elastic
- !use specfem_par_movie
-
+ use specfem_par_acoustic
+ use specfem_par_poroelastic
implicit none
integer :: sizeprocs
@@ -91,6 +91,12 @@
stop 'must have NGLLX = NGLLY = NGLLZ'
endif
+ ! exclusive movie flags
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
+ MOVIE_SURFACE = .false.
+ CREATE_SHAKEMAP = .false.
+ endif
+
! chris: DT_ext_mesh & NSTE_ext_mesh were in constants.h, I suppressed it, now it is Par_file & read in
! read_parameters_file.f90
! DT = DT_ext_mesh
@@ -183,45 +189,48 @@
allocate(ystore(NGLOB_AB))
allocate(zstore(NGLOB_AB))
! material properties
+! allocate(rhostore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(mustore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+! material flags
+ allocate(ispec_is_acoustic(NSPEC_AB))
+ allocate(ispec_is_elastic(NSPEC_AB))
+ allocate(ispec_is_poroelastic(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(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
- allocate(c66store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+! allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+! allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+! allocate(c66store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
! allocate(idoubling(NSPEC_AB))
!mass matrix
- allocate(rmass(NGLOB_AB))
+! allocate(rmass(NGLOB_AB))
allocate(rmass_ocean_load(NGLOB_AB))
- allocate(updated_dof_ocean_load(NGLOB_AB))
-! displacement,velocity,acceleration
- allocate(displ(NDIM,NGLOB_AB))
- allocate(veloc(NDIM,NGLOB_AB))
- allocate(accel(NDIM,NGLOB_AB))
+ !allocate(updated_dof_ocean_load(NGLOB_AB))
+
! attenuation
- allocate(iflag_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+! allocate(iflag_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
end subroutine
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -28,6 +28,10 @@
subroutine iterate_time()
use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+
implicit none
!
@@ -67,24 +71,17 @@
! update displacement using Newark time scheme
call iterate_time_update_displacement_scheme()
+
+! acoustic solver
+! (needs to be done first, before elastic one)
+ if( ACOUSTIC_SIMULATION ) call compute_forces_acoustic()
! elastic solver
- call compute_forces_elastic()
-
-! multiply by the inverse of the mass matrix
- call iterate_time_update_acceleration()
+ if( ELASTIC_SIMULATION ) call compute_forces_elastic()
-! updates acceleration with ocean load term
- if(OCEANS) then
-
- stop 'DK DK oceans have been removed for now because we need a flag to detect the surface elements'
+! poroelastic solver
+ if( POROELASTIC_SIMULATION ) stop 'poroelastic simulation not implemented yet'
- call iterate_time_ocean_load()
- endif
-
-! updates velocity
- call iterate_time_update_velocity()
-
! write the seismograms with time shift
if (nrec_local > 0) then
call iterate_time_write_seismograms()
@@ -108,7 +105,7 @@
! save MOVIE on the SURFACE
if(MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- stop 'DK DK MOVIE_SURFACE has been removed for now because we need a flag to detect the surface elements'
+ !stop 'DK DK MOVIE_SURFACE has been removed for now because we need a flag to detect the surface elements'
call iterate_time_movie_surface_output_obsolete()
endif
@@ -116,7 +113,7 @@
! compute SHAKING INTENSITY MAP
if(CREATE_SHAKEMAP) then
- stop 'DK DK CREATE_SHAKEMAP has been removed for now because we need a flag to detect the surface elements'
+ !stop 'DK DK CREATE_SHAKEMAP has been removed for now because we need a flag to detect the surface elements'
call iterate_time_create_shakemap_obsolete()
endif
@@ -144,12 +141,23 @@
use specfem_par
use specfem_par_elastic
-
+ use specfem_par_acoustic
implicit none
+ double precision :: tCPU,t_remain,t_total
+ integer :: ihours,iminutes,iseconds,int_tCPU, &
+ ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
+ ihours_total,iminutes_total,iseconds_total,int_t_total
+
! compute maximum of norm of displacement in each slice
- Usolidnorm = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2 + displ(3,:)**2))
-
+ if( ELASTIC_SIMULATION ) then
+ Usolidnorm = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2 + displ(3,:)**2))
+ else
+ if( ACOUSTIC_SIMULATION ) then
+ Usolidnorm = maxval(abs(potential_dot_dot_acoustic(:)))
+ endif
+ endif
+
! compute the maximum of the maxima for all the slices using an MPI reduction
call max_all_cr(Usolidnorm,Usolidnorm_all)
@@ -173,7 +181,13 @@
write(IMAIN,*) 'Elapsed time in seconds = ',tCPU
write(IMAIN,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
write(IMAIN,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
- write(IMAIN,*) 'Max norm displacement vector U in all slices (m) = ',Usolidnorm_all
+ if( ELASTIC_SIMULATION ) then
+ write(IMAIN,*) 'Max norm displacement vector U in all slices (m) = ',Usolidnorm_all
+ else
+ if( ACOUSTIC_SIMULATION ) then
+ write(IMAIN,*) 'Max norm pressure P in all slices (m) = ',Usolidnorm_all
+ endif
+ endif
! if (SIMULATION_TYPE == 3) write(IMAIN,*) &
! 'Max norm displacement vector U (backward) in all slices (m) = ',b_Usolidnorm_all
@@ -239,150 +253,85 @@
subroutine iterate_time_update_displacement_scheme()
-! Newark finite-difference time scheme
+! explicit Newark time scheme with acoustic & elastic domains:
+! (see e.g. Hughes, 1987; Chaljub et al., 2003)
+!
+! chi(t+delta_t) = chi(t) + delta_t chi_dot(t) + 1/2 delta_t**2 chi_dot_dot(t)
+! chi_dot(t+delta_t) = chi_dot(t) + 1/2 delta_t chi_dot_dot(t) + 1/2 delta_t chi_dot_dot(t+delta_t)
+! chi_dot_dot(t+delta_t) = 1/M_acoustic( -K_acoustic chi(t+delta) + B_acoustic u(t+delta_t) + f(t+delta_t) )
+!
+! u(t+delta_t) = u(t) + delta_t v(t) + 1/2 delta_t**2 a(t)
+! v(t+delta_t) = v(t) + 1/2 delta_t a(t) + 1/2 delta_t a(t+delta_t)
+! a(t+delta_t) = 1/M_elastic ( -K_elastic u(t+delta) + B_elastic chi_dot_dot(t+delta_t) + f( t+delta_t) )
+!
+! where
+! chi, chi_dot, chi_dot_dot are acoustic (fluid) potentials ( dotted with respect to time)
+! u, v, a are displacement,velocity & acceleration
+! M is mass matrix, K stiffness matrix and B boundary term for acoustic/elastic domains
+! f denotes a source term (acoustic/elastic)
+!
+! note that this stage calculates the predictor terms
+!
+! for
+! potential chi_dot(t+delta) requires + 1/2 delta_t chi_dot_dot(t+delta_t)
+! at a later stage (corrector) once where chi_dot_dot(t+delta) is calculated
+! and similar,
+! velocity v(t+delta_t) requires + 1/2 delta_t a(t+delta_t)
+! at a later stage once where a(t+delta) is calculated
+! also:
+! boundary term B_elastic requires chi_dot_dot(t+delta)
+! thus chi_dot_dot has to be updated first before the elastic boundary term is considered
use specfem_par
+ use specfem_par_acoustic
use specfem_par_elastic
+ use specfem_par_poroelastic
implicit none
+! updates acoustic potentials
+ if( ACOUSTIC_SIMULATION ) then
+ potential_acoustic(:) = potential_acoustic(:) &
+ + deltat * potential_dot_acoustic(:) &
+ + deltatsqover2 * potential_dot_dot_acoustic(:)
+ potential_dot_acoustic(:) = potential_dot_acoustic(:) &
+ + deltatover2 * potential_dot_dot_acoustic(:)
+ potential_dot_dot_acoustic(:) = 0._CUSTOM_REAL
+ endif
+
! updates elastic displacement and velocity
- displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
- veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
- accel(:,:) = 0._CUSTOM_REAL
+ if( ELASTIC_SIMULATION ) then
+ 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
+ endif
-!! 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
!=====================================================================
- 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.
-
-! for surface elements exactly at the top of the model (ocean bottom)
- do ispec2D = 1,NSPEC2D_TOP
-
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
-
-! only for DOFs exactly at the top of the model (ocean bottom)
- k = NGLLZ
-
- do j = 1,NGLLY
- do i = 1,NGLLX
-
-! get global point number
- iglob = ibool(i,j,k,ispec)
-
-! only update once
- if(.not. updated_dof_ocean_load(iglob)) then
-
-! get normal
-!! DK DK array not created yet for CUBIT nx = normal_top(1,i,j,ispec2D)
-!! DK DK array not created yet for CUBIT ny = normal_top(2,i,j,ispec2D)
-!! DK DK array not created yet for CUBIT nz = normal_top(3,i,j,ispec2D)
-
-! make updated component of right-hand side
-! we divide by rmass() which is 1 / M
-! we use the total force which includes the Coriolis term above
- force_normal_comp = (accel(1,iglob)*nx + &
- accel(2,iglob)*ny + accel(3,iglob)*nz) / rmass(iglob)
-
- additional_term = (rmass_ocean_load(iglob) - rmass(iglob)) * force_normal_comp
-
- accel(1,iglob) = accel(1,iglob) + additional_term * nx
- accel(2,iglob) = accel(2,iglob) + additional_term * ny
- accel(3,iglob) = accel(3,iglob) + additional_term * nz
-
- if (SIMULATION_TYPE == 3) then
-!! DK DK array not created yet for CUBIT
-! b_force_normal_comp = (b_accel(1,iglob)*nx + &
-! b_accel(2,iglob)*ny + b_accel(3,iglob)*nz) / rmass(iglob)
-
- b_additional_term = (rmass_ocean_load(iglob) - rmass(iglob)) * b_force_normal_comp
-
-!! DK DK array not created yet for CUBIT
-! b_accel(1,iglob) = b_accel(1,iglob) + b_additional_term * nx
-! b_accel(2,iglob) = b_accel(2,iglob) + b_additional_term * ny
-! b_accel(3,iglob) = b_accel(3,iglob) + b_additional_term * nz
- endif
-
-! done with this point
- updated_dof_ocean_load(iglob) = .true.
-
- endif
-
- enddo ! NGLLX
- enddo ! NGLLY
- enddo ! NSPEC2D_TOP
-
- end subroutine iterate_time_ocean_load
-
-!=====================================================================
-
subroutine iterate_time_write_seismograms()
! writes the seismograms with time shift
use specfem_par
+ use specfem_par_acoustic
use specfem_par_elastic
-
+ use specfem_par_poroelastic
implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: displ_element,veloc_element
+ double precision :: dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd,hlagrange
+ integer :: irec_local,irec
+ integer :: iglob,ispec,i,j,k
do irec_local = 1,nrec_local
@@ -391,19 +340,57 @@
! perform the general interpolation using Lagrange polynomials
if(FASTER_RECEIVERS_POINTS_ONLY) then
-
+ ispec = ispec_selected_rec(irec)
iglob = ibool(nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
- nint(gamma_receiver(irec)),ispec_selected_rec(irec))
- dxd = dble(displ(1,iglob))
- dyd = dble(displ(2,iglob))
- dzd = dble(displ(3,iglob))
- vxd = dble(veloc(1,iglob))
- vyd = dble(veloc(2,iglob))
- vzd = dble(veloc(3,iglob))
- axd = dble(accel(1,iglob))
- ayd = dble(accel(2,iglob))
- azd = dble(accel(3,iglob))
+ nint(gamma_receiver(irec)),ispec)
+ ! elastic wave field
+ if( ispec_is_elastic(ispec) ) then
+ dxd = dble(displ(1,iglob))
+ dyd = dble(displ(2,iglob))
+ dzd = dble(displ(3,iglob))
+ vxd = dble(veloc(1,iglob))
+ vyd = dble(veloc(2,iglob))
+ vzd = dble(veloc(3,iglob))
+ axd = dble(accel(1,iglob))
+ ayd = dble(accel(2,iglob))
+ azd = dble(accel(3,iglob))
+ endif
+
+ ! acoustic wave field
+ if( ispec_is_acoustic(ispec) ) then
+ ! displacement
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! velocity
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! displacement
+ dxd = displ_element(1,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
+ nint(gamma_receiver(irec)))
+ dyd = displ_element(2,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
+ nint(gamma_receiver(irec)))
+ dzd = displ_element(3,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
+ nint(gamma_receiver(irec)))
+ ! velocity
+ vxd = veloc_element(1,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
+ nint(gamma_receiver(irec)))
+ vyd = veloc_element(2,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
+ nint(gamma_receiver(irec)))
+ vzd = veloc_element(3,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
+ nint(gamma_receiver(irec)))
+ ! pressure
+ axd = - potential_dot_dot_acoustic(iglob)
+ ayd = - potential_dot_dot_acoustic(iglob)
+ azd = - potential_dot_dot_acoustic(iglob)
+ endif ! acoustic
+
else
dxd = ZERO
@@ -420,42 +407,87 @@
if (SIMULATION_TYPE == 1) then
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
+ ispec = ispec_selected_rec(irec)
-! receivers are always located at the surface of the mesh
- iglob = ibool(i,j,k,ispec_selected_rec(irec))
+ ! elastic wave field
+ if( ispec_is_elastic(ispec) ) then
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ ! receivers are always located at the surface of the mesh
+ iglob = ibool(i,j,k,ispec)
- hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
+ hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
-
-! save displacement
- dxd = dxd + dble(displ(1,iglob))*hlagrange
- dyd = dyd + dble(displ(2,iglob))*hlagrange
- dzd = dzd + dble(displ(3,iglob))*hlagrange
-
-! save velocity
- vxd = vxd + dble(veloc(1,iglob))*hlagrange
- vyd = vyd + dble(veloc(2,iglob))*hlagrange
- vzd = vzd + dble(veloc(3,iglob))*hlagrange
-
-! save acceleration
- axd = axd + dble(accel(1,iglob))*hlagrange
- ayd = ayd + dble(accel(2,iglob))*hlagrange
- azd = azd + dble(accel(3,iglob))*hlagrange
-
+ ! elastic wave field
+ if( ispec_is_elastic(ispec) ) then
+ ! save displacement
+ dxd = dxd + dble(displ(1,iglob))*hlagrange
+ dyd = dyd + dble(displ(2,iglob))*hlagrange
+ dzd = dzd + dble(displ(3,iglob))*hlagrange
+ ! save velocity
+ vxd = vxd + dble(veloc(1,iglob))*hlagrange
+ vyd = vyd + dble(veloc(2,iglob))*hlagrange
+ vzd = vzd + dble(veloc(3,iglob))*hlagrange
+ ! save acceleration
+ axd = axd + dble(accel(1,iglob))*hlagrange
+ ayd = ayd + dble(accel(2,iglob))*hlagrange
+ azd = azd + dble(accel(3,iglob))*hlagrange
+ endif
+
+ enddo
enddo
enddo
- enddo
-
+ endif
+
+ ! acoustic wave field
+ if( ispec_is_acoustic(ispec) ) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! interpolates vector field
+ do k= 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
+ ! displacement
+ dxd = dxd + hlagrange*displ_element(1,i,j,k)
+ dyd = dyd + hlagrange*displ_element(2,i,j,k)
+ dzd = dzd + hlagrange*displ_element(3,i,j,k)
+ ! velocity
+ vxd = vxd + hlagrange*veloc_element(1,i,j,k)
+ vyd = vxd + hlagrange*veloc_element(2,i,j,k)
+ vzd = vxd + hlagrange*veloc_element(3,i,j,k)
+ ! pressure
+ axd = axd - hlagrange*potential_dot_dot_acoustic(iglob)
+ ayd = ayd - hlagrange*potential_dot_dot_acoustic(iglob)
+ azd = azd - hlagrange*potential_dot_dot_acoustic(iglob)
+ enddo
+ enddo
+ enddo
+ endif ! acoustic
+
else if (SIMULATION_TYPE == 2) then
+ ! adjoint source is placed at receiver
+ ispec = ispec_selected_source(irec)
+
do k = 1,NGLLZ
do j = 1,NGLLY
do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec_selected_source(irec))
+ iglob = ibool(i,j,k,ispec)
hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
@@ -475,7 +507,7 @@
enddo
enddo
- ispec = ispec_selected_source(irec)
+ !ispec = ispec_selected_source(irec)
call compute_adj_source_frechet(displ_s,Mxx(irec),Myy(irec),Mzz(irec),Mxy(irec),Mxz(irec),Myz(irec),eps_s,eps_m_s, &
hxir_store(irec_local,:),hetar_store(irec_local,:),hgammar_store(irec_local,:), &
@@ -495,12 +527,14 @@
sloc_der(:,irec_local) = sloc_der(:,irec_local) + eps_m_s(:) * stf_deltat
else if (SIMULATION_TYPE == 3) then
-
+
+ ispec = ispec_selected_rec(irec)
+
do k = 1,NGLLZ
do j = 1,NGLLY
do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec_selected_rec(irec))
+ iglob = ibool(i,j,k,ispec)
hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
@@ -617,152 +651,79 @@
use specfem_par
use specfem_par_elastic
use specfem_par_movie
-
implicit none
-! initializes arrays
+ integer :: ipoin,ispec,iglob,ispec2D
+
+! initializes arrays for point coordinates
if (it == 1) then
-
store_val_ux_external_mesh(:) = -HUGEVAL
store_val_uy_external_mesh(:) = -HUGEVAL
store_val_uz_external_mesh(:) = -HUGEVAL
- do ispec = 1,nfaces_surface_external_mesh
+ do ispec2D = 1,nfaces_surface_external_mesh
if (USE_HIGHRES_FOR_MOVIES) then
do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_external_mesh(ipoin,ispec2D)
! x,y,z coordinates
- store_val_x_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = xstore(faces_surface_external_mesh(ipoin,ispec))
- store_val_y_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = ystore(faces_surface_external_mesh(ipoin,ispec))
- store_val_z_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = zstore(faces_surface_external_mesh(ipoin,ispec))
+ store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = zstore(iglob)
enddo
else
do ipoin = 1, 4
+ iglob = faces_surface_external_mesh(ipoin,ispec2D)
! x,y,z coordinates
- store_val_x_external_mesh(NGNOD2D*(ispec-1)+ipoin) = xstore(faces_surface_external_mesh(ipoin,ispec))
- store_val_y_external_mesh(NGNOD2D*(ispec-1)+ipoin) = ystore(faces_surface_external_mesh(ipoin,ispec))
- store_val_z_external_mesh(NGNOD2D*(ispec-1)+ipoin) = zstore(faces_surface_external_mesh(ipoin,ispec))
+ store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = zstore(iglob)
enddo
-! store_val_x_external_mesh(NGNOD2D*(ispec-1)+1) = xstore(faces_surface_external_mesh(1,ispec))
-! store_val_x_external_mesh(NGNOD2D*(ispec-1)+2) = xstore(faces_surface_external_mesh(2,ispec))
-! store_val_x_external_mesh(NGNOD2D*(ispec-1)+3) = xstore(faces_surface_external_mesh(3,ispec))
-! store_val_x_external_mesh(NGNOD2D*(ispec-1)+4) = xstore(faces_surface_external_mesh(4,ispec))
-! store_val_y_external_mesh(NGNOD2D*(ispec-1)+1) = ystore(faces_surface_external_mesh(1,ispec))
-! store_val_y_external_mesh(NGNOD2D*(ispec-1)+2) = ystore(faces_surface_external_mesh(2,ispec))
-! store_val_y_external_mesh(NGNOD2D*(ispec-1)+3) = ystore(faces_surface_external_mesh(3,ispec))
-! store_val_y_external_mesh(NGNOD2D*(ispec-1)+4) = ystore(faces_surface_external_mesh(4,ispec))
-! store_val_z_external_mesh(NGNOD2D*(ispec-1)+1) = zstore(faces_surface_external_mesh(1,ispec))
-! store_val_z_external_mesh(NGNOD2D*(ispec-1)+2) = zstore(faces_surface_external_mesh(2,ispec))
-! store_val_z_external_mesh(NGNOD2D*(ispec-1)+3) = zstore(faces_surface_external_mesh(3,ispec))
-! store_val_z_external_mesh(NGNOD2D*(ispec-1)+4) = zstore(faces_surface_external_mesh(4,ispec))
endif
enddo
endif
! stores displacement, velocity and acceleration amplitudes
- do ispec = 1,nfaces_surface_external_mesh
+ do ispec2D = 1,nfaces_surface_external_mesh
+ ispec = faces_surface_external_mesh_ispec(ispec2D)
+ ! high-resolution
if (USE_HIGHRES_FOR_MOVIES) then
do ipoin = 1, NGLLX*NGLLY
- ! norm of displacement
- store_val_ux_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = &
- max(store_val_ux_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin), &
- sqrt(displ(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
- displ(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
- displ(3,faces_surface_external_mesh(ipoin,ispec))**2))
- ! norm of velocity
- store_val_uy_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = &
- max(store_val_uy_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin), &
- sqrt(veloc(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
- veloc(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
- veloc(3,faces_surface_external_mesh(ipoin,ispec))**2))
- ! norm of acceleration
- store_val_uz_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = &
- max(store_val_uz_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin), &
- sqrt(accel(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
- accel(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
- accel(3,faces_surface_external_mesh(ipoin,ispec))**2))
-
+ iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ ! saves norm of displacement,velocity and acceleration vector
+ if( ispec_is_elastic(ispec) ) then
+ ! norm of displacement
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2))
+ ! norm of velocity
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(veloc(1,iglob)**2 + veloc(2,iglob)**2 + veloc(3,iglob)**2))
+ ! norm of acceleration
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(accel(1,iglob)**2 + accel(2,iglob)**2 + accel(3,iglob)**2))
+ endif
enddo
else
+ ! low-resolution: only corner points outputted
do ipoin = 1, 4
- ! norm of displacement
- store_val_ux_external_mesh(NGNOD2D*(ispec-1)+ipoin) = &
- max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+ipoin), &
- sqrt(displ(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
- displ(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
- displ(3,faces_surface_external_mesh(ipoin,ispec))**2))
- ! norm of velocity
- store_val_uy_external_mesh(NGNOD2D*(ispec-1)+ipoin) = &
- max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+ipoin), &
- sqrt(veloc(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
- veloc(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
- veloc(3,faces_surface_external_mesh(ipoin,ispec))**2))
- ! norm of acceleration
- store_val_uz_external_mesh(NGNOD2D*(ispec-1)+ipoin) = &
- max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+ipoin), &
- sqrt(accel(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
- accel(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
- accel(3,faces_surface_external_mesh(ipoin,ispec))**2))
+ iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ ! saves norm of displacement,velocity and acceleration vector
+ if( ispec_is_elastic(ispec) ) then
+ ! norm of displacement
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2))
+ ! norm of velocity
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(veloc(1,iglob)**2 + veloc(2,iglob)**2 + veloc(3,iglob)**2))
+ ! norm of acceleration
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(accel(1,iglob)**2 + accel(2,iglob)**2 + accel(3,iglob)**2))
+ endif
enddo
-
-! store_val_ux_external_mesh(NGNOD2D*(ispec-1)+1) = &
-! max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+1), &
-! sqrt(displ(1,faces_surface_external_mesh(1,ispec))**2 + &
-! displ(2,faces_surface_external_mesh(1,ispec))**2 + &
-! displ(3,faces_surface_external_mesh(1,ispec))**2))
-! store_val_ux_external_mesh(NGNOD2D*(ispec-1)+2) = &
-! max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+2), &
-! sqrt(displ(1,faces_surface_external_mesh(2,ispec))**2 + &
-! displ(2,faces_surface_external_mesh(2,ispec))**2 + &
-! displ(3,faces_surface_external_mesh(2,ispec))**2))
-! store_val_ux_external_mesh(NGNOD2D*(ispec-1)+3) = &
-! max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+3), &
-! sqrt(displ(1,faces_surface_external_mesh(3,ispec))**2 + &
-! displ(2,faces_surface_external_mesh(3,ispec))**2 + &
-! displ(3,faces_surface_external_mesh(3,ispec))**2))
-! store_val_ux_external_mesh(NGNOD2D*(ispec-1)+4) = &
-! max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+4), &
-! sqrt(displ(1,faces_surface_external_mesh(4,ispec))**2 + &
-! displ(2,faces_surface_external_mesh(4,ispec))**2 + &
-! displ(3,faces_surface_external_mesh(4,ispec))**2))
-! store_val_uy_external_mesh(NGNOD2D*(ispec-1)+1) = &
-! max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+1), &
-! sqrt(veloc(1,faces_surface_external_mesh(1,ispec))**2 + &
-! veloc(2,faces_surface_external_mesh(1,ispec))**2 + &
-! veloc(3,faces_surface_external_mesh(1,ispec))**2))
-! store_val_uy_external_mesh(NGNOD2D*(ispec-1)+2) = &
-! max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+2), &
-! sqrt(veloc(1,faces_surface_external_mesh(2,ispec))**2 + &
-! veloc(2,faces_surface_external_mesh(2,ispec))**2 + &
-! veloc(3,faces_surface_external_mesh(2,ispec))**2))
-! store_val_uy_external_mesh(NGNOD2D*(ispec-1)+3) = &
-! max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+3), &
-! sqrt(veloc(1,faces_surface_external_mesh(3,ispec))**2 + &
-! veloc(2,faces_surface_external_mesh(3,ispec))**2 + &
-! veloc(3,faces_surface_external_mesh(3,ispec))**2))
-! store_val_uy_external_mesh(NGNOD2D*(ispec-1)+4) = &
-! max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+4), &
-! sqrt(veloc(1,faces_surface_external_mesh(4,ispec))**2 + &
-! veloc(2,faces_surface_external_mesh(4,ispec))**2 + &
-! veloc(3,faces_surface_external_mesh(4,ispec))**2))
-! store_val_uz_external_mesh(NGNOD2D*(ispec-1)+1) = &
-! max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+1), &
-! sqrt(accel(1,faces_surface_external_mesh(1,ispec))**2 + &
-! accel(2,faces_surface_external_mesh(1,ispec))**2 + &
-! accel(3,faces_surface_external_mesh(1,ispec))**2))
-! store_val_uz_external_mesh(NGNOD2D*(ispec-1)+2) = &
-! max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+2), &
-! sqrt(accel(1,faces_surface_external_mesh(2,ispec))**2 + &
-! accel(2,faces_surface_external_mesh(2,ispec))**2 + &
-! accel(3,faces_surface_external_mesh(2,ispec))**2))
-! store_val_uz_external_mesh(NGNOD2D*(ispec-1)+3) = &
-! max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+3), &
-! sqrt(accel(1,faces_surface_external_mesh(3,ispec))**2 + &
-! accel(2,faces_surface_external_mesh(3,ispec))**2 + &
-! accel(3,faces_surface_external_mesh(3,ispec))**2))
-! store_val_uz_external_mesh(NGNOD2D*(ispec-1)+4) = &
-! max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+4), &
-! sqrt(accel(1,faces_surface_external_mesh(4,ispec))**2 + &
-! accel(2,faces_surface_external_mesh(4,ispec))**2 + &
-! accel(3,faces_surface_external_mesh(4,ispec))**2))
endif
enddo
@@ -832,73 +793,144 @@
use specfem_par
use specfem_par_elastic
- use specfem_par_movie
-
+ use specfem_par_acoustic
+ use specfem_par_movie
implicit none
-! get coordinates of surface mesh and surface displacement
- do ispec = 1,nfaces_surface_external_mesh
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: veloc_element
+ integer :: ispec2D,ispec,ipoin,iglob,i,j,k
+ logical :: is_done
+
+! initializes arrays for point coordinates
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ do ispec2D = 1,nfaces_surface_external_mesh
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ ! x,y,z coordinates
+ store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = zstore(iglob)
+ enddo
+ else
+ do ipoin = 1, 4
+ iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ ! x,y,z coordinates
+ store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = zstore(iglob)
+ enddo
+ endif
+ enddo
+ endif
+
+! saves surface velocities
+ do ispec2D = 1,nfaces_surface_external_mesh
+ ispec = faces_surface_external_mesh_ispec(ispec2D)
+
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ endif
+
if (USE_HIGHRES_FOR_MOVIES) then
do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_external_mesh(ipoin,ispec2D)
! x,y,z coordinates
- store_val_x_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = xstore(faces_surface_external_mesh(ipoin,ispec))
- store_val_y_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = ystore(faces_surface_external_mesh(ipoin,ispec))
- store_val_z_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = zstore(faces_surface_external_mesh(ipoin,ispec))
- ! velocity x,y,z-components
- store_val_ux_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = veloc(1,faces_surface_external_mesh(ipoin,ispec))
- store_val_uy_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = veloc(2,faces_surface_external_mesh(ipoin,ispec))
- store_val_uz_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = veloc(3,faces_surface_external_mesh(ipoin,ispec))
+ !store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
+ !store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
+ !store_val_z_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = zstore(iglob)
+ ! saves velocity vector
+ if( ispec_is_elastic(ispec) ) then
+ ! velocity x,y,z-components
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(3,iglob)
+ endif
+ ! acoustic pressure potential
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(1,i,j,k)
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(2,i,j,k)
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(3,i,j,k)
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ ! only pressure
+ !store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
+ !store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
+ !store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
+ endif
enddo
else
do ipoin = 1, 4
+ iglob = faces_surface_external_mesh(ipoin,ispec2D)
! x,y,z coordinates
- store_val_x_external_mesh(NGNOD2D*(ispec-1)+ipoin) = xstore(faces_surface_external_mesh(ipoin,ispec))
- store_val_y_external_mesh(NGNOD2D*(ispec-1)+ipoin) = ystore(faces_surface_external_mesh(ipoin,ispec))
- store_val_z_external_mesh(NGNOD2D*(ispec-1)+ipoin) = zstore(faces_surface_external_mesh(ipoin,ispec))
- ! velocity x,y,z-components
- store_val_ux_external_mesh(NGNOD2D*(ispec-1)+ipoin) = veloc(1,faces_surface_external_mesh(ipoin,ispec))
- store_val_uy_external_mesh(NGNOD2D*(ispec-1)+ipoin) = veloc(2,faces_surface_external_mesh(ipoin,ispec))
- store_val_uz_external_mesh(NGNOD2D*(ispec-1)+ipoin) = veloc(3,faces_surface_external_mesh(ipoin,ispec))
-
+ !store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
+ !store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
+ !store_val_z_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = zstore(iglob)
+ ! saves velocity vector
+ if( ispec_is_elastic(ispec) ) then
+ ! velocity x,y,z-components
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(3,iglob)
+ endif
+ ! acoustic pressure potential
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(1,i,j,k)
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(2,i,j,k)
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(3,i,j,k)
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ ! only pressure
+ !store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
+ !store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
+ !store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
+ endif
enddo
-! store_val_x_external_mesh(NGNOD2D*(ispec-1)+1) = xstore(faces_surface_external_mesh(1,ispec))
-! store_val_x_external_mesh(NGNOD2D*(ispec-1)+2) = xstore(faces_surface_external_mesh(2,ispec))
-! store_val_x_external_mesh(NGNOD2D*(ispec-1)+3) = xstore(faces_surface_external_mesh(3,ispec))
-! store_val_x_external_mesh(NGNOD2D*(ispec-1)+4) = xstore(faces_surface_external_mesh(4,ispec))
-! store_val_y_external_mesh(NGNOD2D*(ispec-1)+1) = ystore(faces_surface_external_mesh(1,ispec))
-! store_val_y_external_mesh(NGNOD2D*(ispec-1)+2) = ystore(faces_surface_external_mesh(2,ispec))
-! store_val_y_external_mesh(NGNOD2D*(ispec-1)+3) = ystore(faces_surface_external_mesh(3,ispec))
-! store_val_y_external_mesh(NGNOD2D*(ispec-1)+4) = ystore(faces_surface_external_mesh(4,ispec))
-! store_val_z_external_mesh(NGNOD2D*(ispec-1)+1) = zstore(faces_surface_external_mesh(1,ispec))
-! store_val_z_external_mesh(NGNOD2D*(ispec-1)+2) = zstore(faces_surface_external_mesh(2,ispec))
-! store_val_z_external_mesh(NGNOD2D*(ispec-1)+3) = zstore(faces_surface_external_mesh(3,ispec))
-! store_val_z_external_mesh(NGNOD2D*(ispec-1)+4) = zstore(faces_surface_external_mesh(4,ispec))
-! store_val_ux_external_mesh(NGNOD2D*(ispec-1)+1) = veloc(1,faces_surface_external_mesh(1,ispec))
-! store_val_ux_external_mesh(NGNOD2D*(ispec-1)+2) = veloc(1,faces_surface_external_mesh(2,ispec))
-! store_val_ux_external_mesh(NGNOD2D*(ispec-1)+3) = veloc(1,faces_surface_external_mesh(3,ispec))
-! store_val_ux_external_mesh(NGNOD2D*(ispec-1)+4) = veloc(1,faces_surface_external_mesh(4,ispec))
-! store_val_uy_external_mesh(NGNOD2D*(ispec-1)+1) = veloc(2,faces_surface_external_mesh(1,ispec))
-! store_val_uy_external_mesh(NGNOD2D*(ispec-1)+2) = veloc(2,faces_surface_external_mesh(2,ispec))
-! store_val_uy_external_mesh(NGNOD2D*(ispec-1)+3) = veloc(2,faces_surface_external_mesh(3,ispec))
-! store_val_uy_external_mesh(NGNOD2D*(ispec-1)+4) = veloc(2,faces_surface_external_mesh(4,ispec))
-! store_val_uz_external_mesh(NGNOD2D*(ispec-1)+1) = veloc(3,faces_surface_external_mesh(1,ispec))
-! store_val_uz_external_mesh(NGNOD2D*(ispec-1)+2) = veloc(3,faces_surface_external_mesh(2,ispec))
-! store_val_uz_external_mesh(NGNOD2D*(ispec-1)+3) = veloc(3,faces_surface_external_mesh(3,ispec))
-! store_val_uz_external_mesh(NGNOD2D*(ispec-1)+4) = veloc(3,faces_surface_external_mesh(4,ispec))
endif
enddo
! master process collects all info
if (USE_HIGHRES_FOR_MOVIES) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ endif
call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
@@ -909,15 +941,17 @@
store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
else
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
@@ -956,77 +990,202 @@
use specfem_par_movie
implicit none
-
-! get coordinates of surface mesh and surface displacement
- ipoin = 0
+ integer :: imin,imax,jmin,jmax,kmin,kmax,iface,igll
+ integer :: ipoin,iloc
+ integer :: ispec,i,j,k,iglob
- k = NGLLZ
- if (USE_HIGHRES_FOR_MOVIES) then
- do ispec2D = 1,NSPEC2D_TOP
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
- do j = 1,NGLLY
- do i = 1,NGLLX
+! initializes arrays for point coordinates
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ ipoin = 0
+ do iface=1,num_free_surface_faces
+ ispec = free_surface_ispec(iface)
+ ! high_resolution
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do igll = 1, NGLLSQUARE
ipoin = ipoin + 1
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
iglob = ibool(i,j,k,ispec)
- store_val_x(ipoin) = xstore(iglob)
- store_val_y(ipoin) = ystore(iglob)
- store_val_z(ipoin) = zstore(iglob)
+ ! coordinates
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ enddo
+ else
+ imin = minval( free_surface_ijk(1,:,iface) )
+ imax = maxval( free_surface_ijk(1,:,iface) )
+ jmin = minval( free_surface_ijk(2,:,iface) )
+ jmax = maxval( free_surface_ijk(2,:,iface) )
+ kmin = minval( free_surface_ijk(3,:,iface) )
+ kmax = maxval( free_surface_ijk(3,:,iface) )
+ do iloc = 1, NGNOD2D
+ ipoin = ipoin + 1
+ ! corner points
+ if( imin == imax ) then
+ iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
+ else if( jmin == jmax ) then
+ iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
+ else
+ iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
+ endif
+ ! coordinates
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ enddo
+ endif
+ enddo
+ endif
+
+
+! outputs values at free surface
+ ipoin = 0
+ do iface=1,num_free_surface_faces
+ ispec = free_surface_ispec(iface)
+ ! high_resolution
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do igll = 1, NGLLSQUARE
+ ipoin = ipoin + 1
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+ ! coordinates
+ !store_val_x_external_mesh(ipoin) = xstore(iglob)
+ !store_val_y_external_mesh(ipoin) = ystore(iglob)
+ !store_val_z_external_mesh(ipoin) = zstore(iglob)
+ ! elastic displacement/velocity
+ if( ispec_is_elastic(ispec) ) then
if(SAVE_DISPLACEMENT) then
- store_val_ux(ipoin) = displ(1,iglob)
- store_val_uy(ipoin) = displ(2,iglob)
- store_val_uz(ipoin) = displ(3,iglob)
+ store_val_ux_external_mesh(ipoin) = displ(1,iglob)
+ store_val_uy_external_mesh(ipoin) = displ(2,iglob)
+ store_val_uz_external_mesh(ipoin) = displ(3,iglob)
else
- store_val_ux(ipoin) = veloc(1,iglob)
- store_val_uy(ipoin) = veloc(2,iglob)
- store_val_uz(ipoin) = veloc(3,iglob)
+ store_val_ux_external_mesh(ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(ipoin) = veloc(3,iglob)
endif
- enddo
+ endif
enddo
- enddo ! ispec_top
- else
- do ispec2D = 1,NSPEC2D_TOP
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
- do iloc = 1, NGNOD2D
+ else
+ imin = minval( free_surface_ijk(1,:,iface) )
+ imax = maxval( free_surface_ijk(1,:,iface) )
+ jmin = minval( free_surface_ijk(2,:,iface) )
+ jmax = maxval( free_surface_ijk(2,:,iface) )
+ kmin = minval( free_surface_ijk(3,:,iface) )
+ kmax = maxval( free_surface_ijk(3,:,iface) )
+ do iloc = 1, NGNOD2D
ipoin = ipoin + 1
- iglob = ibool(iorderi(iloc),iorderj(iloc),k,ispec)
- store_val_x(ipoin) = xstore(iglob)
- store_val_y(ipoin) = ystore(iglob)
- store_val_z(ipoin) = zstore(iglob)
- if(SAVE_DISPLACEMENT) then
- store_val_ux(ipoin) = displ(1,iglob)
- store_val_uy(ipoin) = displ(2,iglob)
- store_val_uz(ipoin) = displ(3,iglob)
+ ! corner points
+ if( imin == imax ) then
+ iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
+ else if( jmin == jmax ) then
+ iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
else
- store_val_ux(ipoin) = veloc(1,iglob)
- store_val_uy(ipoin) = veloc(2,iglob)
- store_val_uz(ipoin) = veloc(3,iglob)
+ iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
endif
- enddo
- enddo ! ispec_top
+ ! coordinates
+ !store_val_x_external_mesh(ipoin) = xstore(iglob)
+ !store_val_y_external_mesh(ipoin) = ystore(iglob)
+ !store_val_z_external_mesh(ipoin) = zstore(iglob)
+ ! elastic displacement/velocity
+ if( ispec_is_elastic(ispec) ) then
+ if(SAVE_DISPLACEMENT) then
+ store_val_ux_external_mesh(ipoin) = displ(1,iglob)
+ store_val_uy_external_mesh(ipoin) = displ(2,iglob)
+ store_val_uz_external_mesh(ipoin) = displ(3,iglob)
+ else
+ store_val_ux_external_mesh(ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(ipoin) = veloc(3,iglob)
+ endif
+ endif
+ enddo ! iloc
+ endif
+ enddo ! iface
+
+! master process collects all info
+ if (USE_HIGHRES_FOR_MOVIES) then
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ endif
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ else
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
endif
- ispec = nmovie_points
-
- call gather_all_cr(store_val_x,ispec,store_val_x_all,ispec,NPROC)
- call gather_all_cr(store_val_y,ispec,store_val_y_all,ispec,NPROC)
- call gather_all_cr(store_val_z,ispec,store_val_z_all,ispec,NPROC)
- call gather_all_cr(store_val_ux,ispec,store_val_ux_all,ispec,NPROC)
- call gather_all_cr(store_val_uy,ispec,store_val_uy_all,ispec,NPROC)
- call gather_all_cr(store_val_uz,ispec,store_val_uz_all,ispec,NPROC)
-
-! save movie data to disk in home directory
+! file output
if(myrank == 0) then
- write(outputname,"('/moviedata',i6.6)") it
+ write(outputname,"('/moviedata_free_surface',i6.6)") it
open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted')
- write(IOUT) store_val_x_all
- write(IOUT) store_val_y_all
- write(IOUT) store_val_z_all
- write(IOUT) store_val_ux_all
- write(IOUT) store_val_uy_all
- write(IOUT) store_val_uz_all
+ write(IOUT) store_val_x_all_external_mesh ! x coordinate
+ write(IOUT) store_val_y_all_external_mesh ! y coordinate
+ write(IOUT) store_val_z_all_external_mesh ! z coordinate
+ write(IOUT) store_val_ux_all_external_mesh ! velocity x-component
+ write(IOUT) store_val_uy_all_external_mesh ! velocity y-component
+ write(IOUT) store_val_uz_all_external_mesh ! velocity z-component
close(IOUT)
endif
+! obsolete...
+! ispec = nmovie_points
+!
+! call gather_all_cr(store_val_x,ispec,store_val_x_all,ispec,NPROC)
+! call gather_all_cr(store_val_y,ispec,store_val_y_all,ispec,NPROC)
+! call gather_all_cr(store_val_z,ispec,store_val_z_all,ispec,NPROC)
+! call gather_all_cr(store_val_ux,ispec,store_val_ux_all,ispec,NPROC)
+! call gather_all_cr(store_val_uy,ispec,store_val_uy_all,ispec,NPROC)
+! call gather_all_cr(store_val_uz,ispec,store_val_uz_all,ispec,NPROC)
+!
+!! save movie data to disk in home directory
+! if(myrank == 0) then
+! write(outputname,"('/moviedata',i6.6)") it
+! open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted')
+! write(IOUT) store_val_x_all
+! write(IOUT) store_val_y_all
+! write(IOUT) store_val_z_all
+! write(IOUT) store_val_ux_all
+! write(IOUT) store_val_uy_all
+! write(IOUT) store_val_uz_all
+! close(IOUT)
+! endif
+
end subroutine iterate_time_movie_surface_output_obsolete
@@ -1041,71 +1200,142 @@
use specfem_par_movie
implicit none
+ integer :: imin,imax,jmin,jmax,kmin,kmax,iface,igll,iloc,ipoin
+ integer :: ispec,i,j,k,iglob
+! outputs values on free surface
ipoin = 0
- k = NGLLZ
-
-! save all points for high resolution, or only four corners for low resolution
- if(USE_HIGHRES_FOR_MOVIES) then
-
- do ispec2D = 1,NSPEC2D_TOP
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
-
-! loop on all the points inside the element
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool(i,j,k,ispec)
- store_val_x(ipoin) = xstore(iglob)
- store_val_y(ipoin) = ystore(iglob)
- store_val_z(ipoin) = zstore(iglob)
- store_val_norm_displ(ipoin) = max(store_val_norm_displ(ipoin),abs(displ(1,iglob)),abs(displ(2,iglob)))
- store_val_norm_veloc(ipoin) = max(store_val_norm_veloc(ipoin),abs(veloc(1,iglob)),abs(veloc(2,iglob)))
- store_val_norm_accel(ipoin) = max(store_val_norm_accel(ipoin),abs(accel(1,iglob)),abs(accel(2,iglob)))
- enddo
+ do iface=1,num_free_surface_faces
+ ispec = free_surface_ispec(iface)
+ ! save all points for high resolution, or only four corners for low resolution
+ if(USE_HIGHRES_FOR_MOVIES) then
+ do igll = 1, NGLLSQUARE
+ ipoin = ipoin + 1
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ ! todo: are we only interested in the absolute maximum of horizontal (E,N) components?
+ if( ispec_is_elastic( ispec) ) then
+ ! horizontal displacement
+ store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),abs(displ(1,iglob)),abs(displ(2,iglob)))
+ ! horizontal velocity
+ store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),abs(veloc(1,iglob)),abs(veloc(2,iglob)))
+ ! horizontal acceleration
+ store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),abs(accel(1,iglob)),abs(accel(2,iglob)))
+ endif
+ enddo
+ else
+ imin = minval( free_surface_ijk(1,:,iface) )
+ imax = maxval( free_surface_ijk(1,:,iface) )
+ jmin = minval( free_surface_ijk(2,:,iface) )
+ jmax = maxval( free_surface_ijk(2,:,iface) )
+ kmin = minval( free_surface_ijk(3,:,iface) )
+ kmax = maxval( free_surface_ijk(3,:,iface) )
+ do iloc = 1, NGNOD2D
+ ipoin = ipoin + 1
+ ! corner points
+ if( imin == imax ) then
+ iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
+ else if( jmin == jmax ) then
+ iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
+ else
+ iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
+ endif
+ ! coordinates
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ ! todo: are we only interested in the absolute maximum of horizontal (E,N) components?
+ if( ispec_is_elastic( ispec) ) then
+ store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),abs(displ(1,iglob)),abs(displ(2,iglob)))
+ store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),abs(veloc(1,iglob)),abs(veloc(2,iglob)))
+ store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),abs(accel(1,iglob)),abs(accel(2,iglob)))
+ endif
enddo
- enddo
+ endif ! USE_HIGHRES_FOR_MOVIES
+ enddo
- else
- do ispec2D = 1,NSPEC2D_TOP
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
- do iloc = 1, NGNOD2D
- ipoin = ipoin + 1
- iglob = ibool(iorderi(iloc),iorderj(iloc),k,ispec)
- store_val_x(ipoin) = xstore(iglob)
- store_val_y(ipoin) = ystore(iglob)
- store_val_z(ipoin) = zstore(iglob)
- store_val_norm_displ(ipoin) = max(store_val_norm_displ(ipoin),abs(displ(1,iglob)),abs(displ(2,iglob)))
- store_val_norm_veloc(ipoin) = max(store_val_norm_veloc(ipoin),abs(veloc(1,iglob)),abs(veloc(2,iglob)))
- store_val_norm_accel(ipoin) = max(store_val_norm_accel(ipoin),abs(accel(1,iglob)),abs(accel(2,iglob)))
- enddo
- enddo
- endif ! USE_HIGHRES_FOR_MOVIES
-
! save shakemap only at the end of the simulation
if(it == NSTEP) then
- ispec = nmovie_points
- call gather_all_cr(store_val_x,ispec,store_val_x_all,ispec,NPROC)
- call gather_all_cr(store_val_y,ispec,store_val_y_all,ispec,NPROC)
- call gather_all_cr(store_val_z,ispec,store_val_z_all,ispec,NPROC)
- call gather_all_cr(store_val_norm_displ,ispec,store_val_ux_all,ispec,NPROC)
- call gather_all_cr(store_val_norm_veloc,ispec,store_val_uy_all,ispec,NPROC)
- call gather_all_cr(store_val_norm_accel,ispec,store_val_uz_all,ispec,NPROC)
+ if (USE_HIGHRES_FOR_MOVIES) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ else
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
-! save movie data to disk in home directory
+! creates shakemap file
if(myrank == 0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
- write(IOUT) store_val_x_all
- write(IOUT) store_val_y_all
- write(IOUT) store_val_z_all
-! this saves norm of displacement, velocity and acceleration
-! but we use the same ux, uy, uz arrays as for the movies to save memory
- write(IOUT) store_val_ux_all
- write(IOUT) store_val_uy_all
- write(IOUT) store_val_uz_all
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata_freesurface',status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all_external_mesh ! x coordinates
+ write(IOUT) store_val_y_all_external_mesh ! y coordinates
+ write(IOUT) store_val_z_all_external_mesh ! z coordinates
+ write(IOUT) store_val_ux_all_external_mesh ! norm of displacement vector
+ write(IOUT) store_val_uy_all_external_mesh ! norm of velocity vector
+ write(IOUT) store_val_uz_all_external_mesh ! norm of acceleration vector
close(IOUT)
endif
+! obsolete...
+! ispec = nmovie_points
+! call gather_all_cr(store_val_x,ispec,store_val_x_all,ispec,NPROC)
+! call gather_all_cr(store_val_y,ispec,store_val_y_all,ispec,NPROC)
+! call gather_all_cr(store_val_z,ispec,store_val_z_all,ispec,NPROC)
+! call gather_all_cr(store_val_norm_displ,ispec,store_val_ux_all,ispec,NPROC)
+! call gather_all_cr(store_val_norm_veloc,ispec,store_val_uy_all,ispec,NPROC)
+! call gather_all_cr(store_val_norm_accel,ispec,store_val_uz_all,ispec,NPROC)
+!
+!! save movie data to disk in home directory
+! if(myrank == 0) then
+! open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
+! write(IOUT) store_val_x_all
+! write(IOUT) store_val_y_all
+! write(IOUT) store_val_z_all
+!! this saves norm of displacement, velocity and acceleration
+!! but we use the same ux, uy, uz arrays as for the movies to save memory
+! write(IOUT) store_val_ux_all
+! write(IOUT) store_val_uy_all
+! write(IOUT) store_val_uz_all
+! close(IOUT)
+! endif
+!
endif ! NTSTEP
end subroutine iterate_time_create_shakemap_obsolete
@@ -1123,7 +1353,10 @@
implicit none
+ integer :: ispec,i,j,k,l,iglob
+
! save velocity here to avoid static offset on displacement for movies
+ if( .not. ELASTIC_SIMULATION ) return
! save full snapshot data to local disk
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/lagrange_poly.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/lagrange_poly.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/lagrange_poly.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -30,35 +30,36 @@
implicit none
- integer NGLL
- double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)
+ integer, intent(in) :: NGLL
+ double precision, intent(in) :: xi,xigll(NGLL)
+ double precision, intent(out) :: h(NGLL),hprime(NGLL)
integer dgr,i,j
double precision prod1,prod2
do dgr=1,NGLL
- prod1 = 1.0d0
- prod2 = 1.0d0
- do i=1,NGLL
- if(i /= dgr) then
- prod1 = prod1*(xi-xigll(i))
- prod2 = prod2*(xigll(dgr)-xigll(i))
- endif
- enddo
- h(dgr)=prod1/prod2
+ prod1 = 1.0d0
+ prod2 = 1.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1 = prod1*(xi-xigll(i))
+ prod2 = prod2*(xigll(dgr)-xigll(i))
+ endif
+ enddo
+ h(dgr)=prod1/prod2
- hprime(dgr)=0.0d0
- do i=1,NGLL
- if(i /= dgr) then
- prod1=1.0d0
- do j=1,NGLL
- if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
- enddo
- hprime(dgr) = hprime(dgr)+prod1
- endif
- enddo
- hprime(dgr) = hprime(dgr)/prod2
+ hprime(dgr)=0.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1=1.0d0
+ do j=1,NGLL
+ if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
+ enddo
+ hprime(dgr) = hprime(dgr)+prod1
+ endif
+ enddo
+ hprime(dgr) = hprime(dgr)/prod2
enddo
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/locate_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/locate_receivers.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/locate_receivers.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -122,7 +122,7 @@
double precision, allocatable, dimension(:,:) :: xi_receiver_all,eta_receiver_all,gamma_receiver_all
double precision, allocatable, dimension(:,:,:,:) :: nu_all
- character(len=150) OUTPUT_FILES
+ character(len=256) OUTPUT_FILES
! **************
@@ -227,7 +227,7 @@
x_target(irec) = stutm_x(irec)
y_target(irec) = stutm_y(irec)
z_target(irec) = stbur(irec)
- if (myrank == 0) write(IOVTK,*) x_target(irec), y_target(irec), z_target(irec)
+ !if (myrank == 0) write(IOVTK,*) x_target(irec), y_target(irec), z_target(irec)
@@ -286,12 +286,12 @@
iy_initial_guess(irec) = j
iz_initial_guess(irec) = k
- xi_receiver(irec) = dble(ix_initial_guess(irec))
- eta_receiver(irec) = dble(iy_initial_guess(irec))
- gamma_receiver(irec) = dble(iz_initial_guess(irec))
- x_found(irec) = xstore(iglob)
- y_found(irec) = ystore(iglob)
- z_found(irec) = zstore(iglob)
+ xi_receiver(irec) = dble(ix_initial_guess(irec))
+ eta_receiver(irec) = dble(iy_initial_guess(irec))
+ gamma_receiver(irec) = dble(iz_initial_guess(irec))
+ x_found(irec) = xstore(iglob)
+ y_found(irec) = ystore(iglob)
+ z_found(irec) = zstore(iglob)
endif
enddo
@@ -488,104 +488,104 @@
! define coordinates of the control points of the element
- do ia=1,NGNOD
+ do ia=1,NGNOD
- if(iaddx(ia) == 0) then
- iax = 1
- else if(iaddx(ia) == 1) then
- iax = (NGLLX+1)/2
- else if(iaddx(ia) == 2) then
- iax = NGLLX
- else
- call exit_MPI(myrank,'incorrect value of iaddx')
- endif
+ if(iaddx(ia) == 0) then
+ iax = 1
+ else if(iaddx(ia) == 1) then
+ iax = (NGLLX+1)/2
+ else if(iaddx(ia) == 2) then
+ iax = NGLLX
+ else
+ call exit_MPI(myrank,'incorrect value of iaddx')
+ endif
- if(iaddy(ia) == 0) then
- iay = 1
- else if(iaddy(ia) == 1) then
- iay = (NGLLY+1)/2
- else if(iaddy(ia) == 2) then
- iay = NGLLY
- else
- call exit_MPI(myrank,'incorrect value of iaddy')
- endif
+ if(iaddy(ia) == 0) then
+ iay = 1
+ else if(iaddy(ia) == 1) then
+ iay = (NGLLY+1)/2
+ else if(iaddy(ia) == 2) then
+ iay = NGLLY
+ else
+ call exit_MPI(myrank,'incorrect value of iaddy')
+ endif
- if(iaddz(ia) == 0) then
- iaz = 1
- else if(iaddz(ia) == 1) then
- iaz = (NGLLZ+1)/2
- else if(iaddz(ia) == 2) then
- iaz = NGLLZ
- else
- call exit_MPI(myrank,'incorrect value of iaddz')
- endif
+ if(iaddz(ia) == 0) then
+ iaz = 1
+ else if(iaddz(ia) == 1) then
+ iaz = (NGLLZ+1)/2
+ else if(iaddz(ia) == 2) then
+ iaz = NGLLZ
+ else
+ call exit_MPI(myrank,'incorrect value of iaddz')
+ endif
- iglob = ibool(iax,iay,iaz,ispec_iterate)
- xelm(ia) = dble(xstore(iglob))
- yelm(ia) = dble(ystore(iglob))
- zelm(ia) = dble(zstore(iglob))
+ iglob = ibool(iax,iay,iaz,ispec_iterate)
+ xelm(ia) = dble(xstore(iglob))
+ yelm(ia) = dble(ystore(iglob))
+ zelm(ia) = dble(zstore(iglob))
- enddo
+ enddo
! iterate to solve the non linear system
- do iter_loop = 1,NUM_ITER
+ do iter_loop = 1,NUM_ITER
! impose receiver exactly at the surface
! gamma = 1.d0
! recompute jacobian for the new point
- call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
! compute distance to target location
- dx = - (x - x_target(irec))
- dy = - (y - y_target(irec))
- dz = - (z - z_target(irec))
+ dx = - (x - x_target(irec))
+ dy = - (y - y_target(irec))
+ dz = - (z - z_target(irec))
! compute increments
! gamma does not change since we know the receiver is exactly on the surface
- dxi = xix*dx + xiy*dy + xiz*dz
- deta = etax*dx + etay*dy + etaz*dz
- dgamma = gammax*dx + gammay*dy + gammaz*dz
+ dxi = xix*dx + xiy*dy + xiz*dz
+ deta = etax*dx + etay*dy + etaz*dz
+ dgamma = gammax*dx + gammay*dy + gammaz*dz
! update values
- xi = xi + dxi
- eta = eta + deta
- gamma = gamma + dgamma
+ xi = xi + dxi
+ eta = eta + deta
+ gamma = gamma + dgamma
! impose that we stay in that element
! (useful if user gives a receiver outside the mesh for instance)
! we can go slightly outside the [1,1] segment since with finite elements
! the polynomial solution is defined everywhere
! this can be useful for convergence of itertive scheme with distorted elements
- if (xi > 1.10d0) xi = 1.10d0
- if (xi < -1.10d0) xi = -1.10d0
- if (eta > 1.10d0) eta = 1.10d0
- if (eta < -1.10d0) eta = -1.10d0
- if (gamma > 1.10d0) gamma = 1.10d0
- if (gamma < -1.10d0) gamma = -1.10d0
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (eta > 1.10d0) eta = 1.10d0
+ if (eta < -1.10d0) eta = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
! end of non linear iterations
- enddo
+ enddo
! impose receiver exactly at the surface after final iteration
! gamma = 1.d0
! compute final coordinates of point found
- call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
! store xi,eta and x,y,z of point found
- xi_receiver(irec) = xi
- eta_receiver(irec) = eta
- gamma_receiver(irec) = gamma
- x_found(irec) = x
- y_found(irec) = y
- z_found(irec) = z
+ xi_receiver(irec) = xi
+ eta_receiver(irec) = eta
+ gamma_receiver(irec) = gamma
+ x_found(irec) = x
+ y_found(irec) = y
+ z_found(irec) = z
! compute final distance between asked and found (converted to km)
- final_distance(irec) = dsqrt((x_target(irec)-x_found(irec))**2 + &
- (y_target(irec)-y_found(irec))**2 + (z_target(irec)-z_found(irec))**2)
+ final_distance(irec) = dsqrt((x_target(irec)-x_found(irec))**2 + &
+ (y_target(irec)-y_found(irec))**2 + (z_target(irec)-z_found(irec))**2)
enddo
@@ -610,67 +610,67 @@
if(myrank == 0) then
! check that the gather operation went well
- if(any(ispec_selected_rec_all(:,:) == -1)) call exit_MPI(myrank,'gather operation failed for receivers')
+ if(any(ispec_selected_rec_all(:,:) == -1)) call exit_MPI(myrank,'gather operation failed for receivers')
! MPI loop on all the results to determine the best slice
- islice_selected_rec(:) = -1
- do irec = 1,nrec
- distmin = HUGEVAL
- do iprocloop = 0,NPROC-1
- if(final_distance_all(irec,iprocloop) < distmin) then
- distmin = final_distance_all(irec,iprocloop)
- islice_selected_rec(irec) = iprocloop
- ispec_selected_rec(irec) = ispec_selected_rec_all(irec,iprocloop)
- xi_receiver(irec) = xi_receiver_all(irec,iprocloop)
- eta_receiver(irec) = eta_receiver_all(irec,iprocloop)
- gamma_receiver(irec) = gamma_receiver_all(irec,iprocloop)
- x_found(irec) = x_found_all(irec,iprocloop)
- y_found(irec) = y_found_all(irec,iprocloop)
- z_found(irec) = z_found_all(irec,iprocloop)
- nu(:,:,irec) = nu_all(:,:,irec,iprocloop)
- endif
- enddo
- final_distance(irec) = distmin
- enddo
+ islice_selected_rec(:) = -1
+ do irec = 1,nrec
+ distmin = HUGEVAL
+ do iprocloop = 0,NPROC-1
+ if(final_distance_all(irec,iprocloop) < distmin) then
+ distmin = final_distance_all(irec,iprocloop)
+ islice_selected_rec(irec) = iprocloop
+ ispec_selected_rec(irec) = ispec_selected_rec_all(irec,iprocloop)
+ xi_receiver(irec) = xi_receiver_all(irec,iprocloop)
+ eta_receiver(irec) = eta_receiver_all(irec,iprocloop)
+ gamma_receiver(irec) = gamma_receiver_all(irec,iprocloop)
+ x_found(irec) = x_found_all(irec,iprocloop)
+ y_found(irec) = y_found_all(irec,iprocloop)
+ z_found(irec) = z_found_all(irec,iprocloop)
+ nu(:,:,irec) = nu_all(:,:,irec,iprocloop)
+ endif
+ enddo
+ final_distance(irec) = distmin
+ enddo
- do irec=1,nrec
+ do irec=1,nrec
- write(IMAIN,*)
- write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec)
+ write(IMAIN,*)
+ write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec)
- if(final_distance(irec) == HUGEVAL) call exit_MPI(myrank,'error locating receiver')
+ if(final_distance(irec) == HUGEVAL) call exit_MPI(myrank,'error locating receiver')
- write(IMAIN,*) ' original latitude: ',sngl(stlat(irec))
- write(IMAIN,*) ' original longitude: ',sngl(stlon(irec))
- write(IMAIN,*) ' original UTM x: ',sngl(stutm_x(irec))
- write(IMAIN,*) ' original UTM y: ',sngl(stutm_y(irec))
- write(IMAIN,*) ' horizontal distance: ',sngl(horiz_dist(irec))
- if(TOPOGRAPHY) write(IMAIN,*) ' topography elevation: ',sngl(elevation(irec))
- write(IMAIN,*) ' target x, y, z: ',sngl(x_target(irec)),sngl(y_target(irec)),sngl(z_target(irec))
+ write(IMAIN,*) ' original latitude: ',sngl(stlat(irec))
+ write(IMAIN,*) ' original longitude: ',sngl(stlon(irec))
+ write(IMAIN,*) ' original UTM x: ',sngl(stutm_x(irec))
+ write(IMAIN,*) ' original UTM y: ',sngl(stutm_y(irec))
+ write(IMAIN,*) ' horizontal distance: ',sngl(horiz_dist(irec))
+ if(TOPOGRAPHY) write(IMAIN,*) ' topography elevation: ',sngl(elevation(irec))
+ write(IMAIN,*) ' target x, y, z: ',sngl(x_target(irec)),sngl(y_target(irec)),sngl(z_target(irec))
- write(IMAIN,*) 'closest estimate found: ',sngl(final_distance(irec)),' m away'
- write(IMAIN,*) ' in slice ',islice_selected_rec(irec),' in element ',ispec_selected_rec(irec)
- if(FASTER_RECEIVERS_POINTS_ONLY) then
- write(IMAIN,*) 'in point i,j,k = ',nint(xi_receiver(irec)),nint(eta_receiver(irec)),nint(gamma_receiver(irec))
- !write(IMAIN,*) 'in point i,j,k = ',x_found(irec),y_found(irec),z_found(irec)
- write(IMAIN,*) 'nu1 = ',nu(1,:,irec)
- write(IMAIN,*) 'nu2 = ',nu(2,:,irec)
- write(IMAIN,*) 'nu3 = ',nu(3,:,irec)
- else
- write(IMAIN,*) ' at xi,eta,gamma coordinates = ',xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec)
- endif
+ write(IMAIN,*) 'closest estimate found: ',sngl(final_distance(irec)),' m away'
+ write(IMAIN,*) ' in slice ',islice_selected_rec(irec),' in element ',ispec_selected_rec(irec)
+ if(FASTER_RECEIVERS_POINTS_ONLY) then
+ write(IMAIN,*) 'in point i,j,k = ',nint(xi_receiver(irec)),nint(eta_receiver(irec)),nint(gamma_receiver(irec))
+ !write(IMAIN,*) 'in point i,j,k = ',x_found(irec),y_found(irec),z_found(irec)
+ write(IMAIN,*) 'nu1 = ',nu(1,:,irec)
+ write(IMAIN,*) 'nu2 = ',nu(2,:,irec)
+ write(IMAIN,*) 'nu3 = ',nu(3,:,irec)
+ else
+ write(IMAIN,*) ' at xi,eta,gamma coordinates = ',xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec)
+ endif
! add warning if estimate is poor
! (usually means receiver outside the mesh given by the user)
- if(final_distance(irec) > 3000.d0) then
- write(IMAIN,*) '*******************************************************'
- write(IMAIN,*) '***** WARNING: receiver location estimate is poor *****'
- write(IMAIN,*) '*******************************************************'
- endif
+ if(final_distance(irec) > 3000.d0) then
+ write(IMAIN,*) '*******************************************************'
+ write(IMAIN,*) '***** WARNING: receiver location estimate is poor *****'
+ write(IMAIN,*) '*******************************************************'
+ endif
- write(IMAIN,*)
+ write(IMAIN,*)
- enddo
+ enddo
! compute maximal distance for all the receivers
final_distance_max = maxval(final_distance(:))
@@ -690,22 +690,22 @@
endif
! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
! write the list of stations and associated epicentral distance
- open(unit=27,file=trim(OUTPUT_FILES)//'/output_list_stations.txt',status='unknown')
- do irec=1,nrec
- write(27,*) station_name(irec),'.',network_name(irec),' : ',horiz_dist(irec),' km horizontal distance'
- enddo
- close(27)
+ open(unit=27,file=trim(OUTPUT_FILES)//'/output_list_stations.txt',status='unknown')
+ do irec=1,nrec
+ write(27,*) station_name(irec),'.',network_name(irec),' : ',horiz_dist(irec),' km horizontal distance'
+ enddo
+ close(27)
! elapsed time since beginning of mesh generation
- tCPU = wtime() - time_start
- write(IMAIN,*)
- write(IMAIN,*) 'Elapsed time for receiver detection in seconds = ',tCPU
- write(IMAIN,*)
- write(IMAIN,*) 'End of receiver detection - done'
- write(IMAIN,*)
+ tCPU = wtime() - time_start
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for receiver detection in seconds = ',tCPU
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of receiver detection - done'
+ write(IMAIN,*)
endif ! end of section executed by main process only
@@ -769,7 +769,7 @@
double precision stlat,stlon,stele,stbur
character(len=MAX_LENGTH_STATION_NAME) station_name
character(len=MAX_LENGTH_NETWORK_NAME) network_name
- character(len=150) dummystring
+ character(len=256) dummystring
nrec = 0
nrec_filtered = 0
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -35,8 +35,8 @@
xi_source,eta_source,gamma_source, &
TOPOGRAPHY,UTM_PROJECTION_ZONE, &
PRINT_SOURCE_TIME_FUNCTION, &
- nu_source,iglob_is_surface_external_mesh,ispec_is_surface_external_mesh &
- )
+ nu_source,iglob_is_surface_external_mesh,ispec_is_surface_external_mesh, &
+ ispec_is_acoustic,ispec_is_elastic)
implicit none
@@ -56,6 +56,8 @@
! arrays containing coordinates of the points
real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: xstore,ystore,zstore
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic,ispec_is_elastic
+
integer yr,jda,ho,mi
double precision t_cmt(NSOURCES)
@@ -121,7 +123,7 @@
double precision, dimension(NSOURCES) :: lat,long,depth,elevation
double precision moment_tensor(6,NSOURCES)
- character(len=150) OUTPUT_FILES,plot_file
+ character(len=256) OUTPUT_FILES,plot_file
double precision, dimension(NSOURCES) :: x_found_source,y_found_source,z_found_source
double precision distmin
@@ -142,6 +144,10 @@
double precision time_source
double precision, external :: comp_source_time_function
+ integer, dimension(NSOURCES) :: idomain
+ integer, dimension(NGATHER_SOURCES,0:NPROC-1) :: idomain_all
+
+
! **************
! get the base pathname for output files
@@ -206,7 +212,7 @@
x_target_source = utm_x_source(isource)
y_target_source = utm_y_source(isource)
z_target_source = depth(isource)
- if (myrank == 0) write(IOVTK,*) x_target_source, y_target_source, z_target_source
+! if (myrank == 0) write(IOVTK,*) x_target_source, y_target_source, z_target_source
! set distance to huge initial value
@@ -289,6 +295,15 @@
final_distance_source(isource) = HUGEVAL
endif
+ ! sets whether acoustic (1) or elastic (2)
+ if( ispec_is_acoustic( ispec_selected_source(isource) ) ) then
+ idomain(isource) = 1
+ else if( ispec_is_elastic( ispec_selected_source(isource) ) ) then
+ idomain(isource) = 2
+ else
+ idomain(isource) = 0
+ endif
+
! get normal to the face of the hexaedra if receiver is on the surface
if ((.not. SOURCES_CAN_BE_BURIED_EXT_MESH) .and. &
.not. (ispec_selected_source(isource) == 0)) then
@@ -516,6 +531,7 @@
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
! store xi,eta,gamma and x,y,z of point found
+! note: xi/eta/gamma will be in range [-1,1]
xi_source(isource) = xi
eta_source(isource) = eta
gamma_source(isource) = gamma
@@ -548,6 +564,12 @@
tmp_i_local(:) = ispec_selected_source(ns:ne)
call gather_all_i(tmp_i_local,ng,tmp_i_all_local,ng,NPROC)
ispec_selected_source_all(1:ng,:) = tmp_i_all_local(:,:)
+
+ ! acoustic/elastic domain
+ tmp_i_local(:) = idomain(ns:ne)
+ call gather_all_i(tmp_i_local,ng,tmp_i_all_local,ng,NPROC)
+ idomain_all(1:ng,:) = tmp_i_all_local(:,:)
+
deallocate(tmp_i_local,tmp_i_all_local)
! avoids warnings about temporary creations of arrays for function call by compiler
@@ -622,13 +644,14 @@
y_found_source(isource) = y_found_source_all(is,iprocloop)
z_found_source(isource) = z_found_source_all(is,iprocloop)
nu_source(:,:,isource) = nu_source_all(:,:,isource,iprocloop)
+ idomain(isource) = idomain_all(is,iprocloop)
endif
enddo
final_distance_source(isource) = distmin
enddo
endif !myrank
- enddo
+ enddo ! ngather
if (myrank == 0) then
@@ -643,11 +666,19 @@
write(IMAIN,*)
write(IMAIN,*) 'source located in slice ',islice_selected_source(isource)
write(IMAIN,*) ' in element ',ispec_selected_source(isource)
+ if( idomain(isource) == 1 ) then
+ write(IMAIN,*) ' in acoustic domain'
+ else if( idomain(isource) == 2 ) then
+ write(IMAIN,*) ' in elastic domain'
+ else
+ write(IMAIN,*) ' in unknown domain'
+ endif
+
write(IMAIN,*)
if(USE_FORCE_POINT_SOURCE) then
- write(IMAIN,*) ' xi coordinate of source in that element: ',nint(xi_source(isource))
+ write(IMAIN,*) ' xi coordinate of source in that element: ',nint(xi_source(isource))
write(IMAIN,*) ' eta coordinate of source in that element: ',nint(eta_source(isource))
- write(IMAIN,*) 'gamma coordinate of source in that element: ',nint(gamma_source(isource))
+ write(IMAIN,*) ' gamma coordinate of source in that element: ',nint(gamma_source(isource))
write(IMAIN,*) 'nu1 = ',nu_source(1,:,isource)
write(IMAIN,*) 'nu2 = ',nu_source(2,:,isource)
write(IMAIN,*) 'nu3 = ',nu_source(3,:,isource)
@@ -729,6 +760,21 @@
endif
+ ! checks CMTSOLUTION format for acoustic case
+ if( idomain(isource) == 1 ) then
+ if( Mxx(isource) /= Myy(isource) .or. Myy(isource) /= Mzz(isource) .or. &
+ Mxy(isource) > TINYVAL .or. Mxz(isource) > TINYVAL .or. Myz(isource) > TINYVAL ) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' error CMTSOLUTION format for acoustic source:'
+ write(IMAIN,*) ' acoustic source needs explosive moment tensor with'
+ write(IMAIN,*) ' Mrr = Mtt = Mpp '
+ write(IMAIN,*) ' and '
+ write(IMAIN,*) ' Mrt = Mrp = Mtp = zero'
+ write(IMAIN,*)
+ call exit_mpi(myrank,'error acoustic source')
+ endif
+ endif
+
! end of loop on all the sources
enddo
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -115,7 +115,7 @@
+ 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
+! memory usage, in create_regions_mesh_ext() routine requested approximately
static_memory_size_request = &
+ 3*NGNOD*8 + NGLLX*NGLLY*NGLLZ*nspec*4 + 6*nspec*1 + 6*NGLLX*8 &
+ NGNOD*NGLLX*NGLLY*NGLLZ*8 + NDIM*NGNOD*NGLLX*NGLLY*NGLLZ*8 &
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/meshfem3D/save_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/meshfem3D/save_databases.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/meshfem3D/save_databases.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -87,7 +87,9 @@
write(15,*) maxval(idoubling), 0
do idoubl = 1,maxval(idoubling)
call socal_model(idoubl,rho,vp,vs,iattenuation)
- write(15,*) rho,vp,vs,iattenuation,0.d0
+ !write(15,*) rho,vp,vs,iattenuation,0.d0
+ ! assumes material id for elastic domain
+ write(15,*) rho,vp,vs,iattenuation,0.d0,2
end do
! write(15,*) 1,0
! write(15,*) 1100.d0,300.d0,200.d0,0.d0,0.d0
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -455,6 +455,25 @@
!----
!
+ subroutine any_all_l(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ logical sendbuf, recvbuf
+ integer ier
+
+ call MPI_ALLREDUCE(sendbuf,recvbuf,1,MPI_LOGICAL, &
+ MPI_LOR,MPI_COMM_WORLD,ier)
+
+ end subroutine any_all_l
+
+!
+!----
+!
+
subroutine sendrecv_all_cr(sendbuf, sendcount, dest, sendtag, &
recvbuf, recvcount, source, recvtag)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/prepare_assemble_MPI.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/prepare_assemble_MPI.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/prepare_assemble_MPI.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -24,36 +24,45 @@
!=====================================================================
- subroutine prepare_assemble_MPI (nelmnts,ibool, &
- knods, ngnode, &
- npoin, &
+ subroutine prepare_assemble_MPI (nelmnts,knods, &
+ ibool,npoin,ngnode, &
ninterface, max_interface_size, &
my_nelmnts_neighbours, my_interfaces, &
ibool_interfaces_asteroid, &
- nibool_interfaces_asteroid &
- )
+ nibool_interfaces_asteroid )
-! returns ibool_interfaces_asteroid with the global indices (as defined in ibool) &
-! returns nibool_interfaces_asteroid with the number of points in ibool_interfaces_asteroid
-! for all points on the (surface) interface defined by knods, ninterface,my_nelmnts_neighbours and my_interfaces
+! returns: ibool_interfaces_asteroid with the global indices (as defined in ibool)
+! nibool_interfaces_asteroid with the number of points in ibool_interfaces_asteroid
+!
+! for all points on the interface defined by ninterface, my_nelmnts_neighbours and my_interfaces
implicit none
include 'constants.h'
- integer, intent(in) :: nelmnts, npoin, ngnode
+! spectral element indexing
+! ( nelmnts = number of spectral elements
+! ngnode = number of element corners (8)
+! knods = corner indices array )
+ integer, intent(in) :: nelmnts,ngnode
integer, dimension(ngnode,nelmnts), intent(in) :: knods
+
+! global number of points
+ integer, intent(in) :: npoin
+
+! global indexing
integer, dimension(NGLLX,NGLLY,NGLLZ,nelmnts), intent(in) :: ibool
+! MPI interfaces
integer :: ninterface
integer :: max_interface_size
integer, dimension(ninterface) :: my_nelmnts_neighbours
integer, dimension(6,max_interface_size,ninterface) :: my_interfaces
- integer, dimension(NGLLX*NGLLX*max_interface_size,ninterface) :: &
- ibool_interfaces_asteroid
- integer, dimension(ninterface) :: &
- nibool_interfaces_asteroid
+
+ integer, dimension(NGLLX*NGLLX*max_interface_size,ninterface) :: ibool_interfaces_asteroid
+ integer, dimension(ninterface) :: nibool_interfaces_asteroid
+! local parameters
integer :: num_interface
integer :: ispec_interface
@@ -72,47 +81,58 @@
integer :: ix,iy,iz,ier
+! initializes
allocate( mask_ibool_asteroid(npoin), stat=ier); if( ier /= 0) stop 'error allocating array'
ibool_interfaces_asteroid(:,:) = 0
nibool_interfaces_asteroid(:) = 0
+! loops over MPI interfaces
do num_interface = 1, ninterface
- npoin_interface_asteroid = 0
- mask_ibool_asteroid(:) = .false.
+ npoin_interface_asteroid = 0
+ mask_ibool_asteroid(:) = .false.
- do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
- ! element with an interface
- ispec = my_interfaces(1,ispec_interface,num_interface)
- ! type of interface
- type = my_interfaces(2,ispec_interface,num_interface)
- ! nodes of face/edge
- do k = 1, ngnode
- n(k) = knods(k,ispec)
- end do
- e1 = my_interfaces(3,ispec_interface,num_interface)
- e2 = my_interfaces(4,ispec_interface,num_interface)
- e3 = my_interfaces(5,ispec_interface,num_interface)
- e4 = my_interfaces(6,ispec_interface,num_interface)
- call get_edge(ngnode, n, type, e1, e2, e3, e4, ixmin, ixmax, iymin, iymax, izmin, izmax)
+ ! loops over number of elements on interface
+ do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
+ ! spectral element on interface
+ ispec = my_interfaces(1,ispec_interface,num_interface)
+ ! type of interface: (1) corner point, (2) edge, (4) face
+ type = my_interfaces(2,ispec_interface,num_interface)
+ ! gets spectral element corner indices (defines all nodes of face/edge)
+ do k = 1, ngnode
+ n(k) = knods(k,ispec)
+ end do
- do iz = min(izmin,izmax), max(izmin,izmax)
- do iy = min(iymin,iymax), max(iymin,iymax)
- do ix = min(ixmin,ixmax), max(ixmin,ixmax)
+ ! interface node ids
+ e1 = my_interfaces(3,ispec_interface,num_interface)
+ e2 = my_interfaces(4,ispec_interface,num_interface)
+ e3 = my_interfaces(5,ispec_interface,num_interface)
+ e4 = my_interfaces(6,ispec_interface,num_interface)
- if(.not. mask_ibool_asteroid(ibool(ix,iy,iz,ispec))) then
- mask_ibool_asteroid(ibool(ix,iy,iz,ispec)) = .true.
- npoin_interface_asteroid = npoin_interface_asteroid + 1
- ibool_interfaces_asteroid(npoin_interface_asteroid,num_interface)=&
- ibool(ix,iy,iz,ispec)
- end if
- end do
- end do
+ ! gets i,j,k ranges for interface type
+ call get_edge(ngnode, n, type, e1, e2, e3, e4, ixmin, ixmax, iymin, iymax, izmin, izmax)
+
+ ! counts number and stores indices of (global) points on MPI interface
+ do iz = min(izmin,izmax), max(izmin,izmax)
+ do iy = min(iymin,iymax), max(iymin,iymax)
+ do ix = min(ixmin,ixmax), max(ixmin,ixmax)
+ ! stores global index of point on interface
+ if(.not. mask_ibool_asteroid(ibool(ix,iy,iz,ispec))) then
+ ! masks point as being accounted for
+ mask_ibool_asteroid(ibool(ix,iy,iz,ispec)) = .true.
+ ! adds point to interface
+ npoin_interface_asteroid = npoin_interface_asteroid + 1
+ ibool_interfaces_asteroid(npoin_interface_asteroid,num_interface) = &
+ ibool(ix,iy,iz,ispec)
+ end if
+ end do
end do
+ end do
- end do
- nibool_interfaces_asteroid(num_interface) = npoin_interface_asteroid
+ end do
+ ! stores total number of (global) points on this MPI interface
+ nibool_interfaces_asteroid(num_interface) = npoin_interface_asteroid
end do
@@ -126,404 +146,426 @@
subroutine get_edge ( ngnode, n, type, e1, e2, e3, e4, ixmin, ixmax, iymin, iymax, izmin, izmax )
+! returns range of local (GLL) point indices i,j,k depending on given type for corner point (1), edge (2) or face (4)
+
implicit none
include "constants.h"
+! corner node indices per spectral element (8)
integer, intent(in) :: ngnode
integer, dimension(ngnode), intent(in) :: n
+
+! interface type & nodes
integer, intent(in) :: type, e1, e2, e3, e4
+
+! local (GLL) i,j,k index ranges
integer, intent(out) :: ixmin, ixmax, iymin, iymax, izmin, izmax
+! local parameters
integer, dimension(4) :: en
integer :: valence, i
- if ( type == 1 ) then
- if ( e1 == n(1) ) then
- ixmin = 1
- ixmax = 1
- iymin = 1
- iymax = 1
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- iymin = 1
- iymax = 1
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- iymin = NGLLY
- iymax = NGLLY
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(4) ) then
- ixmin = 1
- ixmax = 1
- iymin = NGLLY
- iymax = NGLLY
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(5) ) then
- ixmin = 1
- ixmax = 1
- iymin = 1
- iymax = 1
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- if ( e1 == n(6) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- iymin = 1
- iymax = 1
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- if ( e1 == n(7) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- iymin = NGLLY
- iymax = NGLLY
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- if ( e1 == n(8) ) then
- ixmin = 1
- ixmax = 1
- iymin = NGLLY
- iymax = NGLLY
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- else
- if ( type == 2 ) then
- if ( e1 == n(1) ) then
- ixmin = 1
- iymin = 1
- izmin = 1
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(4) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(5) ) then
- ixmax = 1
- iymax = 1
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- iymin = 1
- izmin = 1
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(1) ) then
- ixmax = 1
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(6) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = NGLLZ
- end if
+! determines local indexes for corners/edges/faces
+ if ( type == 1 ) then
- end if
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- iymin = NGLLY
- izmin = 1
- if ( e2 == n(4) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(7) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(4) ) then
- ixmin = 1
- iymin = NGLLY
- izmin = 1
- if ( e2 == n(1) ) then
- ixmax = 1
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(8) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(5) ) then
- ixmin = 1
- iymin = 1
- izmin = NGLLZ
- if ( e2 == n(1) ) then
- ixmax = 1
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(6) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = NGLLZ
- end if
- if ( e2 == n(8) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(6) ) then
- ixmin = NGLLX
- iymin = 1
- izmin = NGLLZ
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(7) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = NGLLZ
- end if
- if ( e2 == n(5) ) then
- ixmax = 1
- iymax = 1
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(7) ) then
- ixmin = NGLLX
- iymin = NGLLY
- izmin = NGLLZ
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(8) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = NGLLZ
- end if
- if ( e2 == n(6) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(8) ) then
- ixmin = 1
- iymin = NGLLY
- izmin = NGLLZ
- if ( e2 == n(4) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(5) ) then
- ixmax = 1
- iymax = 1
- izmax = NGLLZ
- end if
- if ( e2 == n(7) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = NGLLZ
- end if
- end if
+! corner point
+
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ ixmax = 1
+ iymin = 1
+ iymax = 1
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ iymin = 1
+ iymax = 1
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ iymin = NGLLY
+ iymax = NGLLY
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ ixmax = 1
+ iymin = NGLLY
+ iymax = NGLLY
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(5) ) then
+ ixmin = 1
+ ixmax = 1
+ iymin = 1
+ iymax = 1
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ if ( e1 == n(6) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ iymin = 1
+ iymax = 1
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ if ( e1 == n(7) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ iymin = NGLLY
+ iymax = NGLLY
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ if ( e1 == n(8) ) then
+ ixmin = 1
+ ixmax = 1
+ iymin = NGLLY
+ iymax = NGLLY
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
- else
- if (type == 4) then
- en(1) = e1
- en(2) = e2
- en(3) = e3
- en(4) = e4
+ else if ( type == 2 ) then
- valence = 0
- do i = 1, 4
- if ( en(i) == n(1)) then
- valence = valence+1
- endif
- if ( en(i) == n(2)) then
- valence = valence+1
- endif
- if ( en(i) == n(3)) then
- valence = valence+1
- endif
- if ( en(i) == n(4)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = 1
- iymin = 1
- izmin = 1
- ixmax = NGLLX
- iymax = NGLLY
- izmax = 1
- endif
+! edges
- valence = 0
- do i = 1, 4
- if ( en(i) == n(1)) then
- valence = valence+1
- endif
- if ( en(i) == n(2)) then
- valence = valence+1
- endif
- if ( en(i) == n(5)) then
- valence = valence+1
- endif
- if ( en(i) == n(6)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = 1
- iymin = 1
- izmin = 1
- ixmax = NGLLX
- iymax = 1
- izmax = NGLLZ
- endif
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ iymin = 1
+ izmin = 1
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(5) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ iymin = 1
+ izmin = 1
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(6) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ iymin = NGLLY
+ izmin = 1
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(7) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ iymin = NGLLY
+ izmin = 1
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(8) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(5) ) then
+ ixmin = 1
+ iymin = 1
+ izmin = NGLLZ
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(6) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ if ( e2 == n(8) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(6) ) then
+ ixmin = NGLLX
+ iymin = 1
+ izmin = NGLLZ
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(7) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ if ( e2 == n(5) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(7) ) then
+ ixmin = NGLLX
+ iymin = NGLLY
+ izmin = NGLLZ
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(8) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ if ( e2 == n(6) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(8) ) then
+ ixmin = 1
+ iymin = NGLLY
+ izmin = NGLLZ
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(5) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ if ( e2 == n(7) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ end if
- valence = 0
- do i = 1, 4
- if ( en(i) == n(2)) then
- valence = valence+1
- endif
- if ( en(i) == n(3)) then
- valence = valence+1
- endif
- if ( en(i) == n(6)) then
- valence = valence+1
- endif
- if ( en(i) == n(7)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = NGLLX
- iymin = 1
- izmin = 1
- ixmax = NGLLX
- iymax = NGLLZ
- izmax = NGLLZ
- endif
+ else if (type == 4) then
- valence = 0
- do i = 1, 4
- if ( en(i) == n(3)) then
- valence = valence+1
- endif
- if ( en(i) == n(4)) then
- valence = valence+1
- endif
- if ( en(i) == n(7)) then
- valence = valence+1
- endif
- if ( en(i) == n(8)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = 1
- iymin = NGLLY
- izmin = 1
- ixmax = NGLLX
- iymax = NGLLY
- izmax = NGLLZ
- endif
+! face corners
- valence = 0
- do i = 1, 4
- if ( en(i) == n(1)) then
- valence = valence+1
- endif
- if ( en(i) == n(4)) then
- valence = valence+1
- endif
- if ( en(i) == n(5)) then
- valence = valence+1
- endif
- if ( en(i) == n(8)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = 1
- iymin = 1
- izmin = 1
- ixmax = 1
- iymax = NGLLY
- izmax = NGLLZ
- endif
+ en(1) = e1
+ en(2) = e2
+ en(3) = e3
+ en(4) = e4
- valence = 0
- do i = 1, 4
- if ( en(i) == n(5)) then
- valence = valence+1
- endif
- if ( en(i) == n(6)) then
- valence = valence+1
- endif
- if ( en(i) == n(7)) then
- valence = valence+1
- endif
- if ( en(i) == n(8)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = 1
- iymin = 1
- izmin = NGLLZ
- ixmax = NGLLX
- iymax = NGLLY
- izmax = NGLLZ
- endif
+ ! zmin face
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(1)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(2)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(3)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(4)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = 1
+ iymin = 1
+ izmin = 1
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = 1
+ endif
- else
- stop 'ERROR get_edge'
- endif
+ ! ymin face
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(1)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(2)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(5)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(6)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = 1
+ iymin = 1
+ izmin = 1
+ ixmax = NGLLX
+ iymax = 1
+ izmax = NGLLZ
+ endif
- end if
- end if
+ ! xmax face
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(2)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(3)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(6)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(7)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = NGLLX
+ iymin = 1
+ izmin = 1
+ ixmax = NGLLX
+ iymax = NGLLZ
+ izmax = NGLLZ
+ endif
+ ! ymax face
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(3)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(4)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(7)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(8)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = 1
+ iymin = NGLLY
+ izmin = 1
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = NGLLZ
+ endif
+
+ ! xmin face
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(1)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(4)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(5)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(8)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = 1
+ iymin = 1
+ izmin = 1
+ ixmax = 1
+ iymax = NGLLY
+ izmax = NGLLZ
+ endif
+
+ ! zmax face
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(5)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(6)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(7)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(8)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = 1
+ iymin = 1
+ izmin = NGLLZ
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = NGLLZ
+ endif
+
+ else
+ stop 'ERROR get_edge'
+ endif
+
+! end if
+! end if
+
end subroutine get_edge
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -28,10 +28,16 @@
subroutine prepare_timerun()
use specfem_par
+ use specfem_par_acoustic
use specfem_par_elastic
- use specfem_par_movie
-
+ use specfem_par_poroelastic
implicit none
+
+ double precision :: scale_factor
+ real(kind=CUSTOM_REAL):: vs_val
+ integer :: i,j,k,ispec
+ integer :: iattenuation,iselected
+
! user info
if(myrank == 0) then
@@ -69,6 +75,27 @@
write(IMAIN,*) 'no oceans'
endif
+ write(IMAIN,*)
+ if(ACOUSTIC_SIMULATION) then
+ write(IMAIN,*) 'incorporating acoustic simulation'
+ else
+ write(IMAIN,*) 'no acoustic simulation'
+ endif
+
+ write(IMAIN,*)
+ if(ELASTIC_SIMULATION) then
+ write(IMAIN,*) 'incorporating elastic simulation'
+ else
+ write(IMAIN,*) 'no elastic simulation'
+ endif
+
+ write(IMAIN,*)
+ if(POROELASTIC_SIMULATION) then
+ write(IMAIN,*) 'incorporating poroelastic simulation'
+ else
+ write(IMAIN,*) 'no poroelastic simulation'
+ endif
+ write(IMAIN,*)
endif
! synchronize all the processes before assembling the mass matrix
@@ -76,26 +103,148 @@
call sync_all()
! 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, &
- 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)
+ if(ACOUSTIC_SIMULATION) then
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass_acoustic, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+ ! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ where(rmass_acoustic <= 0._CUSTOM_REAL) rmass_acoustic = 1._CUSTOM_REAL
+ rmass_acoustic(:) = 1._CUSTOM_REAL / rmass_acoustic(:)
+
+ endif ! ACOUSTIC_SIMULATION
+
+ if(ELASTIC_SIMULATION) then
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+ ! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ where(rmass <= 0._CUSTOM_REAL) rmass = 1._CUSTOM_REAL
+ rmass(:) = 1._CUSTOM_REAL / rmass(:)
+
+ if(OCEANS ) then
+ if( minval(rmass_ocean_load(:)) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative ocean load mass matrix term')
+ rmass_ocean_load(:) = 1. / rmass_ocean_load(:)
+ endif
+
+ endif ! ELASTIC_SIMULATION
+
+ if(POROELASTIC_SIMULATION) then
+
+ stop 'poroelastic simulation not implemented yet'
+
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass_solid_poroelastic, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass_fluid_poroelastic, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+ ! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ where(rmass_solid_poroelastic <= 0._CUSTOM_REAL) rmass_solid_poroelastic = 1._CUSTOM_REAL
+ where(rmass_fluid_poroelastic <= 0._CUSTOM_REAL) rmass_fluid_poroelastic = 1._CUSTOM_REAL
+ rmass_solid_poroelastic(:) = 1._CUSTOM_REAL / rmass_solid_poroelastic(:)
+ rmass_fluid_poroelastic(:) = 1._CUSTOM_REAL / rmass_fluid_poroelastic(:)
+
+ endif ! POROELASTIC_SIMULATION
+
if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix'
-! check that mass matrix is positive
- if(minval(rmass(:)) <= 0.) call exit_MPI(myrank,'negative mass matrix term')
- if(OCEANS .and. minval(rmass_ocean_load(:)) <= 0.) &
- call exit_MPI(myrank,'negative ocean load mass matrix term')
+! initialize acoustic arrays to zero
+ if( ACOUSTIC_SIMULATION ) then
+ potential_acoustic(:) = 0._CUSTOM_REAL
+ potential_dot_acoustic(:) = 0._CUSTOM_REAL
+ potential_dot_dot_acoustic(:) = 0._CUSTOM_REAL
+ ! put negligible initial value to avoid very slow underflow trapping
+ if(FIX_UNDERFLOW_PROBLEM) potential_dot_dot_acoustic(:) = VERYSMALLVAL
+ endif
+
+! initialize elastic arrays to zero/verysmallvall
+ if( ELASTIC_SIMULATION ) then
+ displ(:,:) = 0._CUSTOM_REAL
+ veloc(:,:) = 0._CUSTOM_REAL
+ accel(:,:) = 0._CUSTOM_REAL
+ ! put negligible initial value to avoid very slow underflow trapping
+ if(FIX_UNDERFLOW_PROBLEM) displ(:,:) = VERYSMALLVAL
+ endif
-! for efficiency, invert final mass matrix once and for all in each slice
- if(OCEANS) rmass_ocean_load(:) = 1. / rmass_ocean_load(:)
- rmass(:) = 1.0 / rmass(:)
+ !! DK DK array not created yet for CUBIT
+ ! if (SIMULATION_TYPE == 3) then ! kernel calculation, read in last frame
+ ! open(unit=27,file=trim(prname)//'save_forward_arrays.bin',status='old',action='read',form='unformatted')
+ ! read(27) b_displ
+ ! read(27) b_veloc
+ ! read(27) b_accel
+
+ ! rho_kl(:,:,:,:) = 0._CUSTOM_REAL
+ ! mu_kl(:,:,:,:) = 0._CUSTOM_REAL
+ ! kappa_kl(:,:,:,:) = 0._CUSTOM_REAL
+
+ ! endif
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' time step: ',sngl(DT),' s'
+ write(IMAIN,*) 'number of time steps: ',NSTEP
+ write(IMAIN,*) 'total simulated time: ',sngl(NSTEP*DT),' seconds'
+ write(IMAIN,*)
+ endif
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ deltat = sngl(DT)
+ else
+ deltat = DT
+ endif
+ deltatover2 = deltat/2.
+ deltatsqover2 = deltat*deltat/2.
+ ! if (SIMULATION_TYPE == 3) then
+ ! if(CUSTOM_REAL == SIZE_REAL) then
+ ! b_deltat = - sngl(DT)
+ ! else
+ ! b_deltat = - DT
+ ! endif
+ ! b_deltatover2 = b_deltat/2.
+ ! b_deltatsqover2 = b_deltat*b_deltat/2.
+ ! endif
+
+! seismograms
+ if (nrec_local > 0) then
+ ! allocate seismogram array
+ allocate(seismograms_d(NDIM,nrec_local,NSTEP))
+ allocate(seismograms_v(NDIM,nrec_local,NSTEP))
+ allocate(seismograms_a(NDIM,nrec_local,NSTEP))
+
+ ! initialize seismograms
+ seismograms_d(:,:,:) = 0._CUSTOM_REAL
+ seismograms_v(:,:,:) = 0._CUSTOM_REAL
+ seismograms_a(:,:,:) = 0._CUSTOM_REAL
+
+ ! if (SIMULATION_TYPE == 2) then
+ ! ! allocate Frechet derivatives array
+ ! allocate(Mxx_der(nrec_local),Myy_der(nrec_local),Mzz_der(nrec_local),Mxy_der(nrec_local), &
+ ! Mxz_der(nrec_local),Myz_der(nrec_local), sloc_der(NDIM,nrec_local))
+ ! Mxx_der = 0._CUSTOM_REAL
+ ! Myy_der = 0._CUSTOM_REAL
+ ! Mzz_der = 0._CUSTOM_REAL
+ ! Mxy_der = 0._CUSTOM_REAL
+ ! Mxz_der = 0._CUSTOM_REAL
+ ! Myz_der = 0._CUSTOM_REAL
+ ! sloc_der = 0._CUSTOM_REAL
+ ! allocate(seismograms_eps(NDIM,NDIM,nrec_local,NSTEP))
+ ! seismograms_eps(:,:,:,:) = 0._CUSTOM_REAL
+ ! endif
+ endif
+
! if attenuation is on, shift PREM to right frequency
! rescale mu in PREM to average frequency for attenuation
-
if(ATTENUATION) then
! get and store PREM attenuation model
@@ -104,7 +253,7 @@
call get_attenuation_model(myrank,iattenuation,tau_mu_dble, &
tau_sigma_dble,beta_dble,one_minus_sum_beta_dble,factor_scale_dble)
-! distinguish between single and double precision for reals
+ ! distinguish between single and double precision for reals
if(CUSTOM_REAL == SIZE_REAL) then
tau_mu(iattenuation,:) = sngl(tau_mu_dble(:))
tau_sigma(iattenuation,:) = sngl(tau_sigma_dble(:))
@@ -121,24 +270,23 @@
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
+ ! 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 )
+ call get_attenuation_model_olsen( vs_val, iselected )
else
-! takes iflag set in (CUBIT) mesh
+ ! takes iflag set in (CUBIT) mesh
iselected = iflag_attenuation_store(i,j,k,ispec)
endif
-! scales only mu
+ ! scales only mu
scale_factor = factor_scale(iselected)
mustore(i,j,k,ispec) = mustore(i,j,k,ispec) * scale_factor
@@ -147,194 +295,7 @@
enddo
enddo
-! obsolete, old way...
-!pll
-! do ispec = 1,NSPEC_AB
-! if(not_fully_in_bedrock(ispec)) then
-! do k=1,NGLLZ
-! do j=1,NGLLY
-! do i=1,NGLLX
-!
-!! distinguish attenuation factors
-! if(flag_sediments(i,j,k,ispec)) then
-!
-!! use constant attenuation of Q = 90
-!! or 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)
-!! 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
-!
-! else
-! iattenuation_sediments = IATTENUATION_SEDIMENTS_90
-! endif
-!
-! scale_factor = factor_scale(iattenuation_sediments)
-! else
-! scale_factor = factor_scale(IATTENUATION_BEDROCK)
-! endif
-!
-! mustore(i,j,k,ispec) = mustore(i,j,k,ispec) * scale_factor
-!
-! enddo
-! enddo
-! enddo
-! endif
-! enddo
-
- endif ! ATTENUATION
-
-! allocate seismogram array
- if (nrec_local > 0) then
- allocate(seismograms_d(NDIM,nrec_local,NSTEP))
- allocate(seismograms_v(NDIM,nrec_local,NSTEP))
- allocate(seismograms_a(NDIM,nrec_local,NSTEP))
-! initialize seismograms
- seismograms_d(:,:,:) = 0._CUSTOM_REAL
- seismograms_v(:,:,:) = 0._CUSTOM_REAL
- seismograms_a(:,:,:) = 0._CUSTOM_REAL
- if (SIMULATION_TYPE == 2) then
- ! allocate Frechet derivatives array
- allocate(Mxx_der(nrec_local),Myy_der(nrec_local),Mzz_der(nrec_local),Mxy_der(nrec_local), &
- Mxz_der(nrec_local),Myz_der(nrec_local), sloc_der(NDIM,nrec_local))
- Mxx_der = 0._CUSTOM_REAL
- Myy_der = 0._CUSTOM_REAL
- Mzz_der = 0._CUSTOM_REAL
- Mxy_der = 0._CUSTOM_REAL
- Mxz_der = 0._CUSTOM_REAL
- Myz_der = 0._CUSTOM_REAL
- sloc_der = 0._CUSTOM_REAL
- allocate(seismograms_eps(NDIM,NDIM,nrec_local,NSTEP))
- seismograms_eps(:,:,:,:) = 0._CUSTOM_REAL
- endif
- endif
-
-! initialize arrays to zero
- displ(:,:) = 0._CUSTOM_REAL
- veloc(:,:) = 0._CUSTOM_REAL
- accel(:,:) = 0._CUSTOM_REAL
-
-! put negligible initial value to avoid very slow underflow trapping
- if(FIX_UNDERFLOW_PROBLEM) displ(:,:) = VERYSMALLVAL
-
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) then ! kernel calculation, read in last frame
-
-! open(unit=27,file=trim(prname)//'save_forward_arrays.bin',status='old',action='read',form='unformatted')
-! read(27) b_displ
-! read(27) b_veloc
-! read(27) b_accel
-
-! rho_kl(:,:,:,:) = 0._CUSTOM_REAL
-! mu_kl(:,:,:,:) = 0._CUSTOM_REAL
-! kappa_kl(:,:,:,:) = 0._CUSTOM_REAL
-
-! endif
-
-! allocate files to save movies and shaking map
- if(MOVIE_SURFACE .or. CREATE_SHAKEMAP) then
- if (USE_HIGHRES_FOR_MOVIES) then
- nmovie_points = NGLLX * NGLLY * NSPEC2D_TOP
- else
- nmovie_points = NGNOD2D * NSPEC2D_TOP
- iorderi(1) = 1
- iorderi(2) = NGLLX
- iorderi(3) = NGLLX
- iorderi(4) = 1
- iorderj(1) = 1
- iorderj(2) = 1
- iorderj(3) = NGLLY
- iorderj(4) = NGLLY
- endif
- allocate(store_val_x(nmovie_points))
- allocate(store_val_y(nmovie_points))
- allocate(store_val_z(nmovie_points))
- allocate(store_val_ux(nmovie_points))
- allocate(store_val_uy(nmovie_points))
- allocate(store_val_uz(nmovie_points))
- allocate(store_val_norm_displ(nmovie_points))
- allocate(store_val_norm_veloc(nmovie_points))
- allocate(store_val_norm_accel(nmovie_points))
-
- allocate(store_val_x_all(nmovie_points,0:NPROC-1))
- allocate(store_val_y_all(nmovie_points,0:NPROC-1))
- allocate(store_val_z_all(nmovie_points,0:NPROC-1))
- allocate(store_val_ux_all(nmovie_points,0:NPROC-1))
- allocate(store_val_uy_all(nmovie_points,0:NPROC-1))
- allocate(store_val_uz_all(nmovie_points,0:NPROC-1))
-
-! to compute max of norm for shaking map
- store_val_norm_displ(:) = -1.
- store_val_norm_veloc(:) = -1.
- store_val_norm_accel(:) = -1.
- else if (MOVIE_VOLUME) then
- allocate(div(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(curl_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(curl_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(curl_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- endif
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) ' time step: ',sngl(DT),' s'
- write(IMAIN,*) 'number of time steps: ',NSTEP
- write(IMAIN,*) 'total simulated time: ',sngl(NSTEP*DT),' seconds'
- write(IMAIN,*)
- endif
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- deltat = sngl(DT)
- else
- deltat = DT
- endif
- deltatover2 = deltat/2.
- deltatsqover2 = deltat*deltat/2.
- if (SIMULATION_TYPE == 3) then
- if(CUSTOM_REAL == SIZE_REAL) then
- b_deltat = - sngl(DT)
- else
- b_deltat = - DT
- endif
- b_deltatover2 = b_deltat/2.
- b_deltatsqover2 = b_deltat*b_deltat/2.
- endif
-
! precompute Runge-Kutta coefficients if attenuation
- if(ATTENUATION) then
tauinv(:,:) = - 1. / tau_sigma(:,:)
factor_common(:,:) = 2. * beta(:,:) * tauinv(:,:)
alphaval(:,:) = 1 + deltat*tauinv(:,:) + deltat**2*tauinv(:,:)**2 / 2. + &
@@ -369,7 +330,7 @@
! clear memory variables if attenuation
if(ATTENUATION) then
- ! initialize memory variables for attenuation
+ ! initialize memory variables for attenuation
epsilondev_xx(:,:,:,:) = 0._CUSTOM_REAL
epsilondev_yy(:,:,:,:) = 0._CUSTOM_REAL
epsilondev_xy(:,:,:,:) = 0._CUSTOM_REAL
@@ -390,22 +351,23 @@
R_yz(:,:,:,:,:) = VERYSMALLVAL
endif
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) then
-! read(27) b_R_xx
-! read(27) b_R_yy
-! read(27) b_R_xy
-! read(27) b_R_xz
-! read(27) b_R_yz
-! read(27) b_epsilondev_xx
-! read(27) b_epsilondev_yy
-! read(27) b_epsilondev_xy
-! read(27) b_epsilondev_xz
-! read(27) b_epsilondev_yz
-! endif
+ !! DK DK array not created yet for CUBIT
+ ! if (SIMULATION_TYPE == 3) then
+ ! read(27) b_R_xx
+ ! read(27) b_R_yy
+ ! read(27) b_R_xy
+ ! read(27) b_R_xz
+ ! read(27) b_R_yz
+ ! read(27) b_epsilondev_xx
+ ! read(27) b_epsilondev_yy
+ ! read(27) b_epsilondev_xy
+ ! read(27) b_epsilondev_xz
+ ! read(27) b_epsilondev_yz
+ ! endif
+ ! close(27)
endif
- close(27)
+
! initialize Moho boundary index
! if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
@@ -415,6 +377,4 @@
! k_bot = NGLLZ
! endif
-
-
end subroutine
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_arrays_buffers_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_arrays_buffers_solver.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_arrays_buffers_solver.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -37,7 +37,7 @@
integer npoin2D_xi,npoin2D_eta
integer NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX
- character(len=150) LOCAL_PATH
+ character(len=256) LOCAL_PATH
integer, dimension(NPOIN2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
integer, dimension(NPOIN2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
@@ -47,7 +47,7 @@
double precision xdummy,ydummy,zdummy
! processor identification
- character(len=150) prname
+ character(len=256) prname
! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_arrays_solver.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_arrays_solver.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -37,7 +37,7 @@
include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
+! include "OUTPUT_FILES/values_from_mesher.h"
integer myrank
@@ -46,7 +46,7 @@
logical OCEANS
- character(len=150) LOCAL_PATH
+ character(len=256) LOCAL_PATH
! coordinates in single precision
real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: xstore,ystore,zstore
@@ -81,7 +81,7 @@
integer idoubling(NSPEC_AB)
! processor identification
- character(len=150) prname
+ character(len=256) prname
! create the name for the database of the current slide and region
call create_name_database(prname,myrank,LOCAL_PATH)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -29,9 +29,13 @@
use specfem_par
use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_poroelastic
+ implicit none
- implicit none
-
+ integer :: i,j,k,ispec,iglob
+ integer :: iinterface
+
! start reading the databasesa
! info about external mesh simulation
@@ -49,126 +53,152 @@
read(27) gammay
read(27) gammaz
read(27) jacobian
+
+ read(27) ibool
- !pll
- read(27) rho_vp
- read(27) rho_vs
- read(27) iflag_attenuation_store
+ read(27) xstore
+ read(27) ystore
+ read(27) zstore
+ read(27) kappastore
+ read(27) mustore
+
+ read(27) ispec_is_acoustic
+ read(27) ispec_is_elastic
+ read(27) ispec_is_poroelastic
+
+ ! acoustic
+ ! all processes will have acoustic_simulation set if any flag is .true.
+ call any_all_l( ANY(ispec_is_acoustic), ACOUSTIC_SIMULATION )
+ if( ACOUSTIC_SIMULATION ) then
+ ! potentials
+ allocate(potential_acoustic(NGLOB_AB))
+ allocate(potential_dot_acoustic(NGLOB_AB))
+ allocate(potential_dot_dot_acoustic(NGLOB_AB))
+
+ ! mass matrix, density
+ allocate(rmass_acoustic(NGLOB_AB))
+ allocate(rhostore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+
+ read(27) rmass_acoustic
+ read(27) rhostore
+ endif
+
+ ! elastic
+ call any_all_l( ANY(ispec_is_elastic), ELASTIC_SIMULATION )
+ if( ELASTIC_SIMULATION ) then
+ ! displacement,velocity,acceleration
+ allocate(displ(NDIM,NGLOB_AB))
+ allocate(veloc(NDIM,NGLOB_AB))
+ allocate(accel(NDIM,NGLOB_AB))
+
+ allocate(rmass(NGLOB_AB))
+ allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(iflag_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c66store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+
+ read(27) rmass
+ if( OCEANS ) then
+ read(27) rmass_ocean_load
+ endif
+ !pll
+ read(27) rho_vp
+ read(27) rho_vs
+ read(27) iflag_attenuation_store
+
+ else
+ ! no elastic attenuation & anisotropy
+ ATTENUATION = .false.
+ ANISOTROPY = .false.
+ endif
+
+ ! poroelastic
+ call any_all_l( ANY(ispec_is_poroelastic), POROELASTIC_SIMULATION )
+ if( POROELASTIC_SIMULATION ) then
+
+ stop 'not implemented yet '
+
+ allocate(rmass_solid_poroelastic(NGLOB_AB))
+ allocate(rmass_fluid_poroelastic(NGLOB_AB))
+
+ read(27) rmass_solid_poroelastic
+ read(27) rmass_fluid_poroelastic
+ endif
+
+! checks simulation types are valid
+ if( (.not. ACOUSTIC_SIMULATION ) .and. &
+ (.not. ELASTIC_SIMULATION ) .and. &
+ (.not. POROELASTIC_SIMULATION ) ) then
+ close(27)
+ call exit_mpi(myrank,'error no simulation type defined')
+ endif
+
! checks attenuation flags: see integers defined in constants.h
if( ATTENUATION ) then
if( minval(iflag_attenuation_store(:,:,:,:)) < 1 ) then
close(27)
- call exit_MPI(myrank,'something is wrong with the mesh attenuation: flag entry is invalid')
+ call exit_MPI(myrank,'error attenuation flag entry exceeds range')
endif
if( maxval(iflag_attenuation_store(:,:,:,:)) > NUM_REGIONS_ATTENUATION ) then
close(27)
- call exit_MPI(myrank,'something is wrong with the mesh attenuation: flag entry exceeds number of defined attenuation flags in constants.h')
+ call exit_MPI(myrank,'error attenuation flag entry exceeds range')
endif
endif
-! read(27) NSPEC2DMAX_XMIN_XMAX_ext
-! read(27) NSPEC2DMAX_YMIN_YMAX_ext
-! allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX_ext),nimax(2,NSPEC2DMAX_YMIN_YMAX_ext),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX_ext))
-! allocate(njmin(2,NSPEC2DMAX_XMIN_XMAX_ext),njmax(2,NSPEC2DMAX_XMIN_XMAX_ext),nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX_ext))
-! read(27) nimin
-! read(27) nimax
-! read(27) njmin
-! read(27) njmax
-! read(27) nkmin_xi
-! read(27) nkmin_eta
- !end pll
+! absorbing boundary surface
+ read(27) num_abs_boundary_faces
+ allocate(abs_boundary_ispec(num_abs_boundary_faces))
+ allocate(abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces))
+ allocate(abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces))
+ allocate(abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces))
+ read(27) abs_boundary_ispec
+ read(27) abs_boundary_ijk
+ read(27) abs_boundary_jacobian2Dw
+ read(27) abs_boundary_normal
- read(27) kappastore
- read(27) mustore
- read(27) rmass
- read(27) ibool
- read(27) xstore
- read(27) ystore
- read(27) zstore
+! free surface
+ read(27) num_free_surface_faces
+ allocate(free_surface_ispec(num_free_surface_faces))
+ allocate(free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces))
+ allocate(free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces))
+ allocate(free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces))
+ read(27) free_surface_ispec
+ read(27) free_surface_ijk
+ read(27) free_surface_jacobian2Dw
+ read(27) free_surface_normal
-! absorbing boundaries
- !pll
-! read(27) nspec2D_xmin
-! read(27) nspec2D_xmax
-! read(27) nspec2D_ymin
-! read(27) nspec2D_ymax
-! read(27) NSPEC2D_BOTTOM
-! read(27) NSPEC2D_TOP
-! allocate(ibelm_xmin(nspec2D_xmin))
-! allocate(ibelm_xmax(nspec2D_xmax))
-! allocate(ibelm_ymin(nspec2D_ymin))
-! allocate(ibelm_ymax(nspec2D_ymax))
-! allocate(ibelm_bottom(NSPEC2D_BOTTOM))
-! allocate(ibelm_top(NSPEC2D_TOP))
-!
-! allocate(ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin))
-! allocate(ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax))
-! allocate(ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin))
-! allocate(ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax))
-! allocate(ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom))
-! allocate(ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top))
-!
-! allocate(jacobian2D_xmin(NGLLY,NGLLZ,nspec2D_xmin))
-! allocate(jacobian2D_xmax(NGLLY,NGLLZ,nspec2D_xmax))
-! allocate(jacobian2D_ymin(NGLLX,NGLLZ,nspec2D_ymin))
-! allocate(jacobian2D_ymax(NGLLX,NGLLZ,nspec2D_ymax))
-! allocate(jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM))
-! allocate(jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP))
-!
-! allocate(normal_xmin(NDIM,NGLLY,NGLLZ,nspec2D_xmin))
-! allocate(normal_xmax(NDIM,NGLLY,NGLLZ,nspec2D_xmax))
-! allocate(normal_ymin(NDIM,NGLLX,NGLLZ,nspec2D_ymin))
-! allocate(normal_ymax(NDIM,NGLLX,NGLLZ,nspec2D_ymax))
-! allocate(normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM))
-! allocate(normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP))
-! read(27) ibelm_xmin
-! read(27) ibelm_xmax
-! read(27) ibelm_ymin
-! read(27) ibelm_ymax
-! read(27) ibelm_bottom
-! read(27) ibelm_top
-!
-! read(27) ibelm_gll_xmin
-! read(27) ibelm_gll_xmax
-! read(27) ibelm_gll_ymin
-! read(27) ibelm_gll_ymax
-! read(27) ibelm_gll_bottom
-! read(27) ibelm_gll_top
-!
-! read(27) normal_xmin
-! read(27) normal_xmax
-! read(27) normal_ymin
-! read(27) normal_ymax
-! read(27) normal_bottom
-! read(27) normal_top
-! read(27) jacobian2D_xmin
-! read(27) jacobian2D_xmax
-! read(27) jacobian2D_ymin
-! read(27) jacobian2D_ymax
-! read(27) jacobian2D_bottom
-! read(27) jacobian2D_top
-! !end pll
-
- read(27) num_absorbing_boundary_faces
- allocate(absorbing_boundary_ispec(num_absorbing_boundary_faces))
- allocate(absorbing_boundary_ijk(3,NGLLSQUARE,num_absorbing_boundary_faces))
- allocate(absorbing_boundary_jacobian2D(NGLLSQUARE,num_absorbing_boundary_faces))
- allocate(absorbing_boundary_normal(NDIM,NGLLSQUARE,num_absorbing_boundary_faces))
- read(27) absorbing_boundary_ispec
- read(27) absorbing_boundary_ijk
- read(27) absorbing_boundary_jacobian2D
- read(27) absorbing_boundary_normal
-
-! free surface
- read(27) NSPEC2D_TOP
- allocate(ibelm_top(NSPEC2D_TOP))
- allocate(jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP))
- allocate(normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP))
- read(27) ibelm_top
- read(27) jacobian2D_top
- read(27) normal_top
-
+! acoustic-elastic coupling surface
+ read(27) num_coupling_ac_el_faces
+ allocate(coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_ispec(num_coupling_ac_el_faces))
+ read(27) coupling_ac_el_ispec
+ read(27) coupling_ac_el_ijk
+ read(27) coupling_ac_el_jacobian2Dw
+ read(27) coupling_ac_el_normal
+
! MPI interfaces
read(27) num_interfaces_ext_mesh
read(27) max_nibool_interfaces_ext_mesh
@@ -216,14 +246,14 @@
allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh))
! locate inner and outer elements
- allocate(ispec_is_inner_ext_mesh(NSPEC_AB))
- allocate(iglob_is_inner_ext_mesh(NGLOB_AB))
- ispec_is_inner_ext_mesh(:) = .true.
- iglob_is_inner_ext_mesh(:) = .true.
+ allocate(ispec_is_inner(NSPEC_AB))
+ allocate(iglob_is_inner(NGLOB_AB))
+ ispec_is_inner(:) = .true.
+ iglob_is_inner(:) = .true.
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.
+ iglob_is_inner(iglob) = .false.
enddo
enddo
do ispec = 1, NSPEC_AB
@@ -231,12 +261,13 @@
do j = 1, NGLLY
do i = 1, NGLLX
iglob = ibool(i,j,k,ispec)
- ispec_is_inner_ext_mesh(ispec) = iglob_is_inner_ext_mesh(iglob) .and. ispec_is_inner_ext_mesh(ispec)
+ ispec_is_inner(ispec) = iglob_is_inner(iglob) .and. ispec_is_inner(ispec)
enddo
enddo
enddo
enddo
-
+ deallocate( iglob_is_inner )
+
! counts inner and outer elements
! nspec_inner = 0
! nspec_outer = 0
@@ -267,8 +298,9 @@
! check courant criteria on mesh
- call check_mesh_resolution(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, &
- kappastore,mustore,rho_vp,rho_vs, &
- DT )
+ if( ELASTIC_SIMULATION ) then
+ call check_mesh_resolution(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, &
+ kappastore,mustore,rho_vp,rho_vs,DT )
+ endif
end subroutine
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_moho_map.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_moho_map.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_moho_map.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -38,7 +38,7 @@
double precision long,lat,depth_km
- character(len=150) MOHO_MAP_FILE
+ character(len=256) MOHO_MAP_FILE
imoho_depth(:,:) = 0
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_parameter_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_parameter_file.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_parameter_file.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -46,14 +46,14 @@
logical MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT,USE_HIGHRES_FOR_MOVIES
logical ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION,SUPPRESS_UTM_PROJECTION
- character(len=150) LOCAL_PATH,CMTSOLUTION
+ character(len=256) LOCAL_PATH,CMTSOLUTION
! local variables
integer ios,icounter,isource,idummy
double precision hdur,minval_hdur
- character(len=150) dummystring
+ character(len=256) dummystring
integer, external :: err_occurred
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_value_parameters.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_value_parameters.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -31,7 +31,7 @@
integer value_to_read
character(len=*) name
- character(len=100) string_read
+ character(len=256) string_read
call unused_string(name)
@@ -48,7 +48,7 @@
double precision value_to_read
character(len=*) name
- character(len=100) string_read
+ character(len=256) string_read
call unused_string(name)
@@ -65,7 +65,7 @@
logical value_to_read
character(len=*) name
- character(len=100) string_read
+ character(len=256) string_read
call unused_string(name)
@@ -82,7 +82,7 @@
character(len=*) value_to_read
character(len=*) name
- character(len=100) string_read
+ character(len=256) string_read
call unused_string(name)
@@ -99,12 +99,12 @@
include "constants.h"
- character(len=100) string_read
+ character(len=256) string_read
integer index_equal_sign,ios
do
- read(unit=IIN,fmt="(a100)",iostat=ios) string_read
+ read(unit=IIN,fmt="(a256)",iostat=ios) string_read
if(ios /= 0) stop 'error while reading parameter file'
! suppress leading white spaces, if any
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/salton_trough_gocad.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/salton_trough_gocad.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/salton_trough_gocad.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -33,7 +33,7 @@
real :: vp_array(GOCAD_ST_NU,GOCAD_ST_NV,GOCAD_ST_NW)
integer :: ios, reclen
- character(len=150) SALTON_SEA_MODEL_FILE
+ character(len=256) SALTON_SEA_MODEL_FILE
reclen=(GOCAD_ST_NU * GOCAD_ST_NV * GOCAD_ST_NW) * 4
call get_value_string(SALTON_SEA_MODEL_FILE, &
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -30,11 +30,20 @@
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
gammaxstore,gammaystore,gammazstore, &
jacobianstore, rho_vp,rho_vs,iflag_attenuation_store, &
- kappastore,mustore,rmass,ibool,xstore_dummy,ystore_dummy,zstore_dummy, &
- NSPEC2D_TOP,ibelm_top,normal_top,jacobian2D_top, &
- absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
- absorbing_boundary_ijk,absorbing_boundary_ispec, &
- num_absorbing_boundary_faces, &
+ rhostore,kappastore,mustore, &
+ rmass,rmass_acoustic,rmass_solid_poroelastic,rmass_fluid_poroelastic, &
+ OCEANS,rmass_ocean_load,NGLOB_OCEAN,&
+ ibool, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ abs_boundary_normal,abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ free_surface_normal,free_surface_jacobian2Dw, &
+ free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ coupling_ac_el_normal,coupling_ac_el_jacobian2Dw, &
+ coupling_ac_el_ijk,coupling_ac_el_ispec, &
+ num_coupling_ac_el_faces, &
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, &
@@ -42,9 +51,9 @@
c11store,c12store,c13store,c14store,c15store,c16store, &
c22store,c23store,c24store,c25store,c26store,c33store, &
c34store,c35store,c36store,c44store,c45store,c46store, &
- c55store,c56store,c66store)
+ c55store,c56store,c66store, &
+ ispec_is_acoustic,ispec_is_elastic,ispec_is_poroelastic)
-
implicit none
include "constants.h"
@@ -53,55 +62,45 @@
! jacobian
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore,jacobianstore
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore,jacobianstore
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rho_vp,rho_vs
! attenuation
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: iflag_attenuation_store
! material
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: kappastore,mustore
- real(kind=CUSTOM_REAL), dimension(nglob) :: rmass
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,kappastore,mustore
+ real(kind=CUSTOM_REAL), dimension(nglob) :: rmass,rmass_acoustic, &
+ rmass_solid_poroelastic,rmass_fluid_poroelastic
+! ocean load
+ logical :: OCEANS
+ integer :: NGLOB_OCEAN
+ real(kind=CUSTOM_REAL),dimension(NGLOB_OCEAN) :: rmass_ocean_load
! mesh coordinates
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
-! absorbing boundaries
-! integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM
- integer :: NSPEC2D_TOP
-! integer, dimension(nspec2D_xmin) :: ibelm_xmin
-! integer, dimension(nspec2D_xmax) :: ibelm_xmax
-! integer, dimension(nspec2D_ymin) :: ibelm_ymin
-! integer, dimension(nspec2D_ymax) :: ibelm_ymax
-! integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
- integer, dimension(NSPEC2D_TOP) :: ibelm_top
-! 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)
-! 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,NGLLX,NGLLZ,nspec2D_ymin) :: normal_ymin
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,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
-! 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
+! absorbing boundary surface
+ integer :: num_abs_boundary_faces
+ real(kind=CUSTOM_REAL) :: abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces)
+ real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ispec(num_abs_boundary_faces)
- 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
-
+! free surface
+ integer :: num_free_surface_faces
+ real(kind=CUSTOM_REAL) :: free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces)
+ real(kind=CUSTOM_REAL) :: free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ispec(num_free_surface_faces)
-! integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
-! integer, dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nimin,nimax,nkmin_eta
-! integer, dimension(2,NSPEC2DMAX_XMIN_XMAX) :: njmin,njmax,nkmin_xi
+! acoustic-elastic coupling surface
+ integer :: num_coupling_ac_el_faces
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ispec(num_coupling_ac_el_faces)
! MPI interfaces
integer :: num_interfaces_ext_mesh
@@ -111,7 +110,7 @@
integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
! file name
- character(len=150) prname
+ character(len=256) prname
logical :: SAVE_MESH_FILES
! anisotropy
@@ -122,15 +121,26 @@
c22store,c23store,c24store,c25store,c26store,c33store, &
c34store,c35store,c36store,c44store,c45store,c46store, &
c55store,c56store,c66store
+
+! material domain flags
+ logical, dimension(nspec) :: ispec_is_acoustic,ispec_is_elastic,ispec_is_poroelastic
! local parameters
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: v_tmp
- real(kind=CUSTOM_REAL) :: minimum(1)
+ integer,dimension(:),allocatable :: v_tmp_i
+
+ !real(kind=CUSTOM_REAL) :: minimum(1)
integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy
integer :: ier,i
+ logical :: ACOUSTIC_SIMULATION,ELASTIC_SIMULATION,POROELASTIC_SIMULATION
+ character(len=256) :: filename
+ integer, dimension(:), allocatable :: iglob_tmp
+ integer :: j,inum
+
! saves mesh file proc***_external_mesh.bin
- open(unit=IOUT,file=prname(1:len_trim(prname))//'external_mesh.bin',status='unknown',action='write',form='unformatted',iostat=ier)
+ filename = prname(1:len_trim(prname))//'external_mesh.bin'
+ open(unit=IOUT,file=trim(filename),status='unknown',action='write',form='unformatted',iostat=ier)
if( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin'
write(IOUT) nspec
@@ -147,95 +157,82 @@
write(IOUT) gammazstore
write(IOUT) jacobianstore
- !pll Stacey
- write(IOUT) rho_vp
- write(IOUT) rho_vs
- write(IOUT) iflag_attenuation_store
-
-! write(IOUT) NSPEC2DMAX_XMIN_XMAX
-! write(IOUT) NSPEC2DMAX_YMIN_YMAX
-! write(IOUT) nimin
-! write(IOUT) nimax
-! write(IOUT) njmin
-! write(IOUT) njmax
-! write(IOUT) nkmin_xi
-! write(IOUT) nkmin_eta
- !end pll
-
- write(IOUT) kappastore
- write(IOUT) mustore
-
- write(IOUT) rmass
write(IOUT) ibool
write(IOUT) xstore_dummy
write(IOUT) ystore_dummy
write(IOUT) zstore_dummy
-! absorbing boundary parameters
-! write(IOUT) nspec2D_xmin
-! write(IOUT) nspec2D_xmax
-! write(IOUT) nspec2D_ymin
-! write(IOUT) nspec2D_ymax
-! write(IOUT) NSPEC2D_BOTTOM
-! write(IOUT) NSPEC2D_TOP
-!
-! write(IOUT) ibelm_xmin
-! write(IOUT) ibelm_xmax
-! write(IOUT) ibelm_ymin
-! write(IOUT) ibelm_ymax
-! write(IOUT) ibelm_bottom
-! write(IOUT) ibelm_top
-!
-! write(IOUT) ibelm_gll_xmin
-! write(IOUT) ibelm_gll_xmax
-! write(IOUT) ibelm_gll_ymin
-! write(IOUT) ibelm_gll_ymax
-! write(IOUT) ibelm_gll_bottom
-! write(IOUT) ibelm_gll_top
-!
-! write(IOUT) normal_xmin
-! write(IOUT) normal_xmax
-! write(IOUT) normal_ymin
-! write(IOUT) normal_ymax
-! write(IOUT) normal_bottom
-! write(IOUT) normal_top
-!
-! write(IOUT) jacobian2D_xmin
-! write(IOUT) jacobian2D_xmax
-! write(IOUT) jacobian2D_ymin
-! write(IOUT) jacobian2D_ymax
-! write(IOUT) jacobian2D_bottom
-! write(IOUT) jacobian2D_top
+ write(IOUT) kappastore
+ write(IOUT) mustore
- write(IOUT) num_absorbing_boundary_faces
- write(IOUT) absorbing_boundary_ispec
- write(IOUT) absorbing_boundary_ijk
- write(IOUT) absorbing_boundary_jacobian2D
- write(IOUT) absorbing_boundary_normal
+ write(IOUT) ispec_is_acoustic
+ write(IOUT) ispec_is_elastic
+ write(IOUT) ispec_is_poroelastic
+! acoustic
+! all processes will have acoustic_simulation set if any flag is .true. somewhere
+ call any_all_l( ANY(ispec_is_acoustic), ACOUSTIC_SIMULATION )
+ if( ACOUSTIC_SIMULATION ) then
+ write(IOUT) rmass_acoustic
+ write(IOUT) rhostore
+ endif
+
+! elastic
+ call any_all_l( ANY(ispec_is_elastic), ELASTIC_SIMULATION )
+ if( ELASTIC_SIMULATION ) then
+ write(IOUT) rmass
+ if( OCEANS) then
+ write(IOUT) rmass_ocean_load
+ endif
+ !pll Stacey
+ write(IOUT) rho_vp
+ write(IOUT) rho_vs
+ write(IOUT) iflag_attenuation_store
+ endif
+
+! poroelastic
+ call any_all_l( ANY(ispec_is_poroelastic), POROELASTIC_SIMULATION )
+ if( POROELASTIC_SIMULATION ) then
+ write(IOUT) rmass_solid_poroelastic
+ write(IOUT) rmass_fluid_poroelastic
+ endif
+
+! absorbing boundary surface
+ write(IOUT) num_abs_boundary_faces
+ write(IOUT) abs_boundary_ispec
+ write(IOUT) abs_boundary_ijk
+ write(IOUT) abs_boundary_jacobian2Dw
+ write(IOUT) abs_boundary_normal
+
! free surface
- write(IOUT) NSPEC2D_TOP
- write(IOUT) ibelm_top
- write(IOUT) jacobian2D_top
- write(IOUT) normal_top
+ write(IOUT) num_free_surface_faces
+ write(IOUT) free_surface_ispec
+ write(IOUT) free_surface_ijk
+ write(IOUT) free_surface_jacobian2Dw
+ write(IOUT) free_surface_normal
+! acoustic-elastic coupling surface
+ write(IOUT) num_coupling_ac_el_faces
+ write(IOUT) coupling_ac_el_ispec
+ write(IOUT) coupling_ac_el_ijk
+ write(IOUT) coupling_ac_el_jacobian2Dw
+ write(IOUT) coupling_ac_el_normal
+
!MPI interfaces
write(IOUT) num_interfaces_ext_mesh
- write(IOUT) maxval(nibool_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),num_interfaces_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, num_interfaces_ext_mesh
- ibool_interfaces_ext_mesh_dummy = ibool_interfaces_ext_mesh(1:maxval(nibool_interfaces_ext_mesh),:)
+ ibool_interfaces_ext_mesh_dummy(:,i) = ibool_interfaces_ext_mesh(1:maxval(nibool_interfaces_ext_mesh(:)),i)
enddo
write(IOUT) ibool_interfaces_ext_mesh_dummy
- deallocate(ibool_interfaces_ext_mesh_dummy,stat=ier); if( ier /= 0 ) stop 'error deallocating array'
-
! anisotropy
if( ANISOTROPY ) then
write(IOUT) c11store
@@ -264,216 +261,143 @@
close(IOUT)
-
-! mesh arrays used for example in combine_vol_data.f90
+! stores arrays in binary files
if( SAVE_MESH_FILES ) then
-!--- x coordinate
+
+ ! mesh arrays used for example in combine_vol_data.f90
+ !--- x coordinate
open(unit=27,file=prname(1:len_trim(prname))//'x.bin',status='unknown',form='unformatted')
write(27) xstore_dummy
close(27)
-!--- y coordinate
+ !--- y coordinate
open(unit=27,file=prname(1:len_trim(prname))//'y.bin',status='unknown',form='unformatted')
write(27) ystore_dummy
close(27)
-!--- z coordinate
+ !--- z coordinate
open(unit=27,file=prname(1:len_trim(prname))//'z.bin',status='unknown',form='unformatted')
write(27) zstore_dummy
close(27)
-! ibool
+ ! ibool
open(unit=27,file=prname(1:len_trim(prname))//'ibool.bin',status='unknown',form='unformatted')
write(27) ibool
close(27)
allocate( v_tmp(NGLLX,NGLLY,NGLLZ,nspec), stat=ier); if( ier /= 0 ) stop 'error allocating array '
-! vp (for checking the mesh and model)
- minimum = minval( abs(rho_vp) )
- if( minimum(1) /= 0.0 ) then
- v_tmp = (FOUR_THIRDS * mustore + kappastore) / rho_vp
- else
- v_tmp = 0.0
- endif
+ ! vp (for checking the mesh and model)
+ !minimum = minval( abs(rho_vp) )
+ !if( minimum(1) /= 0.0 ) then
+ ! v_tmp = (FOUR_THIRDS * mustore + kappastore) / rho_vp
+ !else
+ ! v_tmp = 0.0
+ !endif
+ v_tmp = 0.0
+ where( rho_vp /= 0._CUSTOM_REAL ) v_tmp = (FOUR_THIRDS * mustore + kappastore) / rho_vp
open(unit=27,file=prname(1:len_trim(prname))//'vp.bin',status='unknown',form='unformatted')
write(27) v_tmp
close(27)
-! vs (for checking the mesh and model)
- minimum = minval( abs(rho_vs) )
- if( minimum(1) /= 0.0 ) then
- v_tmp = mustore / rho_vs
- else
- v_tmp = 0.0
- endif
+ ! VTK file output
+ ! vp values
+ filename = prname(1:len_trim(prname))//'vp'
+ call write_VTK_data_gll_cr(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ v_tmp,filename)
+
+
+ ! vs (for checking the mesh and model)
+ !minimum = minval( abs(rho_vs) )
+ !if( minimum(1) /= 0.0 ) then
+ ! v_tmp = mustore / rho_vs
+ !else
+ ! v_tmp = 0.0
+ !endif
+ v_tmp = 0.0
+ where( rho_vs /= 0._CUSTOM_REAL ) v_tmp = mustore / rho_vs
open(unit=27,file=prname(1:len_trim(prname))//'vs.bin',status='unknown',form='unformatted')
write(27) v_tmp
close(27)
- deallocate(v_tmp,stat=ier); if( ier /= 0 ) stop 'error deallocating array'
- endif
+ ! VTK file output
+ ! vs values
+ filename = prname(1:len_trim(prname))//'vs'
+ call write_VTK_data_gll_cr(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ v_tmp,filename)
- end subroutine save_arrays_solver_ext_mesh
-
-
-
-!=============================================================
+ ! VTK file output
+ ! saves attenuation flag assigned on each gll point into a vtk file
+ filename = prname(1:len_trim(prname))//'attenuation_flag'
+ call write_VTK_data_gll_i(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ iflag_attenuation_store,&
+ filename)
+ ! VTK file output
+ ! acoustic-elastic domains
+ if( ACOUSTIC_SIMULATION .and. ELASTIC_SIMULATION ) then
+ ! saves points on acoustic-elastic coupling interface
+ allocate( iglob_tmp(NGLLSQUARE*num_coupling_ac_el_faces))
+ inum = 0
+ iglob_tmp(:) = 0
+ do i=1,num_coupling_ac_el_faces
+ do j=1,NGLLSQUARE
+ inum = inum+1
+ iglob_tmp(inum) = ibool(coupling_ac_el_ijk(1,j,i), &
+ coupling_ac_el_ijk(2,j,i), &
+ coupling_ac_el_ijk(3,j,i), &
+ coupling_ac_el_ispec(i) )
+ enddo
+ enddo
+ filename = prname(1:len_trim(prname))//'coupling_acoustic_elastic'
+ call write_VTK_data_points(nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ iglob_tmp,NGLLSQUARE*num_coupling_ac_el_faces, &
+ filename)
+
+ ! saves acoustic/elastic flag
+ allocate(v_tmp_i(nspec))
+ do i=1,nspec
+ if( ispec_is_acoustic(i) ) then
+ v_tmp_i(i) = 1
+ else if( ispec_is_elastic(i) ) then
+ v_tmp_i(i) = 2
+ else
+ v_tmp_i(i) = 0
+ endif
+ enddo
+ filename = prname(1:len_trim(prname))//'acoustic_elastic_flag'
+ call write_VTK_data_elem_i(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ v_tmp_i,filename)
+ endif
-! external mesh routine for saving vtk file holding integer flag for each element
+ !! saves 1. MPI interface
+ ! if( num_interfaces_ext_mesh >= 1 ) then
+ ! filename = prname(1:len_trim(prname))//'MPI_1_points'
+ ! call write_VTK_data_points(nglob, &
+ ! xstore_dummy,ystore_dummy,zstore_dummy, &
+ ! ibool_interfaces_ext_mesh_dummy(1:nibool_interfaces_ext_mesh(1),1), &
+ ! nibool_interfaces_ext_mesh(1), &
+ ! filename)
+ ! endif
+ !
- subroutine save_arrays_solver_ext_mesh_elem_vtk(nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- elem_flag,prname_file)
+ deallocate(v_tmp)
+
+ endif ! SAVE_MESH_FILES
+! cleanup
+ deallocate(ibool_interfaces_ext_mesh_dummy,stat=ier); if( ier /= 0 ) stop 'error deallocating array'
- implicit none
- include "constants.h"
-
- integer :: nspec,nglob
-
-! global coordinates
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
-
-! element flag array
- integer, dimension(nspec) :: elem_flag
- integer :: ispec,i
-
-! file name
- character(len=150) prname_file
-
-! write source and receiver VTK files for Paraview
- write(IMAIN,*) ' vtk file: ',prname_file(1:len_trim(prname_file))//'.vtk'
+ end subroutine save_arrays_solver_ext_mesh
- open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
- write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
- write(IOVTK,'(a)') 'material model VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i,a)') 'POINTS ', nglob, ' float'
- do i=1,nglob
- write(IOVTK,'(3f)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
- enddo
- write(IOVTK,*) ""
-
- ! note: indices for vtk start at 0
- write(IOVTK,'(a,i,i)') "CELLS ",nspec,nspec*9
- do ispec=1,nspec
- write(IOVTK,'(9i)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
- ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
- enddo
- write(IOVTK,*) ""
- ! type: hexahedrons
- write(IOVTK,'(a,i)') "CELL_TYPES ",nspec
- write(IOVTK,*) (12,ispec=1,nspec)
- write(IOVTK,*) ""
-
- write(IOVTK,'(a,i)') "CELL_DATA ",nspec
- write(IOVTK,'(a)') "SCALARS elem_flag integer"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do ispec = 1,nspec
- write(IOVTK,*) elem_flag(ispec)
- enddo
- write(IOVTK,*) ""
- close(IOVTK)
-
- end subroutine save_arrays_solver_ext_mesh_elem_vtk
-
-
!=============================================================
-
-! external mesh routine for saving vtk files for values on all gll points
-
- subroutine save_arrays_solver_ext_mesh_glldata_vtk(nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- gll_data,prname_file)
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,nglob
-
-! global coordinates
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
-
-! gll data values array
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: gll_data
-
-! masking arrays (takes first data value assigned on a global point, ignores any data values later on for the same global point)
- real, dimension(:),allocatable :: flag_val
- logical, dimension(:),allocatable :: mask_ibool
-
-! file name
- character(len=150) prname_file
-
- integer :: ispec,i,j,k,ier,iglob
-
-! write source and receiver VTK files for Paraview
- write(IMAIN,*) ' vtk file: ',prname_file(1:len_trim(prname_file))//'.vtk'
-
- open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
- write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
- write(IOVTK,'(a)') 'material model VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i,a)') 'POINTS ', nglob, ' float'
- do i=1,nglob
- write(IOVTK,'(3f)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
- enddo
- write(IOVTK,*) ""
-
- ! note: indices for vtk start at 0
- write(IOVTK,'(a,i,i)') "CELLS ",nspec,nspec*9
- do ispec=1,nspec
- write(IOVTK,'(9i)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
- ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
- enddo
- write(IOVTK,*) ""
-
- ! type: hexahedrons
- write(IOVTK,'(a,i)') "CELL_TYPES ",nspec
- write(IOVTK,*) (12,ispec=1,nspec)
- write(IOVTK,*) ""
-
- ! iflag field on global nodeset
- allocate(mask_ibool(nglob),flag_val(nglob),stat=ier)
- if( ier /= 0 ) stop 'error allocating mask'
-
- mask_ibool = .false.
- do ispec=1,nspec
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- if( .not. mask_ibool(iglob) ) then
- flag_val(iglob) = gll_data(i,j,k,ispec)
- mask_ibool(iglob) = .true.
- endif
- enddo
- enddo
- enddo
- enddo
-
- write(IOVTK,'(a,i)') "POINT_DATA ",nglob
- write(IOVTK,'(a)') "SCALARS gll_data float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do i = 1,nglob
- write(IOVTK,*) flag_val(i)
- enddo
- write(IOVTK,*) ""
-
- close(IOVTK)
-
-
- end subroutine save_arrays_solver_ext_mesh_glldata_vtk
-
-!=============================================================
!
!! old way
!! regular mesh
@@ -590,7 +514,7 @@
! integer i,j,k,ispec,iglob
!
!! processor identification
-! character(len=150) prname
+! character(len=256) prname
!
!! xix
! open(unit=27,file=prname(1:len_trim(prname))//'xix.bin',status='unknown',form='unformatted')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -45,7 +45,7 @@
double precision :: static_memory_size
- character(len=150) HEADER_FILE
+ character(len=256) HEADER_FILE
integer :: nfaces_surface_glob_ext_mesh
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -301,6 +301,20 @@
!----
!
+ subroutine any_all_l(sendbuf, recvbuf)
+
+ implicit none
+
+ logical sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine any_all_l
+
+!
+!----
+!
+
subroutine sendrecv_all_cr(sendbuf, sendcount, dest, sendtag, &
recvbuf, recvcount, source, recvtag)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -29,6 +29,7 @@
use specfem_par
implicit none
+ integer :: i,j
if(myrank == 0) then
write(IMAIN,*) '******************************************'
@@ -37,7 +38,7 @@
write(IMAIN,*)
endif
-! set up GLL points, weights and derivation matrices
+! set up GLL points, weights and derivation matrices for reference element (between -1,1)
call define_derivation_matrices(xigll,yigll,zigll,wxgll,wygll,wzgll, &
hprime_xx,hprime_yy,hprime_zz, &
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -31,13 +31,18 @@
use specfem_par
use specfem_par_movie
-
implicit none
-
+
+ integer :: i,j,k,ispec,iglob
+ integer :: ipoin,nfaces_org
+ character(len=256):: filename
+
! initializes mesh arrays for movies and shakemaps
allocate(nfaces_perproc_surface_ext_mesh(NPROC))
allocate(faces_surface_offset_ext_mesh(NPROC))
+ nfaces_org = nfaces_surface_external_mesh
if (nfaces_surface_external_mesh == 0) then
+ ! dummy arrays
if (USE_HIGHRES_FOR_MOVIES) then
allocate(faces_surface_external_mesh(NGLLX*NGLLY,1))
allocate(store_val_x_external_mesh(NGLLX*NGLLY*1))
@@ -74,6 +79,9 @@
allocate(store_val_uz_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
endif
endif
+ store_val_ux_external_mesh(:) = 0._CUSTOM_REAL
+ store_val_uy_external_mesh(:) = 0._CUSTOM_REAL
+ store_val_uz_external_mesh(:) = 0._CUSTOM_REAL
! number of surface faces for all partitions together
call sum_all_i(nfaces_surface_external_mesh,nfaces_surface_glob_ext_mesh)
@@ -97,6 +105,7 @@
endif
call gather_all_i(nfaces_surface_external_mesh,1,nfaces_perproc_surface_ext_mesh,1,NPROC)
+ ! array offsets
faces_surface_offset_ext_mesh(1) = 0
do i = 2, NPROC
faces_surface_offset_ext_mesh(i) = sum(nfaces_perproc_surface_ext_mesh(1:i-1))
@@ -108,125 +117,168 @@
endif
! stores global indices of GLL points on the surface to array faces_surface_external_mesh
- nfaces_surface_external_mesh = 0
- do ispec = 1, NSPEC_AB
- if (ispec_is_surface_external_mesh(ispec)) then
- iglob = ibool(2,2,1,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do j = NGLLY, 1, -1
- do i = 1, NGLLX
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,j,1,ispec)
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
+
+ allocate( faces_surface_external_mesh_ispec(nfaces_surface_external_mesh))
+
+ ! stores global indices
+ nfaces_surface_external_mesh = 0
+ do ispec = 1, NSPEC_AB
+
+ if (ispec_is_surface_external_mesh(ispec)) then
+
+ ! zmin face
+ iglob = ibool(2,2,1,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do j = NGLLY, 1, -1
+ do i = 1, NGLLX
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,j,1,ispec)
+ enddo
enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
+ endif
endif
- endif
- iglob = ibool(2,2,NGLLZ,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do j = 1, NGLLY
- do i = 1, NGLLX
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,j,NGLLZ,ispec)
+ ! zmax face
+ iglob = ibool(2,2,NGLLZ,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,j,NGLLZ,ispec)
+ enddo
enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ endif
endif
- endif
- iglob = ibool(2,1,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do k = 1, NGLLZ
- do i = 1, NGLLX
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,1,k,ispec)
+ ! ymin face
+ iglob = ibool(2,1,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,1,k,ispec)
+ enddo
enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
+ endif
endif
- endif
- iglob = ibool(2,NGLLY,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do k = 1, NGLLZ
- do i = NGLLX, 1, -1
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,NGLLY,k,ispec)
+ ! ymax face
+ iglob = ibool(2,NGLLY,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do i = NGLLX, 1, -1
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,NGLLY,k,ispec)
+ enddo
enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ endif
endif
- endif
- iglob = ibool(1,2,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do k = 1, NGLLZ
- do j = NGLLY, 1, -1
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(1,j,k,ispec)
- enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ ! xmin face
+ iglob = ibool(1,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do j = NGLLY, 1, -1
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(1,j,k,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ endif
endif
- endif
- iglob = ibool(NGLLX,2,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do k = 1, NGLLZ
- do j = 1, NGLLY
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(NGLLX,j,k,ispec)
- enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ ! xmax face
+ iglob = ibool(NGLLX,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(NGLLX,j,k,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ endif
endif
endif
-
+ enddo ! NSPEC_AB
+
+ ! checks number of faces
+ if( nfaces_surface_external_mesh /= nfaces_org ) then
+ print*,'error number of movie faces: ',nfaces_surface_external_mesh,nfaces_org
+ call exit_mpi(myrank,'error number of faces')
endif
- enddo ! NSPEC_AB
-
+ endif
+
+ ! user output
if (myrank == 0) then
+ if( PLOT_CROSS_SECTIONS ) write(IMAIN,*) 'movie: cross-sections'
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
+
+ ! updates number of surface elements in an include file for the movies
+ if( nfaces_surface_glob_ext_mesh > 0 ) then
+ filename = 'OUTPUT_FILES/surface_from_mesher.h'
+ open(unit=IOUT,file=trim(filename),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
+
endif
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -31,16 +31,56 @@
implicit none
! write source and receiver VTK files for Paraview
- if (myrank == 0) then
- open(IOVTK,file=trim(OUTPUT_FILES)//'/sr.vtk',status='unknown')
- write(IOVTK,'(a)') '# vtk DataFile Version 2.0'
- write(IOVTK,'(a)') 'Source and Receiver VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET POLYDATA'
- ! LQY -- cannot figure out NSOURCES+nrec at this point
- write(IOVTK, '(a,i6,a)') 'POINTS ', 2, ' float'
+! if (myrank == 0) then
+! open(IOVTK,file=trim(OUTPUT_FILES)//'/sr.vtk',status='unknown')
+! write(IOVTK,'(a)') '# vtk DataFile Version 2.0'
+! write(IOVTK,'(a)') 'Source and Receiver VTK file'
+! write(IOVTK,'(a)') 'ASCII'
+! write(IOVTK,'(a)') 'DATASET POLYDATA'
+! ! LQY -- cannot figure out NSOURCES+nrec at this point
+! write(IOVTK, '(a,i6,a)') 'POINTS ', 2, ' float'
+! endif
+
+! locates sources and determines simulation start time t0
+ call setup_sources()
+
+! reads in stations file and locates receivers
+ call setup_receivers()
+
+! pre-compute source arrays
+ call setup_sources_precompute_arrays()
+
+! pre-compute receiver interpolation factors
+ call setup_receivers_precompute_interpolations()
+
+! write source and receiver VTK files for Paraview
+ call setup_sources_receivers_VTKfile()
+
+! user output
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP
+ write(IMAIN,*)
+ write(IMAIN,*)
+ write(IMAIN,*) 'found a total of ',nrec_tot_found,' receivers in all the slices'
+ if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
endif
+end subroutine setup_sources_receivers
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine setup_sources()
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ implicit none
+
+ integer :: yr,jda,ho,mi
+
! allocate arrays for source
allocate(islice_selected_source(NSOURCES))
allocate(ispec_selected_source(NSOURCES))
@@ -61,6 +101,9 @@
allocate(nu_source(3,3,NSOURCES))
! locate sources in the mesh
+!
+! returns: islice_selected_source & ispec_selected_source,
+! xi_source, eta_source & gamma_source
call locate_source(ibool,NSOURCES,myrank,NSPEC_AB,NGLOB_AB, &
xstore,ystore,zstore,xigll,yigll,zigll,NPROC, &
sec,t_cmt,yr,jda,ho,mi,utm_x_source,utm_y_source, &
@@ -69,7 +112,8 @@
xi_source,eta_source,gamma_source, &
TOPOGRAPHY,UTM_PROJECTION_ZONE, &
PRINT_SOURCE_TIME_FUNCTION, &
- nu_source,iglob_is_surface_external_mesh,ispec_is_surface_external_mesh)
+ nu_source,iglob_is_surface_external_mesh,ispec_is_surface_external_mesh,&
+ ispec_is_acoustic,ispec_is_elastic)
if(minval(t_cmt) /= 0.) call exit_MPI(myrank,'one t_cmt must be zero, others must be positive')
@@ -82,14 +126,232 @@
write(IMAIN,*)
endif
endif
+
! convert the half duration for triangle STF to the one for gaussian STF
hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
! define t0 as the earliest start time
t0 = - 1.5d0 * minval(t_cmt-hdur)
-!$$$$$$$$$$$$$$$$$$ RECEIVERS $$$$$$$$$$$$$$$$$$$$$
+! checks if source is in an acoustic element and exactly on the free surface because pressure is zero there
+ call setup_sources_check_acoustic()
+
+end subroutine setup_sources
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine setup_sources_check_acoustic()
+
+! checks if source is in an acoustic element and exactly on the free surface because pressure is zero there
+
+ use specfem_par
+ use specfem_par_acoustic
+ implicit none
+
+ integer :: isource,ixmin,ixmax,iymin,iymax,izmin,izmax,iface,ispec
+ logical :: is_on
+
+! outputs a warning in case of an acoustic source lying on the free surface
+ do isource = 1,NSOURCES
+ ! only receivers in this process
+ if( myrank == islice_selected_source(isource) ) then
+
+ ispec = ispec_selected_source(isource)
+ ! only if receiver is in an acoustic element
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! checks with free surface face
+ do iface = 1,num_free_surface_faces
+
+ if( ispec == free_surface_ispec(iface) ) then
+
+ ! determine face
+ ixmin = minval( free_surface_ijk(1,:,iface) )
+ ixmax = maxval( free_surface_ijk(1,:,iface) )
+
+ iymin = minval( free_surface_ijk(2,:,iface) )
+ iymax = maxval( free_surface_ijk(2,:,iface) )
+
+ izmin = minval( free_surface_ijk(3,:,iface) )
+ izmax = maxval( free_surface_ijk(3,:,iface) )
+
+ ! checks if receiver is close to face
+ is_on = .false.
+
+ if( .not. USE_FORCE_POINT_SOURCE ) then
+ ! xmin face
+ if(ixmin==1 .and. ixmax==1) then
+ if( xi_source(isource) < -0.99d0) is_on = .true.
+ ! xmax face
+ else if(ixmin==NGLLX .and. ixmax==NGLLX) then
+ if( xi_source(isource) > 0.99d0) is_on = .true.
+ ! ymin face
+ else if(iymin==1 .and. iymax==1) then
+ if( eta_source(isource) < -0.99d0) is_on = .true.
+ ! ymax face
+ else if(iymin==NGLLY .and. iymax==NGLLY) then
+ if( eta_source(isource) > 0.99d0) is_on = .true.
+ ! zmin face
+ else if(izmin==1 .and. izmax==1 ) then
+ if( gamma_source(isource) < -0.99d0) is_on = .true.
+ ! zmax face
+ else if(izmin==NGLLZ .and. izmax==NGLLZ ) then
+ if( gamma_source(isource) > 0.99d0) is_on = .true.
+ endif
+ else
+ ! note: for use_force_point_source xi/eta/gamma_source values are in the range [1,NGLL*]
+ ! xmin face
+ if(ixmin==1 .and. ixmax==1) then
+ if( nint(xi_source(isource)) == 1) is_on = .true.
+ ! xmax face
+ else if(ixmin==NGLLX .and. ixmax==NGLLX) then
+ if( nint(xi_source(isource)) == NGLLX) is_on = .true.
+ ! ymin face
+ else if(iymin==1 .and. iymax==1) then
+ if( nint(eta_source(isource)) == 1) is_on = .true.
+ ! ymax face
+ else if(iymin==NGLLY .and. iymax==NGLLY) then
+ if( nint(eta_source(isource)) == NGLLY) is_on = .true.
+ ! zmin face
+ else if(izmin==1 .and. izmax==1 ) then
+ if( nint(gamma_source(isource)) == 1) is_on = .true.
+ ! zmax face
+ else if(izmin==NGLLZ .and. izmax==NGLLZ ) then
+ if( nint(gamma_source(isource)) ==NGLLZ) is_on = .true.
+ endif
+ endif
+
+ ! user output
+ if( is_on ) then
+ print*, '**********************************************************************'
+ print*, '*** source: ',isource,'in rank:',myrank,' ***'
+ print*, '*** Warning: acoustic source located exactly on the free surface ***'
+ print*, '*** will be zeroed ***'
+ print*, '**********************************************************************'
+ print*
+ endif
+ endif ! free_surface_ispec
+ enddo ! iface
+ endif ! ispec_is_acoustic
+ endif ! islice_selected_rec
+ enddo ! num_free_surface_faces
+
+
+end subroutine setup_sources_check_acoustic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine setup_sources_precompute_arrays()
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ implicit none
+
+ integer :: isource,ispec
+ real(kind=CUSTOM_REAL) :: factor_source
+
+! forward simulations
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ allocate(sourcearray(NDIM,NGLLX,NGLLY,NGLLZ))
+ allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ))
+
+ ! compute source arrays
+ do isource = 1,NSOURCES
+
+ ! check that the source slice number is okay
+ if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROC-1) &
+ call exit_MPI(myrank,'something is wrong with the source slice number')
+
+ ! compute source arrays in source slice
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ ! elastic moment tensor source
+ if( ispec_is_elastic(ispec) ) then
+ call compute_arrays_source(ispec, &
+ xi_source(isource),eta_source(isource),gamma_source(isource),sourcearray, &
+ Mxx(isource),Myy(isource),Mzz(isource),Mxy(isource),Mxz(isource),Myz(isource), &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ xigll,yigll,zigll,NSPEC_AB)
+ endif
+
+ ! acoustic case
+ if( ispec_is_acoustic(ispec) ) then
+ ! scalar moment of moment tensor values read in from CMTSOLUTION
+ ! note: M0 by Dahlen and Tromp, eq. 5.91
+ factor_source = 1.0/sqrt(2.0) * sqrt( Mxx(isource)**2 + Myy(isource)**2 + Mzz(isource)**2 &
+ + 2*( Myz(isource)**2 + Mxz(isource)**2 + Mxy(isource)**2 ) )
+
+ ! scales source such that it would be equivalent to explosion source moment tensor,
+ ! where Mxx=Myy=Mzz, others Mxy,.. = zero, in equivalent elastic media
+ ! (and getting rid of 1/sqrt(2) factor from scalar moment tensor definition above)
+ factor_source = factor_source * sqrt(2.0) / sqrt(3.0)
+
+ ! source array interpolated on all element gll points
+ call compute_arrays_source_acoustic(xi_source(isource),eta_source(isource),gamma_source(isource),&
+ sourcearray,xigll,yigll,zigll,factor_source)
+ endif
+
+ ! stores source excitations
+ sourcearrays(isource,:,:,:,:) = sourcearray(:,:,:,:)
+
+ endif
+ enddo
+ endif
+
+ ! adjoint simulations
+ ! if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+ ! nadj_rec_local = 0
+ ! do irec = 1,nrec
+ ! if(myrank == islice_selected_rec(irec))then
+ !! check that the source slice number is okay
+ ! if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROC-1) &
+ ! call exit_MPI(myrank,'something is wrong with the source slice number in adjoint simulation')
+ ! nadj_rec_local = nadj_rec_local + 1
+ ! endif
+ ! enddo
+ ! allocate(adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
+ ! if (nadj_rec_local > 0) allocate(adj_sourcearrays(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
+ ! irec_local = 0
+ ! do irec = 1, nrec
+ !! compute only adjoint source arrays in the local slice
+ ! if(myrank == islice_selected_rec(irec)) then
+ ! irec_local = irec_local + 1
+ ! adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+ ! call compute_arrays_adjoint_source(myrank, adj_source_file, &
+ ! xi_receiver(irec), eta_receiver(irec), gamma_receiver(irec), &
+ ! adj_sourcearray, xigll,yigll,zigll,NSTEP)
+ !
+ ! adj_sourcearrays(irec_local,:,:,:,:,:) = adj_sourcearray(:,:,:,:,:)
+ !
+ ! endif
+ ! enddo
+ ! endif
+
+end subroutine setup_sources_precompute_arrays
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine setup_receivers()
+
+ use specfem_par
+ use specfem_par_acoustic
+ implicit none
+
+ integer :: irec,isource,ios
+
+! reads in station file
if (SIMULATION_TYPE == 1) then
call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS')
@@ -143,62 +405,6 @@
TOPOGRAPHY,UTM_PROJECTION_ZONE, &
iglob_is_surface_external_mesh,ispec_is_surface_external_mesh )
-
-!###################### SOURCE ARRAYS ################
-
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- allocate(sourcearray(NDIM,NGLLX,NGLLY,NGLLZ))
- allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ))
-
-! compute source arrays
- do isource = 1,NSOURCES
-
-! check that the source slice number is okay
- if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROC-1) &
- call exit_MPI(myrank,'something is wrong with the source slice number')
-
-! compute source arrays in source slice
- if(myrank == islice_selected_source(isource)) then
- call compute_arrays_source(ispec_selected_source(isource), &
- xi_source(isource),eta_source(isource),gamma_source(isource),sourcearray, &
- Mxx(isource),Myy(isource),Mzz(isource),Mxy(isource),Mxz(isource),Myz(isource), &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- xigll,yigll,zigll,NSPEC_AB)
- sourcearrays(isource,:,:,:,:) = sourcearray(:,:,:,:)
- endif
- enddo
- endif
-
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- nadj_rec_local = 0
- do irec = 1,nrec
- if(myrank == islice_selected_rec(irec))then
-! check that the source slice number is okay
- if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROC-1) &
- call exit_MPI(myrank,'something is wrong with the source slice number in adjoint simulation')
- nadj_rec_local = nadj_rec_local + 1
- endif
- enddo
- allocate(adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
- if (nadj_rec_local > 0) allocate(adj_sourcearrays(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
- irec_local = 0
- do irec = 1, nrec
-! compute only adjoint source arrays in the local slice
- if(myrank == islice_selected_rec(irec)) then
- irec_local = irec_local + 1
- adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
- call compute_arrays_adjoint_source(myrank, adj_source_file, &
- xi_receiver(irec), eta_receiver(irec), gamma_receiver(irec), &
- adj_sourcearray, xigll,yigll,zigll,NSTEP)
-
- adj_sourcearrays(irec_local,:,:,:,:,:) = adj_sourcearray(:,:,:,:,:)
-
- endif
- enddo
- endif
-
-!--- select local receivers
-
! count number of receivers located in this slice
nrec_local = 0
if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
@@ -207,12 +413,111 @@
if(myrank == islice_selected_rec(irec)) nrec_local = nrec_local + 1
enddo
else
+ ! adjoint simulation: receivers become adjoint sources
nrec_simulation = NSOURCES
do isource = 1, NSOURCES
if(myrank == islice_selected_source(isource)) nrec_local = nrec_local + 1
enddo
endif
+! checks if acoustic receiver is exactly on the free surface because pressure is zero there
+ call setup_receivers_check_acoustic()
+
+end subroutine setup_receivers
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine setup_receivers_check_acoustic()
+
+! checks if acoustic receiver is exactly on the free surface because pressure is zero there
+
+ use specfem_par
+ use specfem_par_acoustic
+ implicit none
+
+ integer :: irec,ixmin,ixmax,iymin,iymax,izmin,izmax,iface,ispec
+ logical :: is_on
+
+! outputs a warning in case the receiver is lying on the free surface
+ do irec = 1,nrec
+ ! only receivers in this process
+ if( myrank == islice_selected_rec(irec) ) then
+
+ ispec = ispec_selected_rec(irec)
+ ! only if receiver is in an acoustic element
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! checks with free surface face
+ do iface = 1,num_free_surface_faces
+
+ if( ispec == free_surface_ispec(iface) ) then
+
+ ! determine face
+ ixmin = minval( free_surface_ijk(1,:,iface) )
+ ixmax = maxval( free_surface_ijk(1,:,iface) )
+
+ iymin = minval( free_surface_ijk(2,:,iface) )
+ iymax = maxval( free_surface_ijk(2,:,iface) )
+
+ izmin = minval( free_surface_ijk(3,:,iface) )
+ izmax = maxval( free_surface_ijk(3,:,iface) )
+
+ ! checks if receiver is close to face
+ is_on = .false.
+
+ ! xmin face
+ if(ixmin==1 .and. ixmax==1) then
+ if( xi_receiver(irec) < -0.99d0) is_on = .true.
+ ! xmax face
+ else if(ixmin==NGLLX .and. ixmax==NGLLX) then
+ if( xi_receiver(irec) > 0.99d0) is_on = .true.
+ ! ymin face
+ else if(iymin==1 .and. iymax==1) then
+ if( eta_receiver(irec) < -0.99d0) is_on = .true.
+ ! ymax face
+ else if(iymin==NGLLY .and. iymax==NGLLY) then
+ if( eta_receiver(irec) > 0.99d0) is_on = .true.
+ ! zmin face
+ else if(izmin==1 .and. izmax==1 ) then
+ if( gamma_receiver(irec) < -0.99d0) is_on = .true.
+ ! zmax face
+ else if(izmin==NGLLZ .and. izmax==NGLLZ ) then
+ if( gamma_receiver(irec) > 0.99d0) is_on = .true.
+ endif
+
+ ! user output
+ if( is_on ) then
+ print*, '**********************************************************************'
+ print*, '*** receiver:',irec,'in rank:',myrank,' ***'
+ print*, '*** Warning: acoustic receiver located exactly on the free surface ***'
+ print*, '*** Warning: tangential component will be zero there ***'
+ print*, '**********************************************************************'
+ print*
+ endif
+ endif ! free_surface_ispec
+ enddo ! iface
+ endif ! ispec_is_acoustic
+ endif ! islice_selected_rec
+ enddo ! num_free_surface_faces
+
+end subroutine setup_receivers_check_acoustic
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine setup_receivers_precompute_interpolations()
+
+ use specfem_par
+ implicit none
+
+ integer :: irec,irec_local,isource
+
+! stores local receivers interpolation factors
if (nrec_local > 0) then
! allocate Lagrange interpolators for receivers
allocate(hxir_store(nrec_local,NGLLX))
@@ -270,23 +575,142 @@
! check that the sum of the number of receivers in each slice is nrec
call sum_all_i(nrec_local,nrec_tot_found)
- if(myrank == 0) then
-
- close(IOVTK)
-
- write(IMAIN,*)
- write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP
- write(IMAIN,*)
- write(IMAIN,*)
- write(IMAIN,*) 'found a total of ',nrec_tot_found,' receivers in all the slices'
+ if( myrank == 0 ) then
if(nrec_tot_found /= nrec_simulation) then
call exit_MPI(myrank,'problem when dispatching the receivers')
- else
- write(IMAIN,*) 'this total is okay'
endif
+ endif
+
+
+end subroutine setup_receivers_precompute_interpolations
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine setup_sources_receivers_VTKfile()
+
+ use specfem_par
+ implicit none
+
+ double precision :: shape3D(NGNOD)
+ double precision :: xil,etal,gammal
+ double precision :: xmesh,ymesh,zmesh
+
+ real(kind=CUSTOM_REAL),dimension(NGNOD) :: xelm,yelm,zelm
+
+ integer :: ia,ispec,isource,irec
+
+ if (myrank == 0) then
+ ! vtk file
+ open(IOVTK,file=trim(OUTPUT_FILES)//'/sr.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 2.0'
+ write(IOVTK,'(a)') 'Source and Receiver VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET POLYDATA'
+ write(IOVTK, '(a,i6,a)') 'POINTS ', NSOURCES+nrec, ' float'
+ endif
+
+ ! sources
+ do isource=1,NSOURCES
+ ! spectral element id
+ ispec = ispec_selected_source(isource)
- if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
+ ! gets element ancor nodes
+ if( myrank == islice_selected_source(isource) ) then
+ ! find the coordinates of the eight corner nodes of the element
+ call get_shape3D_element_corners(xelm,yelm,zelm,ispec,&
+ ibool,xstore,ystore,zstore,NSPEC_AB,NGLOB_AB)
+
+ endif
+ ! master collects corner locations
+ if( islice_selected_source(isource) /= 0 ) then
+ if( myrank == 0 ) then
+ call recvv_cr(xelm,NGNOD,islice_selected_source(isource),0)
+ call recvv_cr(yelm,NGNOD,islice_selected_source(isource),0)
+ call recvv_cr(zelm,NGNOD,islice_selected_source(isource),0)
+ else if( myrank == islice_selected_source(isource) ) then
+ call sendv_cr(xelm,NGNOD,0,0)
+ call sendv_cr(yelm,NGNOD,0,0)
+ call sendv_cr(zelm,NGNOD,0,0)
+ endif
+ endif
+ if( myrank == 0 ) then
+ ! get the 3-D shape functions
+ xil = xi_source(isource)
+ etal = eta_source(isource)
+ gammal = gamma_source(isource)
+ call get_shape3D_single(myrank,shape3D,xil,etal,gammal)
+
+ ! interpolates source locations
+ xmesh = 0.0
+ ymesh = 0.0
+ zmesh = 0.0
+ do ia=1,NGNOD
+ xmesh = xmesh + shape3D(ia)*xelm(ia)
+ ymesh = ymesh + shape3D(ia)*yelm(ia)
+ zmesh = zmesh + shape3D(ia)*zelm(ia)
+ enddo
+
+ ! writes out to VTK file
+ write(IOVTK,*) xmesh,ymesh,zmesh
+ endif
+ enddo ! NSOURCES
+
+ ! receivers
+ do irec=1,nrec
+ ispec = ispec_selected_rec(irec)
+
+ ! find the coordinates of the eight corner nodes of the element
+ if( myrank == islice_selected_rec(irec) ) then
+ call get_shape3D_element_corners(xelm,yelm,zelm,ispec,&
+ ibool,xstore,ystore,zstore,NSPEC_AB,NGLOB_AB)
+ endif
+ ! master collects corner locations
+ if( islice_selected_rec(irec) /= 0 ) then
+ if( myrank == 0 ) then
+ call recvv_cr(xelm,NGNOD,islice_selected_rec(irec),0)
+ call recvv_cr(yelm,NGNOD,islice_selected_rec(irec),0)
+ call recvv_cr(zelm,NGNOD,islice_selected_rec(irec),0)
+ else if( myrank == islice_selected_rec(irec) ) then
+ call sendv_cr(xelm,NGNOD,0,0)
+ call sendv_cr(yelm,NGNOD,0,0)
+ call sendv_cr(zelm,NGNOD,0,0)
+ endif
+ endif
+
+ if( myrank == 0 ) then
+ ! get the 3-D shape functions
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ xil = xi_receiver(irec)
+ etal = eta_receiver(irec)
+ gammal = gamma_receiver(irec)
+ else
+ xil = xi_source(irec)
+ etal = eta_source(irec)
+ gammal = gamma_source(irec)
+ endif
+ call get_shape3D_single(myrank,shape3D,xil,etal,gammal)
+
+ ! interpolates receiver locations
+ xmesh = 0.0
+ ymesh = 0.0
+ zmesh = 0.0
+ do ia=1,NGNOD
+ xmesh = xmesh + shape3D(ia)*xelm(ia)
+ ymesh = ymesh + shape3D(ia)*yelm(ia)
+ zmesh = zmesh + shape3D(ia)*zelm(ia)
+ enddo
+
+ ! writes out to VTK file
+ write(IOVTK,*) xmesh,ymesh,zmesh
+ endif
+ enddo
+
+ ! closes vtk file
+ if( myrank == 0 ) then
+ write(IOVTK,*)
+ close(IOVTK)
endif
- end subroutine
\ No newline at end of file
+end subroutine setup_sources_receivers_VTKfile
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/sort_array_coordinates.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/sort_array_coordinates.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/sort_array_coordinates.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -31,6 +31,8 @@
! this routine MUST be in double precision to avoid sensitivity
! to roundoff errors in the coordinates of the points
+!
+! returns: sorted indexing array (ibool), reordering array (iglob) & number of global points (nglob)
implicit none
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -194,7 +194,7 @@
call read_mesh_databases()
-! creates GLL points
+! sets up reference element GLL points/weights/derivatives
call setup_GLL_points()
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -41,14 +41,6 @@
implicit none
-! include "constants.h"
-
-! include values created by the mesher
- include "OUTPUT_FILES/values_from_mesher.h"
-
-! 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
@@ -56,8 +48,8 @@
real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: factor_scale,one_minus_sum_beta
real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: tauinv,factor_common, alphaval,betaval,gammaval
- integer iattenuation
- double precision scale_factor
+! integer iattenuation
+! double precision scale_factor
real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: &
R_xx,R_yy,R_xy,R_xz,R_yz
@@ -68,53 +60,36 @@
integer, dimension(:,:,:,:),allocatable :: iflag_attenuation_store
! ADJOINT
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: b_alphaval, b_betaval, b_gammaval
-!! DK DK array not created yet for CUBIT
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS) :: &
-! b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL) :: b_epsilondev_xx, &
-! b_epsilondev_yy,b_epsilondev_xy,b_epsilondev_xz,b_epsilondev_yz
-! ADJOINT
+ !real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: b_alphaval, b_betaval, b_gammaval
+ !! DK DK array not created yet for CUBIT
+ ! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS) :: &
+ ! b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz
+ ! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL) :: b_epsilondev_xx, &
+ ! b_epsilondev_yy,b_epsilondev_xy,b_epsilondev_xz,b_epsilondev_yz
+ ! ADJOINT
! use integer array to store topography values
- integer NX_TOPO,NY_TOPO
- double precision ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
- character(len=100) topo_file
+ integer :: NX_TOPO,NY_TOPO
+ double precision :: ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
+ character(len=100) :: topo_file
integer, dimension(:,:), allocatable :: itopo_bathy
-! absorbing boundaries
-! integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax
-! integer, dimension(:), allocatable :: ibelm_ymin,ibelm_ymax
-! integer, dimension(:), allocatable :: ibelm_bottom
-! integer, dimension(:), allocatable :: ibelm_top
-!! integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
-! ! local indices i,j,k of all GLL points on xmin boundary in the element
-! integer,dimension(:,:,:,:),allocatable :: ibelm_gll_xmin,ibelm_gll_xmax, &
-! ibelm_gll_ymin,ibelm_gll_ymax, &
-! ibelm_gll_bottom,ibelm_gll_top
-! real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_xmin,jacobian2D_xmax
-! real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_ymin,jacobian2D_ymax
-! real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_bottom
-! real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_top
-! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_xmin,normal_xmax
-! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_ymin,normal_ymax
-! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_bottom
-! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_top
-
! absorbing boundary arrays (for all boundaries) - keeps all infos, allowing for irregular surfaces
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: absorbing_boundary_normal
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: absorbing_boundary_jacobian2D
- integer, dimension(:,:,:), allocatable :: absorbing_boundary_ijk
- integer, dimension(:), allocatable :: absorbing_boundary_ispec
- integer :: num_absorbing_boundary_faces
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: abs_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: abs_boundary_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: abs_boundary_ijk
+ integer, dimension(:), allocatable :: abs_boundary_ispec
+ integer :: num_abs_boundary_faces
-! free surface
- integer :: nspec2D_top,ispec2D
- integer, dimension(:), allocatable :: ibelm_top
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_top
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_top
- real(kind=CUSTOM_REAL) :: nx,ny,nz
+! free surface arrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: free_surface_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: free_surface_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: free_surface_ijk
+ integer, dimension(:), allocatable :: free_surface_ispec
+ integer :: num_free_surface_faces
+ !real(kind=CUSTOM_REAL) :: nx,ny,nz
+
!! DK DK array not created yet for CUBIT
! integer, dimension(NSPEC2D_TOP_VAL) :: ibelm_top
! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_VAL) :: normal_top
@@ -133,48 +108,37 @@
! mesh parameters
integer, dimension(:,:,:,:), allocatable :: ibool
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore,ystore,zstore
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore,ystore,zstore
! material properties
! isotropic
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- kappastore,mustore
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: kappastore,mustore
-
-! flag for sediments
-! logical, dimension(:), allocatable :: not_fully_in_bedrock
-! logical, dimension(:,:,:,:), allocatable :: flag_sediments
-
-
-! local to global mapping
-! integer, dimension(:), allocatable :: idoubling
-
! 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
+ !logical, dimension(:), allocatable :: updated_dof_ocean_load
+ !real(kind=CUSTOM_REAL) additional_term,force_normal_comp
! 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(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, &
-! absorb_ymin, absorb_ymax, absorb_zmin ! for absorbing b.c.
-! integer reclen_xmin, reclen_xmax, reclen_ymin, reclen_ymax, reclen_zmin
+ !real(kind=CUSTOM_REAL) b_additional_term,b_force_normal_comp
+ !! DK DK array not created yet for CUBIT
+ ! 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, &
+ ! absorb_ymin, absorb_ymax, absorb_zmin ! for absorbing b.c.
+ ! integer reclen_xmin, reclen_xmax, reclen_ymin, reclen_ymax, reclen_zmin
+ !real(kind=CUSTOM_REAL) b_deltat, b_deltatover2, b_deltatsqover2
+ ! ADJOINT
- real(kind=CUSTOM_REAL) b_deltat, b_deltatover2, b_deltatsqover2
-! ADJOINT
+! integer l
- integer l
-
! Moho kernel
! integer ispec2D_moho_top, ispec2D_moho_bot, k_top, k_bot, ispec_top, ispec_bot, iglob_top, iglob_bot
!! DK DK array not created yet for CUBIT
@@ -184,19 +148,22 @@
! --------
+! time loop step
+ integer :: it
+
! parameters for the source
- integer it,isource
+ !integer :: isource
integer, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
- integer yr,jda,ho,mi
+ !integer :: yr,jda,ho,mi
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: sourcearray
real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
double precision, dimension(:,:,:), allocatable :: nu_source
!ADJOINT
- character(len=150) adj_source_file
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearray
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: adj_sourcearrays
+! character(len=256) adj_source_file
+! real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearray
+! real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: adj_sourcearrays
!ADJOINT
- double precision sec,stf
+ double precision :: sec,stf
double precision, dimension(:), allocatable :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
double precision, dimension(:), allocatable :: xi_source,eta_source,gamma_source
double precision, dimension(:), allocatable :: t_cmt,hdur,hdur_gaussian
@@ -205,18 +172,20 @@
double precision :: t0
! receiver information
- character(len=150) rec_filename,filtered_rec_filename,dummystring
- integer nrec,nrec_local,nrec_tot_found,irec_local,ios
+ character(len=256) :: rec_filename,filtered_rec_filename,dummystring
+ integer :: nrec,nrec_local,nrec_tot_found !,irec_local,ios
+ integer :: nrec_simulation
integer, allocatable, dimension(:) :: islice_selected_rec,ispec_selected_rec,number_receiver_global
double precision, allocatable, dimension(:) :: xi_receiver,eta_receiver,gamma_receiver
- double precision hlagrange
+ double precision, dimension(:,:), allocatable :: hpxir_store,hpetar_store,hpgammar_store
+! double precision :: hlagrange
+
! ADJOINT
- integer nrec_simulation, nadj_rec_local
+ !integer :: nadj_rec_local
! source frechet derivatives
real(kind=CUSTOM_REAL) :: displ_s(NDIM,NGLLX,NGLLY,NGLLZ), eps_s(NDIM,NDIM), eps_m_s(NDIM), stf_deltat
real(kind=CUSTOM_REAL), dimension(:), allocatable :: Mxx_der,Myy_der,Mzz_der,Mxy_der,Mxz_der,Myz_der
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: sloc_der
- double precision, dimension(:,:), allocatable :: hpxir_store,hpetar_store,hpgammar_store
! ADJOINT
! timing information for the stations
@@ -225,11 +194,11 @@
character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
! seismograms
- double precision dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
+ !double precision dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms_d,seismograms_v,seismograms_a
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: seismograms_eps
- integer i,j,k,ispec,irec,iglob
+! integer i,j,k,ispec,irec,iglob
! Gauss-Lobatto-Legendre points of integration and weights
double precision, dimension(NGLLX) :: xigll,wxgll
@@ -248,61 +217,41 @@
double precision, dimension(:), allocatable :: hxir,hetar,hpxir,hpetar,hgammar,hpgammar
double precision, dimension(:,:), allocatable :: hxir_store,hetar_store,hgammar_store
-! 2-D addressing and buffers for summation between slices
-! integer, dimension(NPOIN2DMAX_XMIN_XMAX_VAL) :: iboolleft_xi,iboolright_xi
-! integer, dimension(NPOIN2DMAX_YMIN_YMAX_VAL) :: iboolleft_eta,iboolright_eta
-
-! for addressing of the slices
-! integer, dimension(0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL) :: addressing
-
! proc numbers for MPI
integer :: myrank
-! integer npoin2D_xi,npoin2D_eta
-
-! integer iproc_xi,iproc_eta
-
! timer MPI
double precision, external :: wtime
- integer :: ihours,iminutes,iseconds,int_tCPU, &
- ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
- ihours_total,iminutes_total,iseconds_total,int_t_total
- double precision :: time_start,tCPU,t_remain,t_total
+ double precision :: time_start
+ !integer :: ihours,iminutes,iseconds,int_tCPU, &
+ ! ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
+ ! ihours_total,iminutes_total,iseconds_total,int_t_total
! parameters read from parameter file
- integer NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
- integer NSOURCES
+ integer :: NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
+ integer :: NSOURCES
- double precision DT,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX,HDUR_MOVIE
+ double precision :: DT
+ double precision :: LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX,HDUR_MOVIE
- logical TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
+ logical :: TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
OCEANS,ABSORBING_CONDITIONS,SAVE_FORWARD
- logical ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+ logical :: ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
- logical MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
- integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+ integer :: NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
- character(len=150) OUTPUT_FILES,LOCAL_PATH,prname,prname_Q
+ character(len=256) OUTPUT_FILES,LOCAL_PATH,prname,prname_Q
! parameters deduced from parameters read from file
- integer NPROC
+ integer :: NPROC
- !integer :: NSPEC2D_BOTTOM
- !integer :: NSPEC2D_TOP
-
integer :: NSPEC_AB, NGLOB_AB
! names of the data files for all the processors in MPI
- character(len=150) outputname
+ character(len=256) outputname
-! Stacey conditions put back
- !integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,ispec2D
- !real(kind=CUSTOM_REAL) nx,ny,nz
- !integer, dimension(:,:),allocatable :: nimin,nimax,nkmin_eta
- !integer, dimension(:,:),allocatable :: njmin,njmax,nkmin_xi
-
-
! for assembling in case of external mesh
integer :: num_interfaces_ext_mesh
integer :: max_nibool_interfaces_ext_mesh
@@ -321,22 +270,21 @@
! for detecting surface receivers and source in case of external mesh
logical, dimension(:), allocatable :: iglob_is_surface_external_mesh
logical, dimension(:), allocatable :: ispec_is_surface_external_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
+! MPI partition surfaces
+ logical, dimension(:), allocatable :: ispec_is_inner
+ logical, dimension(:), allocatable :: iglob_is_inner
+ !integer :: iinterface
-! model surface
- logical, dimension(:), allocatable :: ispec_is_inner_ext_mesh
- logical, dimension(:), allocatable :: iglob_is_inner_ext_mesh
- integer :: iinterface
+! 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
+
+!daniel
! integer, dimension(:),allocatable :: spec_inner, spec_outer
! integer :: nspec_inner,nspec_outer
@@ -361,9 +309,9 @@
! 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
+ ! 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
@@ -379,24 +327,68 @@
c55store,c56store,c66store
integer :: NSPEC_ANISO
-! maximum of the norm of the displacement
- real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all
- integer:: Usolidnorm_index(1)
+! material flag
+ logical, dimension(:), allocatable :: ispec_is_elastic
-! ADJOINT
-! real(kind=CUSTOM_REAL) b_Usolidnorm, b_Usolidnorm_all
-! ADJOINT
+ logical :: ELASTIC_SIMULATION
-! attenuation Olsen
- real(kind=CUSTOM_REAL):: vs_val
- integer :: iselected
+end module specfem_par_elastic
+!=====================================================================
-end module specfem_par_elastic
+module specfem_par_acoustic
+! parameter module for elastic solver
+ use constants,only: CUSTOM_REAL
+ implicit none
+
+! potential
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: potential_acoustic, &
+ potential_dot_acoustic,potential_dot_dot_acoustic
+
+! density
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_acoustic
+
+! acoustic-elastic coupling surface
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: coupling_ac_el_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: coupling_ac_el_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: coupling_ac_el_ijk
+ integer, dimension(:), allocatable :: coupling_ac_el_ispec
+ integer :: num_coupling_ac_el_faces
+
+! material flag
+ logical, dimension(:), allocatable :: ispec_is_acoustic
+
+ logical :: ACOUSTIC_SIMULATION
+
+end module specfem_par_acoustic
+
!=====================================================================
+module specfem_par_poroelastic
+
+! parameter module for elastic solver
+
+ use constants,only: CUSTOM_REAL
+ implicit none
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_solid_poroelastic,rmass_fluid_poroelastic
+
+! material flag
+ logical, dimension(:), allocatable :: ispec_is_poroelastic
+
+ logical :: POROELASTIC_SIMULATION
+
+end module specfem_par_poroelastic
+
+
+!=====================================================================
+
module specfem_par_movie
! parameter module for movies/shakemovies
@@ -406,17 +398,18 @@
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
+ !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
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dvxdxl,dvxdyl,&
+ dvxdzl,dvydxl,dvydyl,dvydzl,dvzdxl,dvzdyl,dvzdzl
! shakemovies
real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_x_external_mesh
@@ -441,7 +434,17 @@
real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
- integer ipoin, nmovie_points, iloc, iorderi(NGNOD2D), iorderj(NGNOD2D)
+ !integer nmovie_points
+! for storing surface of external 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,dimension(:),allocatable :: faces_surface_external_mesh_ispec
+ integer :: nfaces_surface_external_mesh
+ integer :: nfaces_surface_glob_ext_mesh
+
+ integer :: iorderi(NGNOD2D),iorderj(NGNOD2D)
+
end module specfem_par_movie
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_global_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_global_data.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_global_data.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -52,7 +52,7 @@
integer npoin,numpoin
! processor identification
- character(len=150) prname
+ character(len=256) prname
! ------------------------------------
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_global_faces_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_global_faces_data.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_global_faces_data.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -58,7 +58,7 @@
integer npoin,numpoin,nspecface,ispecface
! processor identification
- character(len=150) prname
+ character(len=256) prname
! writing points
open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='unknown')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_surface_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_surface_data.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_AVS_DX_surface_data.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -56,7 +56,7 @@
integer npoin,numpoin,nspecface,ispecface
! processor identification
- character(len=150) prname
+ character(len=256) prname
! writing points
open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='unknown')
Added: seismo/3D/SPECFEM3D_SESAME/trunk/write_VTK_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_VTK_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_VTK_data.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -0,0 +1,325 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+
+! routine for saving vtk file holding integer flag on each spectral element
+
+ subroutine write_VTK_data_elem_i(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ elem_flag,prname_file)
+
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,nglob
+
+! global coordinates
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
+
+! element flag array
+ integer, dimension(nspec) :: elem_flag
+ integer :: ispec,i
+
+! file name
+ character(len=256) prname_file
+
+! write source and receiver VTK files for Paraview
+ write(IMAIN,*) ' vtk file: '
+ write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
+
+ open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
+ write(IOVTK,'(a)') 'material model VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ write(IOVTK, '(a,i,a)') 'POINTS ', nglob, ' float'
+ do i=1,nglob
+ write(IOVTK,'(3f)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ enddo
+ write(IOVTK,*) ""
+
+ ! note: indices for vtk start at 0
+ write(IOVTK,'(a,i,i)') "CELLS ",nspec,nspec*9
+ do ispec=1,nspec
+ write(IOVTK,'(9i)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
+ enddo
+ write(IOVTK,*) ""
+
+ ! type: hexahedrons
+ write(IOVTK,'(a,i)') "CELL_TYPES ",nspec
+ write(IOVTK,*) (12,ispec=1,nspec)
+ write(IOVTK,*) ""
+
+ write(IOVTK,'(a,i)') "CELL_DATA ",nspec
+ write(IOVTK,'(a)') "SCALARS elem_flag integer"
+ write(IOVTK,'(a)') "LOOKUP_TABLE default"
+ do ispec = 1,nspec
+ write(IOVTK,*) elem_flag(ispec)
+ enddo
+ write(IOVTK,*) ""
+ close(IOVTK)
+
+
+ end subroutine write_VTK_data_elem_i
+
+
+!=============================================================
+
+! external mesh routine for saving vtk files for custom_real values on all gll points
+
+ subroutine write_VTK_data_gll_cr(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ gll_data,prname_file)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,nglob
+
+! global coordinates
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
+
+! gll data values array
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: gll_data
+
+! masking arrays (takes first data value assigned on a global point, ignores any data values later on for the same global point)
+ real, dimension(:),allocatable :: flag_val
+ logical, dimension(:),allocatable :: mask_ibool
+
+! file name
+ character(len=256) prname_file
+
+ integer :: ispec,i,j,k,ier,iglob
+
+! write source and receiver VTK files for Paraview
+ write(IMAIN,*) ' vtk file: '
+ write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
+
+ open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
+ write(IOVTK,'(a)') 'material model VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ write(IOVTK, '(a,i,a)') 'POINTS ', nglob, ' float'
+ do i=1,nglob
+ write(IOVTK,'(3f)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ enddo
+ write(IOVTK,*) ""
+
+ ! note: indices for vtk start at 0
+ write(IOVTK,'(a,i,i)') "CELLS ",nspec,nspec*9
+ do ispec=1,nspec
+ write(IOVTK,'(9i)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
+ enddo
+ write(IOVTK,*) ""
+
+ ! type: hexahedrons
+ write(IOVTK,'(a,i)') "CELL_TYPES ",nspec
+ write(IOVTK,*) (12,ispec=1,nspec)
+ write(IOVTK,*) ""
+
+ ! iflag field on global nodeset
+ allocate(mask_ibool(nglob),flag_val(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocating mask'
+
+ mask_ibool = .false.
+ do ispec=1,nspec
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( .not. mask_ibool(iglob) ) then
+ flag_val(iglob) = gll_data(i,j,k,ispec)
+ mask_ibool(iglob) = .true.
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ write(IOVTK,'(a,i)') "POINT_DATA ",nglob
+ write(IOVTK,'(a)') "SCALARS gll_data float"
+ write(IOVTK,'(a)') "LOOKUP_TABLE default"
+ do i = 1,nglob
+ write(IOVTK,*) flag_val(i)
+ enddo
+ write(IOVTK,*) ""
+
+ close(IOVTK)
+
+
+ end subroutine write_VTK_data_gll_cr
+
+!=============================================================
+
+! external mesh routine for saving vtk files for integer values on all gll points
+
+ subroutine write_VTK_data_gll_i(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ gll_data,prname_file)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,nglob
+
+! global coordinates
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
+
+! gll data values array
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: gll_data
+
+! masking arrays (takes first data value assigned on a global point, ignores any data values later on for the same global point)
+ real, dimension(:),allocatable :: flag_val
+ logical, dimension(:),allocatable :: mask_ibool
+
+! file name
+ character(len=256) prname_file
+
+ integer :: ispec,i,j,k,ier,iglob
+
+! write source and receiver VTK files for Paraview
+ write(IMAIN,*) ' vtk file: '
+ write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
+
+ open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
+ write(IOVTK,'(a)') 'material model VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ write(IOVTK, '(a,i,a)') 'POINTS ', nglob, ' float'
+ do i=1,nglob
+ write(IOVTK,'(3f)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ enddo
+ write(IOVTK,*) ""
+
+ ! note: indices for vtk start at 0
+ write(IOVTK,'(a,i,i)') "CELLS ",nspec,nspec*9
+ do ispec=1,nspec
+ write(IOVTK,'(9i)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
+ enddo
+ write(IOVTK,*) ""
+
+ ! type: hexahedrons
+ write(IOVTK,'(a,i)') "CELL_TYPES ",nspec
+ write(IOVTK,*) (12,ispec=1,nspec)
+ write(IOVTK,*) ""
+
+ ! iflag field on global nodeset
+ allocate(mask_ibool(nglob),flag_val(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocating mask'
+
+ mask_ibool = .false.
+ do ispec=1,nspec
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( .not. mask_ibool(iglob) ) then
+ flag_val(iglob) = gll_data(i,j,k,ispec)
+ mask_ibool(iglob) = .true.
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ write(IOVTK,'(a,i)') "POINT_DATA ",nglob
+ write(IOVTK,'(a)') "SCALARS gll_data float"
+ write(IOVTK,'(a)') "LOOKUP_TABLE default"
+ do i = 1,nglob
+ write(IOVTK,*) flag_val(i)
+ enddo
+ write(IOVTK,*) ""
+
+ close(IOVTK)
+
+
+ end subroutine write_VTK_data_gll_i
+
+!=============================================================
+
+! external mesh routine for saving vtk files for points locations
+
+ subroutine write_VTK_data_points(nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ points_globalindices,num_points_globalindices, &
+ prname_file)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nglob
+
+! global coordinates
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
+
+! gll data values array
+ integer :: num_points_globalindices
+ integer, dimension(num_points_globalindices) :: points_globalindices
+
+! file name
+ character(len=256) prname_file
+
+ integer :: i,iglob
+
+! write source and receiver VTK files for Paraview
+ write(IMAIN,*) ' vtk file: '
+ write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
+
+ open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
+ write(IOVTK,'(a)') 'material model VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ write(IOVTK, '(a,i,a)') 'POINTS ', num_points_globalindices, ' float'
+ do i=1,num_points_globalindices
+ iglob = points_globalindices(i)
+ if( iglob <= 0 .or. iglob > nglob ) then
+ print*,'error: '//prname_file(1:len_trim(prname_file))//'.vtk'
+ print*,'error global index: ',iglob,i
+ close(IOVTK)
+ stop 'error vtk points file'
+ endif
+
+ write(IOVTK,'(3f)') xstore_dummy(iglob),ystore_dummy(iglob),zstore_dummy(iglob)
+ enddo
+ write(IOVTK,*) ""
+
+ close(IOVTK)
+
+
+ end subroutine write_VTK_data_points
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90 2009-11-21 00:15:57 UTC (rev 16022)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90 2009-11-21 02:18:44 UTC (rev 16023)
@@ -37,7 +37,7 @@
integer, dimension(nrec_local) :: number_receiver_global
real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NSTEP) :: seismograms
double precision hdur,DT
- character(len=150) LOCAL_PATH
+ character(len=256) LOCAL_PATH
character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
@@ -47,7 +47,7 @@
character(len=4) chn
character(len=1) component
- character(len=150) sisname,clean_LOCAL_PATH,final_LOCAL_PATH
+ character(len=256) sisname,clean_LOCAL_PATH,final_LOCAL_PATH
! parameters for master collects seismograms
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: one_seismogram
@@ -295,7 +295,7 @@
integer, dimension(nrec_local) :: number_receiver_global
real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NSTEP) :: seismograms
double precision hdur,DT
- character(len=150) LOCAL_PATH
+ character(len=256) LOCAL_PATH
integer irec,irec_local
@@ -303,7 +303,7 @@
character(len=4) chn
character(len=1) component
- character(len=150) sisname,clean_LOCAL_PATH,final_LOCAL_PATH
+ character(len=256) sisname,clean_LOCAL_PATH,final_LOCAL_PATH
! save displacement, velocity or acceleration
if(istore == 1) then
@@ -393,7 +393,7 @@
integer, dimension(nrec_local) :: number_receiver_global
real(kind=CUSTOM_REAL), dimension(NDIM,NDIM,nrec_local,NSTEP) :: seismograms
double precision hdur,DT
- character(len=150) LOCAL_PATH
+ character(len=256) LOCAL_PATH
integer irec,irec_local
@@ -401,7 +401,7 @@
character(len=4) chn
character(len=1) component
- character(len=150) sisname,clean_LOCAL_PATH,final_LOCAL_PATH
+ character(len=256) sisname,clean_LOCAL_PATH,final_LOCAL_PATH
do irec_local = 1,nrec_local
More information about the CIG-COMMITS
mailing list