[cig-commits] r12864 - in seismo/2D/SPECFEM2D/branches/BIOT: . DATA
cmorency at geodynamics.org
cmorency at geodynamics.org
Thu Sep 11 11:24:41 PDT 2008
Author: cmorency
Date: 2008-09-11 11:24:41 -0700 (Thu, 11 Sep 2008)
New Revision: 12864
Modified:
seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file
seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Abel_Balanche_bathy_source_solid
seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_M2_UPPA
seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Ronan_SV_30
seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_canyon
seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_no_canyon
seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_unstruct
seismo/2D/SPECFEM2D/branches/BIOT/DATA/STATIONS
seismo/2D/SPECFEM2D/branches/BIOT/Makefile
seismo/2D/SPECFEM2D/branches/BIOT/README_MANUAL.txt
seismo/2D/SPECFEM2D/branches/BIOT/assemble_MPI.F90
seismo/2D/SPECFEM2D/branches/BIOT/attenuation_model.f90
seismo/2D/SPECFEM2D/branches/BIOT/checkgrid.F90
seismo/2D/SPECFEM2D/branches/BIOT/compute_Bielak_conditions.f90
seismo/2D/SPECFEM2D/branches/BIOT/compute_arrays_source.f90
seismo/2D/SPECFEM2D/branches/BIOT/compute_energy.f90
seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_acoustic.f90
seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_elastic.f90
seismo/2D/SPECFEM2D/branches/BIOT/compute_gradient_attenuation.f90
seismo/2D/SPECFEM2D/branches/BIOT/compute_pressure.f90
seismo/2D/SPECFEM2D/branches/BIOT/compute_vector_field.f90
seismo/2D/SPECFEM2D/branches/BIOT/constants.h
seismo/2D/SPECFEM2D/branches/BIOT/construct_acoustic_surface.f90
seismo/2D/SPECFEM2D/branches/BIOT/convolve_source_timefunction.f90
seismo/2D/SPECFEM2D/branches/BIOT/create_color_image.f90
seismo/2D/SPECFEM2D/branches/BIOT/createnum_fast.f90
seismo/2D/SPECFEM2D/branches/BIOT/createnum_slow.f90
seismo/2D/SPECFEM2D/branches/BIOT/datim.f90
seismo/2D/SPECFEM2D/branches/BIOT/define_derivation_matrices.f90
seismo/2D/SPECFEM2D/branches/BIOT/define_external_model.f90
seismo/2D/SPECFEM2D/branches/BIOT/define_shape_functions.f90
seismo/2D/SPECFEM2D/branches/BIOT/enforce_acoustic_free_surface.f90
seismo/2D/SPECFEM2D/branches/BIOT/gmat01.f90
seismo/2D/SPECFEM2D/branches/BIOT/lagrange_poly.f90
seismo/2D/SPECFEM2D/branches/BIOT/locate_receivers.F90
seismo/2D/SPECFEM2D/branches/BIOT/locate_source_force.F90
seismo/2D/SPECFEM2D/branches/BIOT/locate_source_moment_tensor.F90
seismo/2D/SPECFEM2D/branches/BIOT/meshfem2D.F90
seismo/2D/SPECFEM2D/branches/BIOT/part_unstruct.F90
seismo/2D/SPECFEM2D/branches/BIOT/plotgll.f90
seismo/2D/SPECFEM2D/branches/BIOT/plotpost.F90
seismo/2D/SPECFEM2D/branches/BIOT/read_value_parameters.f90
seismo/2D/SPECFEM2D/branches/BIOT/recompute_jacobian.f90
seismo/2D/SPECFEM2D/branches/BIOT/specfem2D.F90
seismo/2D/SPECFEM2D/branches/BIOT/spline_routines.f90
seismo/2D/SPECFEM2D/branches/BIOT/write_seismograms.F90
Log:
Modification of SPECFEM2D version 5.2 to include (1) Biot poroelastic equations and (2) adjoint method.
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,7 +1,7 @@
# title of job, and file that contains interface data
-title = Test for M2 UPPA
-interfacesfile = interfaces_M2_UPPA_curved.dat
+title = Forward calculation (P phase)
+interfacesfile = interfaces.dat
# data concerning mesh, when generated using third-party app (more info in README)
read_external_mesh = .false.
@@ -11,15 +11,15 @@
free_surface_file = ./DATA/Mesh_canyon/canyon_free_surface_file # file containing the free surface
absorbing_surface_file = ./DATA/Mesh_canyon/canyon_absorbing_surface_file # file containing the absorbing surface
-# parameters concerning partitioning
+# parameters concerning partitionning
nproc = 1 # number of processes
-partitioning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
-partitioning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitioning strategy.
+partionning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
+partitionning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitionning strategy.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
-xmax = 4000.d0 # abscissa of right side of the model
-nx = 80 # number of elements along X
+xmax = 800.d0 # abscissa of right side of the model
+nx = 100 # number of elements along X
ngnod = 9 # number of control nodes per element (4 or 9)
initialfield = .false. # use a plane wave as source or not
add_Bielak_conditions = .false. # add Bielak conditions or not if initial plane wave
@@ -32,21 +32,22 @@
absorbing_conditions = .true. # absorbing boundary active or not
absorbbottom = .true.
absorbright = .true.
-absorbtop = .false.
+absorbtop = .true.
absorbleft = .true.
# time step parameters
-nt = 1600 # total number of time steps
-deltat = 1.d-3 # duration of a time step
+nt = 3000 # total number of time steps
+deltat = 2d-4 # duration of a time step
+isolver = 2 # type of simulation 1=forward 2=adjoint + kernels
# source parameters
source_surf = .false. # source inside the medium or at the surface
-xs = 2000. # source location x in meters
-zs = 1600. # source location z in meters
+xs = 300. # source location x in meters
+zs = 400. # source location z in meters
source_type = 1 # elastic force or acoustic pressure = 1 or moment tensor = 2
time_function_type = 1 # Ricker = 1, first derivative = 2, Gaussian = 3, Dirac = 4, Heaviside = 5
-f0 = 8.0 # dominant source frequency (Hz) if not Dirac or Heaviside
-angleforce = 20. # angle of the source (for a force only)
+f0 = 20.0 # dominant source frequency (Hz) if not Dirac or Heaviside
+angleforce = -90. # angle of the source (for a force only)
Mxx = 1. # Mxx component (for a moment tensor source only)
Mzz = 1. # Mzz component (for a moment tensor source only)
Mxz = 0. # Mxz component (for a moment tensor source only)
@@ -60,21 +61,22 @@
# receiver line parameters for seismograms
seismotype = 1 # record 1=displ 2=veloc 3=accel 4=pressure
+save_forward = .false. # save the last frame
generate_STATIONS = .true. # creates a STATION file in ./DATA
nreceiverlines = 1 # number of receiver lines
anglerec = 0.d0 # angle to rotate components at receivers
# first receiver line
-nrec = 11 # number of receivers
-xdeb = 300. # first receiver x in meters
-zdeb = 2200. # first receiver z in meters
+nrec = 1 # number of receivers
+xdeb = 500. # first receiver x in meters
+zdeb = 400. # first receiver z in meters
xfin = 3700. # last receiver x in meters (ignored if onlyone receiver)
zfin = 2200. # last receiver z in meters (ignored if onlyone receiver)
-enreg_surf = .true. # receivers inside the medium or at the surface
+enreg_surf = .false. # receivers inside the medium or at the surface
# display parameters
-NTSTEP_BETWEEN_OUTPUT_INFO = 100 # display frequency in time steps
-output_postscript_snapshot = .true. # output Postscript snapshot of the results
+NTSTEP_BETWEEN_OUTPUT_INFO = 400 # display frequency in time steps
+output_postscript_snapshot = .false. # output Postscript snapshot of the results
output_color_image = .true. # output color image of the results
imagetype = 1 # display 1=displ 2=veloc 3=accel 4=pressure
cutsnaps = 1. # minimum amplitude in % for snapshots
@@ -88,18 +90,12 @@
gnuplot = .false. # generate a GNUPLOT file for the grid
outputgrid = .false. # save the grid in a text file or not
-# velocity and density models
-nbmodels = 4 # nb of different models
-# define models as (model_number,1,rho,vp,vs,0,0) or (model_number,2,rho,c11,c13,c33,c44)
-# set vs to zero to make a given model acoustic
-# the mesh can contain both acoustic and elastic models simultaneously
-1 1 2700.d0 3000.d0 1732.051d0 0 0
-2 1 2500.d0 2700.d0 0 0 0 #1558.89d0 0 0
-3 1 2200.d0 2500.d0 1443.375d0 0 0
-4 1 2200.d0 2200.d0 1343.375d0 0 0
+# models
+nbmodels = 1 # nb of different models
+# define models as (model_number,1,rho_s,rho_f,phi,tort,permxx,permxz,permzz,kappa_s,kappa_f,kappa_fr,mu_s,eta_f,mu_fr) or (Anisotropic: to be defined - in the code already, just need to modify the Par_file)
+# set the porosity phi to 1 to make a given model acoustic, and to 0 to make it elastic
+# the mesh can contain acoustic, elastic and poroelastic models simultaneously
+1 1 2650.d0 880.d0 0.0d0 2.0 1d-11 0.d0 1d-11 12.2d9 2.5d9 9.6d9 5.1d9 0.0d-3 5.1d9
# define the different regions of the model in the (nx,nz) spectral element mesh
-nbregions = 4 # nb of regions and model number for each
-1 80 1 20 1
-1 80 21 40 2
-1 80 41 60 3
-60 70 21 40 4
+nbregions = 1 # nb of regions and model number for each
+1 100 1 80 1
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Abel_Balanche_bathy_source_solid
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Abel_Balanche_bathy_source_solid 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Abel_Balanche_bathy_source_solid 2008-09-11 18:24:41 UTC (rev 12864)
@@ -11,10 +11,10 @@
free_surface_file = ./DATA/Mesh_canyon/canyon_free_surface_file # file containing the free surface
absorbing_surface_file = ./DATA/Mesh_canyon/canyon_absorbing_surface_file # file containing the absorbing surface
-# parameters concerning partitioning
+# parameters concerning partitionning
nproc = 1 # number of processes
-partitioning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
-partitioning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitioning strategy.
+partionning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
+partitionning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitionning strategy.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_M2_UPPA
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_M2_UPPA 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_M2_UPPA 2008-09-11 18:24:41 UTC (rev 12864)
@@ -11,10 +11,10 @@
free_surface_file = ./DATA/Mesh_canyon/canyon_free_surface_file # file containing the free surface
absorbing_surface_file = ./DATA/Mesh_canyon/canyon_absorbing_surface_file # file containing the absorbing surface
-# parameters concerning partitioning
+# parameters concerning partitionning
nproc = 1 # number of processes
-partitioning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
-partitioning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitioning strategy.
+partionning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
+partitionning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitionning strategy.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Ronan_SV_30
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Ronan_SV_30 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Ronan_SV_30 2008-09-11 18:24:41 UTC (rev 12864)
@@ -11,10 +11,10 @@
free_surface_file = ./DATA/unstructured_fluide_solide_test/surface_free # file containing the free surface
absorbing_surface_file = ./DATA/unstructured_fluide_solide_test/surface_abs # file containing the absorbing surface
-# parameters concerning partitioning
+# parameters concerning partitionning
nproc = 1 # number of processes
-partitioning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
-partitioning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitioning strategy.
+partionning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
+partitionning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitionning strategy.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_canyon
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_canyon 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_canyon 2008-09-11 18:24:41 UTC (rev 12864)
@@ -11,10 +11,10 @@
free_surface_file = ./DATA/Mesh_canyon/canyon_free_surface_file # file containing the free surface
absorbing_surface_file = ./DATA/Mesh_canyon/canyon_absorbing_surface_file # file containing the absorbing surface
-# parameters concerning partitioning
+# parameters concerning partitionning
nproc = 1 # number of processes
-partitioning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
-partitioning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitioning strategy.
+partionning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
+partitionning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitionning strategy.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_no_canyon
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_no_canyon 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_no_canyon 2008-09-11 18:24:41 UTC (rev 12864)
@@ -11,10 +11,10 @@
free_surface_file = ./DATA/Mesh_canyon/canyon_free_surface_file # file containing the free surface
absorbing_surface_file = ./DATA/Mesh_canyon/canyon_absorbing_surface_file # file containing the absorbing surface
-# parameters concerning partitioning
+# parameters concerning partitionning
nproc = 1 # number of processes
-partitioning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
-partitioning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitioning strategy.
+partionning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
+partitionning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitionning strategy.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_unstruct
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_unstruct 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_unstruct 2008-09-11 18:24:41 UTC (rev 12864)
@@ -11,10 +11,10 @@
free_surface_file = ./DATA/unstructured_fluide_solide_test/surface_free # file containing the free surface
absorbing_surface_file = ./DATA/unstructured_fluide_solide_test/surface_abs # file containing the absorbing surface
-# parameters concerning partitioning
+# parameters concerning partitionning
nproc = 8 # number of processes
-partitioning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
-partitioning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitioning strategy.
+partionning_method = 1 # ascending order = 1, Metis = 2, Scotch = 3
+partitionning_strategy = 01110 #b{strat=m{asc=g,low=g,rat=1.0,type=h,vert=4}} #01110 # options concerning partitionning strategy.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/STATIONS
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/STATIONS 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/STATIONS 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,11 +1 @@
-S0001 AA 300.0000000 2997.7298909 0.0 0.0
-S0002 AA 640.0000000 3008.0430011 0.0 0.0
-S0003 AA 980.0000000 3090.8224062 0.0 0.0
-S0004 AA 1320.0000000 3283.0303923 0.0 0.0
-S0005 AA 1660.0000000 3347.8768862 0.0 0.0
-S0006 AA 2000.0000000 3250.0000000 0.0 0.0
-S0007 AA 2340.0000000 3197.3138031 0.0 0.0
-S0008 AA 2680.0000000 3150.9619873 0.0 0.0
-S0009 AA 3020.0000000 3086.5939051 0.0 0.0
-S0010 AA 3360.0000000 3042.8523748 0.0 0.0
-S0011 AA 3700.0000000 3020.6886768 0.0 0.0
+S0001 AA 500.0000000 400.0000000 0.0 0.0
Modified: seismo/2D/SPECFEM2D/branches/BIOT/Makefile
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/Makefile 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/Makefile 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,13 +1,15 @@
#========================================================================
#
-# S P E C F E M 2 D Version 5.2
+# S P E C F E M 2 D Version 6.3
# ------------------------------
#
-# Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+# Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
# Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
# Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
# Roland Martin, roland DOT martin aT univ-pau DOT fr
+# Christina Morency, cmorency aT gps DOT caltech DOT edu
+# Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
#
# This software is a computer program whose purpose is to solve
# the two-dimensional viscoelastic anisotropic wave equation
@@ -52,9 +54,6 @@
#FLAGS_CHECK=-fast -Mbounds -Mneginfo -Mdclchk -Minform=warn
# Intel
-# NOTE FOR USERS OF IFORT 10.0 AND ABOVE :
-# Use of option -heap-arrays <size> can be required, depending on the size of the simulation.
-# Another workaround can be to increase your stack size (ulimit -s).
#F90 = ifort
#CC = gcc
#FLAGS_NOCHECK=-O0 -implicitnone -warn stderrors -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -assume byterecl -check nobounds
@@ -82,15 +81,14 @@
OBJS_MESHFEM2D = $O/part_unstruct.o $O/meshfem2D.o $O/read_value_parameters.o $O/spline_routines.o
OBJS_SPECFEM2D = $O/checkgrid.o $O/datim.o $O/enforce_acoustic_free_surface.o\
- $O/compute_forces_acoustic.o $O/compute_forces_elastic.o\
+ $O/compute_forces_acoustic.o $O/compute_forces_elastic.o $O/compute_forces_solid.o $O/compute_forces_fluid.o\
$O/lagrange_poly.o $O/gmat01.o $O/gll_library.o $O/plotgll.o $O/define_derivation_matrices.o\
$O/plotpost.o $O/locate_receivers.o $O/locate_source_force.o $O/compute_gradient_attenuation.o\
$O/specfem2D.o $O/write_seismograms.o $O/define_external_model.o $O/createnum_fast.o $O/createnum_slow.o\
$O/define_shape_functions.o $O/attenuation_model.o $O/create_color_image.o $O/compute_vector_field.o $O/compute_pressure.o\
$O/recompute_jacobian.o $O/compute_arrays_source.o $O/locate_source_moment_tensor.o $O/netlib_specfun_erf.o\
- $O/construct_acoustic_surface.o $O/assemble_MPI.o $O/compute_energy.o $O/compute_curl_one_element.o\
- $O/attenuation_compute_param.o $O/compute_Bielak_conditions.o $O/paco_beyond_critical.o\
- $O/paco_convolve_fft.o $O/is_in_convex_quadrilateral.o
+ $O/construct_acoustic_surface.o $O/assemble_MPI.o $O/compute_energy.o\
+ $O/attenuation_compute_param.o $O/compute_Bielak_conditions.o
default: clean meshfem2D specfem2D convolve_source_timefunction
@@ -181,6 +179,14 @@
### use optimized compilation option for solver only
$O/compute_forces_elastic.o: compute_forces_elastic.f90 constants.h
${F90} $(FLAGS_NOCHECK) -c -o $O/compute_forces_elastic.o compute_forces_elastic.f90
+
+### use optimized compilation option for solver only
+$O/compute_forces_solid.o: compute_forces_solid.f90 constants.h
+ ${F90} $(FLAGS_NOCHECK) -c -o $O/compute_forces_solid.o compute_forces_solid.f90
+
+### use optimized compilation option for solver only
+$O/compute_forces_fluid.o: compute_forces_fluid.f90 constants.h
+ ${F90} $(FLAGS_NOCHECK) -c -o $O/compute_forces_fluid.o compute_forces_fluid.f90
### use optimized compilation option for solver only
$O/compute_gradient_attenuation.o: compute_gradient_attenuation.f90 constants.h
@@ -195,9 +201,6 @@
$O/compute_pressure.o: compute_pressure.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/compute_pressure.o compute_pressure.f90
-$O/compute_curl_one_element.o: compute_curl_one_element.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/compute_curl_one_element.o compute_curl_one_element.f90
-
$O/compute_Bielak_conditions.o: compute_Bielak_conditions.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/compute_Bielak_conditions.o compute_Bielak_conditions.f90
@@ -206,7 +209,7 @@
$O/create_color_image.o: create_color_image.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/create_color_image.o create_color_image.f90
-
+
$O/spline_routines.o: spline_routines.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/spline_routines.o spline_routines.f90
@@ -230,13 +233,3 @@
$O/attenuation_compute_param.o: attenuation_compute_param.c
${CC} -c -o $O/attenuation_compute_param.o attenuation_compute_param.c
-
-$O/paco_beyond_critical.o: paco_beyond_critical.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/paco_beyond_critical.o paco_beyond_critical.f90
-
-$O/paco_convolve_fft.o: paco_convolve_fft.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/paco_convolve_fft.o paco_convolve_fft.f90
-
-$O/is_in_convex_quadrilateral.o: is_in_convex_quadrilateral.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/is_in_convex_quadrilateral.o is_in_convex_quadrilateral.f90
-
Modified: seismo/2D/SPECFEM2D/branches/BIOT/README_MANUAL.txt
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/README_MANUAL.txt 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/README_MANUAL.txt 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,14 +1,11 @@
-How to use SPECFEM2D version 5.2.2:
------------------------------------
-
To use the code:
- edit the Makefile. There are several options available : -DUSE_MPI compiles with use of an MPI library. -DUSE_METIS enables use of graph partitioner METIS, the same goes for -DUSE_SCOTCH for SCOTCH.
- type "make all"
-- edit the input file "DATA/Par_file" which describes the simulation. It contains comments and should be almost self-explanatory, if you need more details we do not have a manual for the 2D version but you can find useful information in the manuals of the 3D versions, since many parameters and the general philosophy is similar. They are available at http://geodynamics.org/wsvn/cig/seismo/3D in subdirectories USER_MANUAL. To create acoustic (fluid) regions, just set the S wave speed to zero and the code will see that these elements are fluid and switch to the right equations there automatically, and automatically match them with the solid regions
+- edit the input file "DATA/Par_file" which describes the simulation. It contains comments and should be almost self-explanatory, if you need more details we do not have a manual for the 2D version but you can find useful information in the manuals of the 3D versions, since many parameters and the general philosophy is similar. They are available at http://www.univ-pau.fr/~dkomati1/published_papers/manual_SPECFEM3D_GLOBE.pdf and http://www.univ-pau.fr/~dkomati1/published_papers/manual_SPECFEM3D_BASIN.pdf. To create acoustic (fluid) regions, just set the S wave speed to zero and the code will see that these elements are fluid and switch to the right equations there automatically, and automatically match them with the solid regions
- if you are using an external mesher (like GID or CUBIT), you should set "read_external_mesh" to true.
"mesh_file" is the file describing the mesh : first line is the number of elements, then a list of 4 nodes (quadrilaterals only) forming each elements on each line.
@@ -31,7 +28,7 @@
- you can convolve them with any source time function in postprocessing later using "convolve_source_timefunction.csh" and "convolve_source_timefunction.f90", see the manual of the 3D code for details on how to do this
-- we do not have PML absorbing conditions implemented in the fluid/solid code yet. We use (older and less efficient) paraxial Clayton-Engquist or Sommerfeld equations instead. This is only by lack of time, we have a developer who is currently implementing PML but the code is not fully ready. For now, since the paraxial conditions are less efficient, please use a larger model
+- we do not have PML absorbing conditions implemented in the fluid/solid code yet. We use (older and less efficient) paraxial Clayton-Engquist or Sommerfeld equations instead. This is only by lack of time, I have a student who is currently implementing PML but the code is not fully ready. I will send it to you when it is. (We already have PML in the purely elastic code, see http://www.univ-pau.fr/~dkomati1/published_papers/pml_2nd_order_GJI_typos_fixed.pdf for details, therefore it is only a matter of cutting/pasting the routines). For now, since the paraxial conditions are less efficient, please use a larger model until we send you the code with PML
- there are a few useful scripts and Fortran routines in directory UTILS
Modified: seismo/2D/SPECFEM2D/branches/BIOT/assemble_MPI.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/assemble_MPI.F90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/assemble_MPI.F90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,13 +1,15 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.2
+! S P E C F E M 2 D Version 6.3
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -41,8 +43,8 @@
!========================================================================
!
-! This file contains subroutines related to assembling (of the mass matrix, potential_dot_dot and
-! accel_elastic).
+! This file contains subroutines related to assembling (of the mass matrix, potential_dot_dot,
+! accel_elastic, accels_poroelastic and accelw_poroelastic).
! These subroutines are for the most part not used in the sequential version.
!
@@ -56,13 +58,13 @@
!-----------------------------------------------
subroutine prepare_assemble_MPI (nspec,ibool, &
knods, ngnod, &
- npoin, elastic, &
+ npoin, elastic,poroelastic, &
ninterface, max_interface_size, &
my_nelmnts_neighbours, my_interfaces, &
- ibool_interfaces_acoustic, ibool_interfaces_elastic, &
- nibool_interfaces_acoustic, nibool_interfaces_elastic, &
- inum_interfaces_acoustic, inum_interfaces_elastic, &
- ninterface_acoustic, ninterface_elastic, &
+ ibool_interfaces_acoustic, ibool_interfaces_elastic, ibool_interfaces_poroelastic,&
+ nibool_interfaces_acoustic, nibool_interfaces_elastic, nibool_interfaces_poroelastic,&
+ inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic,&
+ ninterface_acoustic, ninterface_elastic, ninterface_poroelastic,&
mask_ispec_inner_outer &
)
@@ -71,7 +73,7 @@
include 'constants.h'
integer, intent(in) :: nspec, npoin, ngnod
- logical, dimension(nspec), intent(in) :: elastic
+ logical, dimension(nspec), intent(in) :: elastic,poroelastic
integer, dimension(ngnod,nspec), intent(in) :: knods
integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
@@ -80,13 +82,13 @@
integer, dimension(ninterface) :: my_nelmnts_neighbours
integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
integer, dimension(NGLLX*max_interface_size,ninterface) :: &
- ibool_interfaces_acoustic,ibool_interfaces_elastic
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
integer, dimension(ninterface) :: &
- nibool_interfaces_acoustic,nibool_interfaces_elastic
+ nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
integer, dimension(ninterface), intent(out) :: &
- inum_interfaces_acoustic, inum_interfaces_elastic
- integer, intent(out) :: ninterface_acoustic, ninterface_elastic
+ inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
+ integer, intent(out) :: ninterface_acoustic, ninterface_elastic, ninterface_poroelastic
integer :: num_interface
integer :: ispec_interface
@@ -95,6 +97,7 @@
logical, dimension(npoin) :: mask_ibool_acoustic
logical, dimension(npoin) :: mask_ibool_elastic
+ logical, dimension(npoin) :: mask_ibool_poroelastic
integer :: ixmin, ixmax
integer :: izmin, izmax
@@ -106,6 +109,7 @@
integer :: k
integer :: npoin_interface_acoustic
integer :: npoin_interface_elastic
+ integer :: npoin_interface_poroelastic
integer :: ix,iz
@@ -115,12 +119,16 @@
nibool_interfaces_acoustic(:) = 0
ibool_interfaces_elastic(:,:) = 0
nibool_interfaces_elastic(:) = 0
+ ibool_interfaces_poroelastic(:,:) = 0
+ nibool_interfaces_poroelastic(:) = 0
do num_interface = 1, ninterface
npoin_interface_acoustic = 0
npoin_interface_elastic = 0
+ npoin_interface_poroelastic = 0
mask_ibool_acoustic(:) = .false.
mask_ibool_elastic(:) = .false.
+ mask_ibool_poroelastic(:) = .false.
do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
ispec = my_interfaces(1,ispec_interface,num_interface)
@@ -144,6 +152,14 @@
ibool_interfaces_elastic(npoin_interface_elastic,num_interface)=&
ibool(ix,iz,ispec)
end if
+ elseif ( poroelastic(ispec) ) then
+
+ if(.not. mask_ibool_poroelastic(ibool(ix,iz,ispec))) then
+ mask_ibool_poroelastic(ibool(ix,iz,ispec)) = .true.
+ npoin_interface_poroelastic = npoin_interface_poroelastic + 1
+ ibool_interfaces_poroelastic(npoin_interface_poroelastic,num_interface)=&
+ ibool(ix,iz,ispec)
+ end if
else
if(.not. mask_ibool_acoustic(ibool(ix,iz,ispec))) then
mask_ibool_acoustic(ibool(ix,iz,ispec)) = .true.
@@ -158,12 +174,14 @@
end do
nibool_interfaces_acoustic(num_interface) = npoin_interface_acoustic
nibool_interfaces_elastic(num_interface) = npoin_interface_elastic
+ nibool_interfaces_poroelastic(num_interface) = npoin_interface_poroelastic
do ispec = 1, nspec
do iz = 1, NGLLZ
do ix = 1, NGLLX
if ( mask_ibool_acoustic(ibool(ix,iz,ispec)) &
- .or. mask_ibool_elastic(ibool(ix,iz,ispec)) ) then
+ .or. mask_ibool_elastic(ibool(ix,iz,ispec)) &
+ .or. mask_ibool_poroelastic(ibool(ix,iz,ispec))) then
mask_ispec_inner_outer(ispec) = .true.
endif
@@ -175,6 +193,7 @@
ninterface_acoustic = 0
ninterface_elastic = 0
+ ninterface_poroelastic = 0
do num_interface = 1, ninterface
if ( nibool_interfaces_acoustic(num_interface) > 0 ) then
ninterface_acoustic = ninterface_acoustic + 1
@@ -184,6 +203,10 @@
ninterface_elastic = ninterface_elastic + 1
inum_interfaces_elastic(ninterface_elastic) = num_interface
end if
+ if ( nibool_interfaces_poroelastic(num_interface) > 0 ) then
+ ninterface_poroelastic = ninterface_poroelastic + 1
+ inum_interfaces_poroelastic(ninterface_poroelastic) = num_interface
+ end if
end do
end subroutine prepare_assemble_MPI
@@ -402,13 +425,67 @@
end subroutine create_MPI_req_SEND_RECV_el
+!-----------------------------------------------
+! Creation of persistent communication requests (send and recv) for poroelastic elements.
+! Should be disposed of if using Paraver (with MPItrace), since it does not instrument persistent
+! communications yet.
+!-----------------------------------------------
+subroutine create_MPI_req_SEND_RECV_po( &
+ ninterface, ninterface_poroelastic, &
+ nibool_interfaces_poroelastic, &
+ my_neighbours, &
+ max_ibool_interfaces_size_po, &
+ buffer_send_faces_vector_pos, &
+ buffer_recv_faces_vector_pos, &
+ tab_requests_send_recv_poroelastic, &
+ inum_interfaces_poroelastic &
+ )
+ implicit none
+
+ include 'constants.h'
+ include 'mpif.h'
+ include 'precision_mpi.h'
+
+
+ integer, intent(in) :: ninterface, ninterface_poroelastic
+ integer, dimension(ninterface), intent(in) :: inum_interfaces_poroelastic
+ integer, intent(in) :: max_ibool_interfaces_size_po
+ real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(in) :: &
+ buffer_send_faces_vector_pos
+ real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(in) :: &
+ buffer_recv_faces_vector_pos
+ integer, dimension(ninterface_poroelastic*2), intent(inout) :: tab_requests_send_recv_poroelastic
+ integer, dimension(ninterface), intent(in) :: nibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(in) :: my_neighbours
+
+ integer :: inum_interface,num_interface
+ integer :: ier
+
+ do inum_interface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(inum_interface)
+
+ call MPI_Send_init ( buffer_send_faces_vector_pos(1,inum_interface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 14, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poroelastic(inum_interface), ier)
+ call MPI_Recv_init ( buffer_recv_faces_vector_pos(1,inum_interface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 14, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poroelastic(ninterface_poroelastic+inum_interface), ier)
+ end do
+
+end subroutine create_MPI_req_SEND_RECV_po
+
+
!-----------------------------------------------
! Assembling the mass matrix.
!-----------------------------------------------
-subroutine assemble_MPI_scalar(array_val1, array_val2,npoin, &
- ninterface, max_interface_size, max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, &
- ibool_interfaces_acoustic,ibool_interfaces_elastic, nibool_interfaces_acoustic,nibool_interfaces_elastic, my_neighbours)
+subroutine assemble_MPI_scalar(array_val1, array_val2, array_val3, array_val4,npoin, &
+ ninterface, max_interface_size, max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, max_ibool_interfaces_size_po,&
+ ibool_interfaces_acoustic,ibool_interfaces_elastic, ibool_interfaces_poroelastic,&
+ nibool_interfaces_acoustic,nibool_interfaces_elastic, nibool_interfaces_poroelastic,my_neighbours)
implicit none
@@ -416,18 +493,18 @@
include 'mpif.h'
! array to assemble
- real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1, array_val2
+ real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1, array_val2, array_val3, array_val4
integer, intent(in) :: npoin
integer, intent(in) :: ninterface
integer, intent(in) :: max_interface_size
- integer, intent(in) :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el
+ integer, intent(in) :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, max_ibool_interfaces_size_po
integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: &
- ibool_interfaces_acoustic,ibool_interfaces_elastic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic,nibool_interfaces_elastic
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
integer, dimension(ninterface), intent(in) :: my_neighbours
- double precision, dimension(max_ibool_interfaces_size_ac+max_ibool_interfaces_size_el, ninterface) :: &
+ double precision, dimension(max_ibool_interfaces_size_ac+max_ibool_interfaces_size_el+2*max_ibool_interfaces_size_po, ninterface) :: &
buffer_send_faces_scalar, &
buffer_recv_faces_scalar
integer :: msg_status(MPI_STATUS_SIZE)
@@ -452,8 +529,21 @@
array_val2(ibool_interfaces_elastic(i,num_interface))
end do
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val3(ibool_interfaces_poroelastic(i,num_interface))
+ end do
+
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val4(ibool_interfaces_poroelastic(i,num_interface))
+ end do
+
call MPI_isend ( buffer_send_faces_scalar(1,num_interface), &
- nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface), MPI_DOUBLE_PRECISION, &
+ nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface)+2*nibool_interfaces_poroelastic(num_interface),&
+ MPI_DOUBLE_PRECISION, &
my_neighbours(num_interface), 11, &
MPI_COMM_WORLD, msg_requests(num_interface), ier)
@@ -461,7 +551,8 @@
do num_interface = 1, ninterface
call MPI_recv ( buffer_recv_faces_scalar(1,num_interface), &
- nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface), MPI_DOUBLE_PRECISION, &
+ nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface)+2*nibool_interfaces_poroelastic(num_interface),&
+ MPI_DOUBLE_PRECISION, &
my_neighbours(num_interface), 11, &
MPI_COMM_WORLD, msg_status(1), ier)
@@ -478,6 +569,18 @@
buffer_recv_faces_scalar(ipoin,num_interface)
end do
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ array_val3(ibool_interfaces_poroelastic(i,num_interface)) = array_val3(ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ array_val4(ibool_interfaces_poroelastic(i,num_interface)) = array_val4(ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+
end do
call MPI_BARRIER(mpi_comm_world,ier)
@@ -612,7 +715,72 @@
end subroutine assemble_MPI_vector_el_start
+!-----------------------------------------------
+! Assembling accels_poroelastic and accelw_poroelastic for poroelastic elements :
+! the buffers are filled, and the send and recv are started here.
+! We use MPI_Start (MPI_Startall is not used, since it causes problems in OpenMPI prior to v1.2).
+!-----------------------------------------------
+subroutine assemble_MPI_vector_po_start(array_val3,array_val4,npoin, &
+ ninterface, ninterface_poroelastic, &
+ inum_interfaces_poroelastic, &
+ max_interface_size, max_ibool_interfaces_size_po,&
+ ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
+ tab_requests_send_recv_poroelastic, &
+ buffer_send_faces_vector_pos, buffer_send_faces_vector_pow&
+ )
+ implicit none
+
+ include 'constants.h'
+ include 'mpif.h'
+
+ ! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(in) :: array_val3,array_val4
+
+ integer, intent(in) :: npoin
+ integer, intent(in) :: ninterface, ninterface_poroelastic
+ integer, dimension(ninterface), intent(in) :: inum_interfaces_poroelastic
+ integer, intent(in) :: max_interface_size
+ integer, intent(in) :: max_ibool_interfaces_size_po
+ integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(in) :: nibool_interfaces_poroelastic
+ integer, dimension(ninterface_poroelastic*2), intent(inout) :: tab_requests_send_recv_poroelastic
+ real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(inout) :: &
+ buffer_send_faces_vector_pos,buffer_send_faces_vector_pow
+
+
+ integer :: ipoin, num_interface, inum_interface
+ integer :: ier
+
+ integer :: i
+
+
+ do inum_interface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(inum_interface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ buffer_send_faces_vector_pos(ipoin+1:ipoin+2,inum_interface) = &
+ array_val3(:,ibool_interfaces_poroelastic(i,num_interface))
+ buffer_send_faces_vector_pow(ipoin+1:ipoin+2,inum_interface) = &
+ array_val4(:,ibool_interfaces_poroelastic(i,num_interface))
+ ipoin = ipoin + 2
+ end do
+
+ end do
+
+ do inum_interface = 1, ninterface_poroelastic*2
+ call MPI_START(tab_requests_send_recv_poroelastic(inum_interface), ier)
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_start unsuccessful in assemble_MPI_vector_start')
+ end if
+ end do
+
+!call MPI_Startall ( ninterface*2, tab_requests_send_recv(1), ier )
+
+end subroutine assemble_MPI_vector_po_start
+
!-----------------------------------------------
! Assembling potential_dot_dot for acoustic elements :
! We wait for the completion of the communications, and add the contributions received
@@ -732,9 +900,70 @@
end subroutine assemble_MPI_vector_el_wait
+!-----------------------------------------------
+! Assembling accels_poroelastic and accelw_poroelastic for poroelastic elements :
+! We wait for the completion of the communications, and add the contributions received
+! for the points on the interfaces.
+!-----------------------------------------------
+subroutine assemble_MPI_vector_po_wait(array_val3,array_val4,npoin, &
+ ninterface, ninterface_poroelastic, &
+ inum_interfaces_poroelastic, &
+ max_interface_size, max_ibool_interfaces_size_po,&
+ ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
+ tab_requests_send_recv_poroelastic, &
+ buffer_recv_faces_vector_pos, buffer_recv_faces_vector_pow &
+ )
+
+ implicit none
+
+ include 'constants.h'
+ include 'mpif.h'
+
+ ! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(inout) :: array_val3,array_val4
+
+ integer, intent(in) :: npoin
+ integer, intent(in) :: ninterface, ninterface_poroelastic
+ integer, dimension(ninterface), intent(in) :: inum_interfaces_poroelastic
+ integer, intent(in) :: max_interface_size
+ integer, intent(in) :: max_ibool_interfaces_size_po
+ integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(in) :: nibool_interfaces_poroelastic
+ integer, dimension(ninterface_poroelastic*2), intent(inout) :: tab_requests_send_recv_poroelastic
+ real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(inout) :: &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow
+
+ integer :: ipoin, num_interface, inum_interface
+ integer :: ier
+ integer, dimension(MPI_STATUS_SIZE,ninterface_poroelastic*2) :: tab_statuses_poroelastic
+
+ integer :: i
+
+ call MPI_Waitall ( ninterface_poroelastic*2, tab_requests_send_recv_poroelastic(1), tab_statuses_poroelastic(1,1), ier )
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_WAITALL unsuccessful in assemble_MPI_vector_wait')
+ end if
+
+ do inum_interface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(inum_interface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) = array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_vector_pos(ipoin+1:ipoin+2,inum_interface)
+ array_val4(:,ibool_interfaces_poroelastic(i,num_interface)) = array_val4(:,ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_vector_pow(ipoin+1:ipoin+2,inum_interface)
+
+ ipoin = ipoin + 2
+ end do
+
+ end do
+
+end subroutine assemble_MPI_vector_po_wait
+
#endif
-
!-----------------------------------------------
! Dummy subroutine, to be able to stop the code whether sequential or parallel.
!-----------------------------------------------
Modified: seismo/2D/SPECFEM2D/branches/BIOT/attenuation_model.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/attenuation_model.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/attenuation_model.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/checkgrid.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/checkgrid.F90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/checkgrid.F90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,13 +1,15 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.2
+! S P E C F E M 2 D Version 6.3
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -40,9 +42,11 @@
!
!========================================================================
- subroutine checkgrid(vpext,vsext,rhoext,density,elastcoef,ibool,kmato,coord,npoin,vpmin,vpmax, &
+ subroutine checkgrid(vpext,vsext,rhoext,density,poroelastcoef,porosity,tortuosity,ibool,kmato,&
+ coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
assign_external_model,nspec,numat,deltat,f0,t0,initialfield,time_function_type, &
- coorg,xinterp,zinterp,shapeint,knods,simulation_title,npgeo,pointsdisp,ngnod,any_elastic,myrank,nproc)
+ coorg,xinterp,zinterp,shapeint,knods,simulation_title,npgeo,pointsdisp,ngnod,&
+ any_elastic,any_poroelastic,myrank,nproc)
! check the mesh, stability and number of points per wavelength
@@ -66,19 +70,23 @@
integer, dimension(nspec) :: kmato
integer, dimension(NGLLX,NGLLX,nspec) :: ibool
- double precision, dimension(numat) :: density
- double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(numat) :: porosity,tortuosity
double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
double precision coord(NDIM,npoin)
- double precision vpmin,vpmax,vsmin,vsmax,densmin,densmax,vpmax_local,vpmin_local,vsmin_local
- double precision lambdaplus2mu,mu,denst,cploc,csloc
+ double precision vpImin,vpImax,vsmin,vsmax,densmin,densmax,vpImax_local,vpImin_local,vsmin_local
+ double precision vpIImin,vpIImax,vpIImax_local,vpIImin_local
+ double precision kappa_s,kappa_f,kappa_fr,mu_s,mu_fr,denst_s,denst_f,denst_bar,phi,tort,cpIloc,cpIIloc,csloc
+ double precision afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,cpIsquare,cpIIsquare,cssquare
double precision distance_min,distance_max,distance_min_local,distance_max_local
- double precision courant_stability_number_max,lambdaPmin,lambdaPmax,lambdaSmin,lambdaSmax
+ double precision courant_stability_number_max,lambdaPImin,lambdaPImax,lambdaSmin,lambdaSmax
+ double precision lambdaPIImin,lambdaPIImax
double precision f0,t0,deltat,distance_1,distance_2,distance_3,distance_4
- logical assign_external_model,initialfield,any_elastic
+ logical assign_external_model,initialfield,any_elastic,any_poroelastic
! for the stability condition
! maximum polynomial degree for which we can compute the stability condition
@@ -88,16 +96,18 @@
integer pointsdisp,npgeo,ngnod,is,ir,in,nnum
double precision :: xmax,zmax,height,usoffset,sizex,sizez,courant_stability_number
- double precision :: x1,z1,x2,z2,ratio_page,xmin,zmin,lambdaS_local,lambdaP_local
+ double precision :: x1,z1,x2,z2,ratio_page,xmin,zmin,lambdaS_local,lambdaPI_local
#ifdef USE_MPI
- double precision :: vpmin_glob,vpmax_glob,vsmin_glob,vsmax_glob,densmin_glob,densmax_glob
+ double precision :: vpImin_glob,vpImax_glob,vsmin_glob,vsmax_glob,densmin_glob,densmax_glob
+ double precision :: vpIImin_glob,vpIImax_glob
double precision :: distance_min_glob,distance_max_glob
- double precision :: courant_stability_max_glob,lambdaPmin_glob,lambdaPmax_glob,lambdaSmin_glob,lambdaSmax_glob
+ double precision :: courant_stability_max_glob,lambdaPImin_glob,lambdaPImax_glob,&
+ lambdaPIImin_glob,lambdaPIImax_glob,lambdaSmin_glob,lambdaSmax_glob
double precision :: xmin_glob, xmax_glob, zmin_glob, zmax_glob
#endif
- logical :: any_elastic_glob
+ logical :: any_elastic_glob,any_poroelastic_glob
double precision, dimension(2,nspec*5) :: coorg_send
double precision, dimension(:,:), allocatable :: coorg_recv
integer, dimension(nspec) :: RGB_send
@@ -120,6 +130,7 @@
double precision coorg(NDIM,npgeo)
+
! title of the plot
character(len=60) simulation_title
@@ -1345,16 +1356,24 @@
!---- compute parameters for the spectral elements
- vpmin = HUGEVAL
- vpmax = -HUGEVAL
+ vpImin = HUGEVAL
+ vpImax = -HUGEVAL
- if(any_elastic) then
+ if(any_elastic .or. any_poroelastic) then
vsmin = HUGEVAL
vsmax = -HUGEVAL
else
vsmin = 0
vsmax = 0
endif
+
+ if(any_poroelastic) then
+ vpIImin = HUGEVAL
+ vpIImax = -HUGEVAL
+ else
+ vpIImin = 0
+ vpIImax = 0
+ endif
densmin = HUGEVAL
densmax = -HUGEVAL
@@ -1364,30 +1383,71 @@
courant_stability_number_max = -HUGEVAL
- lambdaPmin = HUGEVAL
- lambdaPmax = -HUGEVAL
+ lambdaPImin = HUGEVAL
+ lambdaPImax = -HUGEVAL
- if(any_elastic) then
+ if(any_elastic .or. any_poroelastic) then
lambdaSmin = HUGEVAL
lambdaSmax = -HUGEVAL
else
lambdaSmin = 0
lambdaSmax = 0
endif
+
+ if(any_poroelastic) then
+ lambdaPIImin = HUGEVAL
+ lambdaPIImax = -HUGEVAL
+ else
+ lambdaPIImin = 0
+ lambdaPIImax = 0
+ endif
do ispec=1,nspec
material = kmato(ispec)
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
+ phi = porosity(material)
+ tort = tortuosity(material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ denst_bar = (1.d0 - phi)*denst_s + phi*denst_f
+!Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = denst_bar - phi/tort*denst_f
+ bfactor = H_biot + phi*denst_bar/(tort*denst_f)*M_biot - 2.d0*phi/tort*C_biot
+ cfactor = phi/(tort*denst_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cssquare = mu_fr/afactor
- cploc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
+ cpIloc = sqrt(cpIsquare)
+ cpIIloc = sqrt(cpIIsquare)
+ csloc = sqrt(cssquare)
- vpmax_local = -HUGEVAL
- vpmin_local = HUGEVAL
+ if(phi >= 1.d0) then ! acoustic domain
+ cpIsquare = kappa_f/denst_f
+ cpIIsquare = 0.d0
+ denst_bar = denst_f
+ cpIloc = sqrt(cpIsquare)
+ cpIIloc = sqrt(cpIIsquare)
+ endif
+
+ vpImax_local = -HUGEVAL
+ vpImin_local = HUGEVAL
+ vpIImax_local = -HUGEVAL
+ vpIImin_local = HUGEVAL
vsmin_local = HUGEVAL
distance_min_local = HUGEVAL
@@ -1398,25 +1458,31 @@
!--- if heterogeneous formulation with external velocity model
if(assign_external_model) then
- cploc = vpext(i,j,ispec)
+ cpIloc = vpext(i,j,ispec)
csloc = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
+ denst_bar = rhoext(i,j,ispec)
endif
!--- compute min and max of velocity and density models
- vpmin = min(vpmin,cploc)
- vpmax = max(vpmax,cploc)
+ vpImin = min(vpImin,cpIloc)
+ vpImax = max(vpImax,cpIloc)
+! ignore acoustic and elastic regions with cpII = 0
+ if(cpIIloc > 0.0001d0) vpIImin = min(vpIImin,cpIIloc)
+ vpIImax = max(vpIImax,cpIIloc)
+
! ignore fluid regions with Vs = 0
- if(csloc > 0.0001d0) vsmin = min(vsmin,csloc)
+ if((assign_external_model .and. csloc > 0.0001d0) .or. (phi < 1.d0)) vsmin = min(vsmin,csloc)
vsmax = max(vsmax,csloc)
- densmin = min(densmin,denst)
- densmax = max(densmax,denst)
+ densmin = min(densmin,denst_bar)
+ densmax = max(densmax,denst_bar)
- vpmax_local = max(vpmax_local,cploc)
- vpmin_local = min(vpmin_local,cploc)
- vsmin_local = min(vsmin_local,csloc)
+ vpImax_local = max(vpImax_local,vpImax)
+ vpImin_local = min(vpImin_local,vpImin)
+ vpIImax_local = max(vpIImax_local,vpIImax)
+ vpIImin_local = min(vpIImin_local,vpIImin)
+ vsmin_local = min(vsmin_local,vsmin)
enddo
enddo
@@ -1440,23 +1506,31 @@
distance_min = min(distance_min,distance_min_local)
distance_max = max(distance_max,distance_max_local)
- courant_stability_number_max = max(courant_stability_number_max,vpmax_local * deltat / (distance_min_local * percent_GLL(NGLLX)))
+ courant_stability_number_max = max(courant_stability_number_max,vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX)))
! ignore fluid regions with Vs = 0
- if(csloc > 0.0001d0) then
+ if(phi < 1.d0) then
lambdaSmin = min(lambdaSmin,vsmin_local / (distance_max_local / (NGLLX - 1)))
lambdaSmax = max(lambdaSmax,vsmin_local / (distance_max_local / (NGLLX - 1)))
endif
- lambdaPmin = min(lambdaPmin,vpmin_local / (distance_max_local / (NGLLX - 1)))
- lambdaPmax = max(lambdaPmax,vpmin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPImin = min(lambdaPImin,vpImin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPImax = max(lambdaPImax,vpImin_local / (distance_max_local / (NGLLX - 1)))
+ if(cpIIloc > 0.0001d0) then
+ lambdaPIImin = min(lambdaPIImin,vpIImin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPIImax = max(lambdaPIImax,vpIImin_local / (distance_max_local / (NGLLX - 1)))
+ endif
+
enddo
any_elastic_glob = any_elastic
+ any_poroelastic_glob = any_poroelastic
#ifdef USE_MPI
- call MPI_ALLREDUCE (vpmin, vpmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (vpmax, vpmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpImin, vpImin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpImax, vpImax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpImin, vpIImin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpImax, vpIImax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (vsmin, vsmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (vsmax, vsmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (densmin, densmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
@@ -1465,13 +1539,18 @@
call MPI_ALLREDUCE (distance_max, distance_max_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (courant_stability_number_max, courant_stability_max_glob, 1, MPI_DOUBLE_PRECISION, &
MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPmin, lambdaPmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPmax, lambdaPmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPImin, lambdaPImin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPImax, lambdaPImax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPIImin, lambdaPIImin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPIImax, lambdaPIImax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (lambdaSmin, lambdaSmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (lambdaSmax, lambdaSmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (any_elastic, any_elastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
- vpmin = vpmin_glob
- vpmax = vpmax_glob
+ call MPI_ALLREDUCE (any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+ vpImin = vpImin_glob
+ vpImax = vpImax_glob
+ vpIImin = vpIImin_glob
+ vpIImax = vpIImax_glob
vsmin = vsmin_glob
vsmax = vsmax_glob
densmin = densmin_glob
@@ -1479,8 +1558,10 @@
distance_min = distance_min_glob
distance_max = distance_max_glob
courant_stability_number_max = courant_stability_max_glob
- lambdaPmin = lambdaPmin_glob
- lambdaPmax = lambdaPmax_glob
+ lambdaPImin = lambdaPImin_glob
+ lambdaPImax = lambdaPImax_glob
+ lambdaPIImin = lambdaPIImin_glob
+ lambdaPIImax = lambdaPIImax_glob
lambdaSmin = lambdaSmin_glob
lambdaSmax = lambdaSmax_glob
@@ -1489,7 +1570,8 @@
if ( myrank == 0 ) then
write(IOUT,*)
write(IOUT,*) '********'
- write(IOUT,*) 'Model: P velocity min,max = ',vpmin,vpmax
+ write(IOUT,*) 'Model: PI velocity min,max = ',vpImin,vpImax
+ write(IOUT,*) 'Model: PII velocity min,max = ',vpIImin,vpIImax
write(IOUT,*) 'Model: S velocity min,max = ',vsmin,vsmax
write(IOUT,*) 'Model: density min,max = ',densmin,densmax
write(IOUT,*) '********'
@@ -1504,7 +1586,7 @@
write(IOUT,*) '*** Min grid size = ',distance_min
write(IOUT,*) '*** Max/min ratio = ',distance_max/distance_min
write(IOUT,*)
- write(IOUT,*) '*** Max stability for P wave velocity = ',courant_stability_number_max
+ write(IOUT,*) '*** Max stability for P (or PI) wave velocity = ',courant_stability_number_max
write(IOUT,*)
@@ -1521,9 +1603,12 @@
write(IOUT,*) ' --> onset time ok'
endif
write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambdaPmin_fmax max = ',lambdaPmax/(2.5d0*f0)
- write(IOUT,*) ' Nb pts / lambdaPmin_fmax min = ',lambdaPmin/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaPImin_fmax max = ',lambdaPImax/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaPImin_fmax min = ',lambdaPImin/(2.5d0*f0)
write(IOUT,*) '----'
+ write(IOUT,*) ' Nb pts / lambdaPIImin_fmax max = ',lambdaPIImax/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaPIImin_fmax min = ',lambdaPIImin/(2.5d0*f0)
+ write(IOUT,*) '----'
write(IOUT,*) ' Nb pts / lambdaSmin_fmax max = ',lambdaSmax/(2.5d0*f0)
write(IOUT,*) ' Nb pts / lambdaSmin_fmax min = ',lambdaSmin/(2.5d0*f0)
write(IOUT,*) '----'
@@ -1769,16 +1854,33 @@
material = kmato(ispec)
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
+ phi=porosity(material)
+ tort=tortuosity(material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ denst_bar = (1.d0 - phi)*denst_s + phi*denst_f
+!Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = denst_bar - phi/tort*denst_f
+ bfactor = H_biot + phi*denst_bar/(tort*denst_f)*M_biot - 2.d0*phi/tort*C_biot
+ cfactor = phi/(tort*denst_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
- cploc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
+ cpIloc = sqrt(cpIsquare)
- vpmax_local = -HUGEVAL
- vpmin_local = HUGEVAL
- vsmin_local = HUGEVAL
+ vpImax_local = -HUGEVAL
distance_min_local = HUGEVAL
distance_max_local = -HUGEVAL
@@ -1788,14 +1890,12 @@
!--- if heterogeneous formulation with external velocity model
if(assign_external_model) then
- cploc = vpext(i,j,ispec)
+ cpIloc = vpext(i,j,ispec)
csloc = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
+ denst_bar = rhoext(i,j,ispec)
endif
- vpmax_local = max(vpmax_local,cploc)
- vpmin_local = min(vpmin_local,cploc)
- vsmin_local = min(vsmin_local,csloc)
+ vpImax_local = max(vpImax_local,cpIloc)
enddo
enddo
@@ -1819,7 +1919,7 @@
distance_min = min(distance_min,distance_min_local)
distance_max = max(distance_max,distance_max_local)
- courant_stability_number = vpmax_local * deltat / (distance_min_local * percent_GLL(NGLLX))
+ courant_stability_number = vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX))
! display bad elements that are above 80% of the threshold
if(courant_stability_number >= 0.80 * courant_stability_number_max) then
@@ -1900,7 +2000,7 @@
!
!---- open PostScript file
!
- if(any_elastic_glob) then
+ if(any_elastic_glob .or. any_poroelastic_glob) then
open(unit=24,file='OUTPUT_FILES/mesh_S_wave_dispersion.ps',status='unknown')
else
open(unit=24,file='OUTPUT_FILES/mesh_P_wave_dispersion.ps',status='unknown')
@@ -2101,15 +2201,45 @@
material = kmato(ispec)
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
+ phi = porosity(material)
+ tort = tortuosity(material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ denst_bar = (1.d0 - phi)*denst_s + phi*denst_f
+!Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = denst_bar - phi/tort*denst_f
+ bfactor = H_biot + phi*denst_bar/(tort*denst_f)*M_biot - 2.d0*phi/tort*C_biot
+ cfactor = phi/(tort*denst_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cssquare = mu_fr/afactor
- cploc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
+ cpIloc = sqrt(cpIsquare)
+ cpIIloc = sqrt(cpIIsquare)
+ csloc = sqrt(cssquare)
- vpmax_local = -HUGEVAL
- vpmin_local = HUGEVAL
+ if(csloc < TINYVAL) then ! acoustic domain
+ cpIsquare = kappa_f/denst_f
+ cpIIsquare = 0.d0
+ cpIloc = sqrt(cpIsquare)
+ cpIIloc = sqrt(cpIIsquare)
+ endif
+
+ vpImax_local = -HUGEVAL
+ vpImin_local = HUGEVAL
vsmin_local = HUGEVAL
distance_min_local = HUGEVAL
@@ -2120,13 +2250,13 @@
!--- if heterogeneous formulation with external velocity model
if(assign_external_model) then
- cploc = vpext(i,j,ispec)
+ cpIloc = vpext(i,j,ispec)
csloc = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
+ denst_bar = rhoext(i,j,ispec)
endif
- vpmax_local = max(vpmax_local,cploc)
- vpmin_local = min(vpmin_local,cploc)
+ vpImax_local = max(vpImax_local,cpIloc)
+ vpImin_local = min(vpImin_local,cpIloc)
vsmin_local = min(vsmin_local,csloc)
enddo
@@ -2152,7 +2282,7 @@
distance_max = max(distance_max,distance_max_local)
! display mesh dispersion for S waves if there is at least one elastic element in the mesh
- if(any_elastic_glob) then
+ if(any_elastic_glob .or. any_poroelastic_glob) then
! ignore fluid regions with Vs = 0
if(csloc > 0.0001d0) then
@@ -2193,13 +2323,13 @@
end if
endif
-! display mesh dispersion for P waves if there is no elastic element in the mesh
+! display mesh dispersion for P waves if there is no elastic/poroelastic element in the mesh
else
- lambdaP_local = vpmin_local / (distance_max_local / (NGLLX - 1))
+ lambdaPI_local = vpImin_local / (distance_max_local / (NGLLX - 1))
! display very good elements that are above 80% of the threshold in red
- if(lambdaP_local >= 0.80 * lambdaPmax) then
+ if(lambdaPI_local >= 0.80 * lambdaPImax) then
if ( myrank == 0 ) then
write(24,*) '1 0 0 RG GF 0 setgray ST'
else
@@ -2207,7 +2337,7 @@
end if
! display bad elements that are below 120% of the threshold in blue
- else if(lambdaP_local <= 1.20 * lambdaPmin) then
+ else if(lambdaPI_local <= 1.20 * lambdaPImin) then
if ( myrank == 0 ) then
write(24,*) '0 0 1 RG GF 0 setgray ST'
else
@@ -2481,17 +2611,43 @@
coorg_send(2,(ispec-1)*5+5) = z2
end if
- if((vpmax-vpmin)/vpmin > 0.02d0) then
+ if((vpImax-vpImin)/vpImin > 0.02d0) then
if(assign_external_model) then
! use lower-left corner
- x1 = (vpext(1,1,ispec)-vpmin) / (vpmax-vpmin)
+ x1 = (vpext(1,1,ispec)-vpImin) / (vpImax-vpImin)
else
material = kmato(ispec)
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
- cploc = sqrt(lambdaplus2mu/denst)
- x1 = (cploc-vpmin)/(vpmax-vpmin)
+ phi = porosity(material)
+ tort = tortuosity(material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ denst_bar = (1.d0 - phi)*denst_s + phi*denst_f
+!Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = denst_bar - phi/tort*denst_f
+ bfactor = H_biot + phi*denst_bar/(tort*denst_f)*M_biot - 2.d0*phi/tort*C_biot
+ cfactor = phi/(tort*denst_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cssquare = mu_fr/afactor
+ cpIloc = sqrt(cpIsquare)
+ csloc = sqrt(cssquare)
+ if(csloc < TINYVAL) then ! acoustic domain
+ cpIsquare = kappa_f/denst_f
+ cpIloc = sqrt(cpIsquare)
+ endif
+ x1 = (cpIloc-vpImin)/(vpImax-vpImin)
endif
else
x1 = 0.5d0
@@ -2566,7 +2722,7 @@
!
!---- open PostScript file
!
- open(unit=24,file='OUTPUT_FILES/mesh_partitioning.ps',status='unknown')
+ open(unit=24,file='OUTPUT_FILES/mesh_partition.ps',status='unknown')
!
!---- write PostScript header
@@ -2641,7 +2797,7 @@
write(24,*) '24.35 CM 18.9 CM MV'
write(24,*) usoffset,' CM 2 div neg 0 MR'
write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(Mesh partitioning) show'
+ write(24,*) '(Mesh stability condition \(red = bad\)) show'
write(24,*) 'grestore'
write(24,*) '25.35 CM 18.9 CM MV'
write(24,*) usoffset,' CM 2 div neg 0 MR'
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_Bielak_conditions.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_Bielak_conditions.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_Bielak_conditions.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_arrays_source.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_arrays_source.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_arrays_source.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,13 +1,15 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.2
+! S P E C F E M 2 D Version 6.3
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -125,3 +127,68 @@
end subroutine compute_arrays_source
+! ------------------------------------------------------------------------------------------------------
+
+
+ subroutine compute_arrays_adj_source(myrank,adj_source_file, &
+ xi_receiver,gamma_receiver, adj_sourcearray, &
+ xigll,zigll,NSTEP)
+
+
+ implicit none
+
+ include 'constants.h'
+
+! input
+ integer myrank, NSTEP
+
+ double precision xi_receiver, gamma_receiver
+
+ character(len=*) adj_source_file
+
+! output
+ real(kind=CUSTOM_REAL), dimension(NSTEP,NDIM,NGLLX,NGLLZ) :: adj_sourcearray
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hgammar(NGLLZ), hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL) :: adj_src_s(NSTEP,NDIM)
+
+ integer icomp, itime, i, k, ios
+ double precision :: junk
+ character(len=3) :: comp(2)
+ character(len=150) :: filename
+
+ call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
+
+ adj_sourcearray(:,:,:,:) = 0.
+
+ comp = (/"BHX","BHZ"/)
+
+ do icomp = 1, NDIM
+
+ filename = 'OUTPUT_FILES/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit = IIN, file = trim(filename), iostat = ios)
+ if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//'does not exist')
+
+ do itime = 1, NSTEP
+ read(IIN,*) junk, adj_src_s(itime,icomp)
+ enddo
+ close(IIN)
+
+ enddo
+
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ adj_sourcearray(:,:,i,k) = hxir(i) * hgammar(k) * adj_src_s(:,:)
+ enddo
+ enddo
+
+
+end subroutine compute_arrays_adj_source
+
+
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_energy.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_energy.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_energy.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,10 +4,12 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -41,14 +43,17 @@
!========================================================================
subroutine compute_energy(displ_elastic,veloc_elastic, &
+ displs_poroelastic,velocs_poroelastic,displw_poroelastic,velocw_poroelastic, &
xix,xiz,gammax,gammaz,jacobian,ibool,elastic,hprime_xx,hprime_zz, &
- nspec,npoin,assign_external_model,it,deltat,t0,kmato,elastcoef,density, &
+ nspec,npoin,assign_external_model,it,deltat,t0,kmato,poroelastcoef,density, &
+ porosity,tortuosity,&
vpext,vsext,rhoext,wxgll,wzgll,numat, &
pressure_element,vector_field_element,e1,e11, &
potential_dot_acoustic,potential_dot_dot_acoustic,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
-! compute kinetic and potential energy in the solid (acoustic elements are excluded)
+! compute kinetic and potential energy for elastic/acoustic/poroelastic
+
implicit none
include "constants.h"
@@ -74,7 +79,7 @@
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
@@ -82,11 +87,14 @@
logical :: assign_external_model
- double precision, dimension(numat) :: density
- double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: poroelastcoef
double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic,veloc_elastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displs_poroelastic,velocs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displw_poroelastic,velocw_poroelastic
! Gauss-Lobatto-Legendre points and weights
real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
@@ -102,12 +110,19 @@
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
! jacobian
real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
real(kind=CUSTOM_REAL) :: kinetic_energy,potential_energy
real(kind=CUSTOM_REAL) :: cpl,csl,rhol,mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
+ real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G,mul_C,lambdal_C,lambdalplus2mul_C,mul_M,lambdal_M,lambdalplus2mul_M
kinetic_energy = ZERO
potential_energy = ZERO
@@ -121,10 +136,10 @@
if(elastic(ispec)) then
! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- lambdalplus2mul_relaxed = elastcoef(3,kmato(ispec))
- rhol = density(kmato(ispec))
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
! double loop over GLL points
do j = 1,NGLLZ
@@ -183,6 +198,122 @@
enddo
!---
+!--- poroelastic spectral element
+!---
+ elseif(poroelastic(ispec)) then
+
+! get relaxed elastic parameters of current spectral element
+!for now replaced by solid, fluid, and frame parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+!The RHS has the form : div T -phi/c div T_f + phi/ceta_fk^-1.partial t w
+!where T = G:grad u_s + C div w I
+!and T_f = C div u_s I + M div w I
+!we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
+ mul_G = mul_fr
+ lambdal_G = H_biot - TWO*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+ mul_C = ZERO
+ lambdal_C = C_biot - 2.d0/3.d0*mul_C
+ lambdalplus2mul_C = lambdal_C + TWO*mul_C
+ mul_M = ZERO
+ lambdal_M = M_biot - 2.d0/3.d0*mul_M
+ lambdalplus2mul_M = lambdal_M + TWO*mul_M
+
+! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(k,i)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(k,i)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(k,j)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(k,j)
+
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(k,i)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(k,i)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(k,j)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(k,j)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+ jacobianl = jacobian(i,j,ispec)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+! compute potential energy
+ potential_energy = potential_energy + ( lambdalplus2mul_G*dux_dxl**2 &
+ + lambdalplus2mul_G*duz_dzl**2 &
+ + two*lambdal_G*dux_dxl*duz_dzl + mul_G*(dux_dzl + duz_dxl)**2 &
+ + two*lambdal_C*dwx_dxl*dux_dxl + two*lambdal_C*dwz_dzl*duz_dzl &
+ + two*lambdal_C*(dwx_dxl*duz_dzl + dwz_dzl*dux_dxl) &
+ + lambdal_M*dwx_dxl**2 + lambdal_M*dwz_dzl**2 &
+ + two*lambdal_M*dwx_dxl*dwz_dzl )*wxgll(i)*wzgll(j)*jacobianl / TWO
+
+
+! compute kinetic energy
+ if(phil > 0.0d0) then
+ kinetic_energy = kinetic_energy + ( &
+ rhol_bar*(velocs_poroelastic(1,ibool(i,j,ispec))**2 + velocs_poroelastic(2,ibool(i,j,ispec))**2) &
+ + rhol_f*tortl/phil*(velocw_poroelastic(1,ibool(i,j,ispec))**2 + velocw_poroelastic(2,ibool(i,j,ispec))**2) &
+ + rhol_f*(velocs_poroelastic(1,ibool(i,j,ispec))*velocw_poroelastic(1,ibool(i,j,ispec)) &
+ + velocs_poroelastic(2,ibool(i,j,ispec))*velocw_poroelastic(2,ibool(i,j,ispec))) &
+ )*wxgll(i)*wzgll(j)*jacobianl / TWO
+ else
+ kinetic_energy = kinetic_energy + &
+ rhol_s*(velocs_poroelastic(1,ibool(i,j,ispec))**2 + velocs_poroelastic(2,ibool(i,j,ispec))**2) &
+ *wxgll(i)*wzgll(j)*jacobianl / TWO
+ endif
+ enddo
+ enddo
+
+!---
!--- acoustic spectral element
!---
else
@@ -190,30 +321,30 @@
! for the definition of potential energy in an acoustic fluid, see for instance
! equation (23) of M. Maess et al., Journal of Sound and Vibration 296 (2006) 264-276
-! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
+! in case of an acoustic medium, a displacement potential Chi 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).
+! Displacement is then: u = grad(Chi)
+! Velocity is then: v = grad(Chi_dot) (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - rho * Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
! compute pressure in this element
- call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
+ call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
! compute velocity vector field in this element
- call compute_vector_one_element(vector_field_element,potential_dot_acoustic,veloc_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_one_element(vector_field_element,potential_dot_acoustic,veloc_elastic,&
+ velocs_poroelastic,elastic,poroelastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
-! get density of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- rhol = density(kmato(ispec))
- kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
- cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ cpl = sqrt(kappal_f/rhol_f)
! double loop over GLL points
do j = 1,NGLLZ
@@ -222,16 +353,16 @@
!--- if external medium, get density of current grid point
if(assign_external_model) then
cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
+ rhol_f = rhoext(i,j,ispec)
endif
! compute kinetic energy
kinetic_energy = kinetic_energy + &
- rhol*(vector_field_element(1,i,j)**2 + &
+ rhol_f*(vector_field_element(1,i,j)**2 + &
vector_field_element(2,i,j)**2) *wxgll(i)*wzgll(j)*jacobianl / TWO
! compute potential energy
- potential_energy = potential_energy + (pressure_element(i,j)**2)*wxgll(i)*wzgll(j)*jacobianl / (TWO * rhol * cpl**2)
+ potential_energy = potential_energy + (pressure_element(i,j)**2)*wxgll(i)*wzgll(j)*jacobianl / (TWO * rhol_f * cpl**2)
enddo
enddo
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_acoustic.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_acoustic.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_acoustic.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,13 +1,15 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.2
+! S P E C F E M 2 D Version 6.3
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -40,15 +42,22 @@
!
!========================================================================
- subroutine compute_forces_acoustic(npoin,nspec,nelemabs,numat, &
- anyabs,assign_external_model,ibool,kmato,numabs, &
- elastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
- vpext,rhoext,hprime_xx,hprimewgll_xx, &
+ subroutine compute_forces_acoustic(npoin,nspec,myrank,numat, &
+ iglob_source,ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ assign_external_model,initialfield,ibool,kmato, &
+ elastic,poroelastic,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,b_potential_dot_dot_acoustic,b_potential_acoustic,&
+ density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,source_time_function,adj_sourcearrays,hprime_xx,hprimewgll_xx, &
hprime_zz,hprimewgll_zz,wxgll,wzgll, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right, &
- nspec_inner_outer, ispec_inner_outer_to_glob, num_phase_inner_outer)
+ nspec_inner_outer, ispec_inner_outer_to_glob, num_phase_inner_outer, &
+ nrec,isolver,save_forward,b_absorb_acoustic_left,&
+ b_absorb_acoustic_right,b_absorb_acoustic_bottom,&
+ b_absorb_acoustic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax)
! compute forces for the acoustic elements
@@ -56,24 +65,36 @@
include "constants.h"
- integer :: npoin,nspec,nelemabs,numat
+ integer :: npoin,nspec,myrank,numat,iglob_source,ispec_selected_source,is_proc_source,source_type,it,NSTEP
+ integer :: nrec,isolver
+ integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nspec_xmin) :: ib_xmin,jbegin_left,jend_left
+ integer, dimension(nspec_xmax) :: ib_xmax,jbegin_right,jend_right
+ integer, dimension(nspec_zmin) :: ib_zmin,ibegin_bottom,iend_bottom
+ integer, dimension(nspec_zmax) :: ib_zmax,ibegin_top,iend_top
- logical :: anyabs,assign_external_model
+ logical :: anyabs,assign_external_model,initialfield
+ logical :: save_forward
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
integer, dimension(nspec) :: kmato
- integer, dimension(nelemabs) :: numabs,ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right
- logical, dimension(nspec) :: elastic
- logical, dimension(4,nelemabs) :: codeabs
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
- double precision, dimension(numat) :: density
- double precision, dimension(4,numat) :: elastcoef
+ real(kind=CUSTOM_REAL), dimension(npoin) :: b_potential_dot_dot_acoustic,b_potential_acoustic
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext
+ real(kind=CUSTOM_REAL), dimension(NSTEP) :: source_time_function
+ real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,NDIM,NGLLX,NGLLZ) :: adj_sourcearrays
+ double precision, dimension(NGLLZ,nspec_xmin,NSTEP) :: b_absorb_acoustic_left
+ double precision, dimension(NGLLZ,nspec_xmax,NSTEP) :: b_absorb_acoustic_right
+ double precision, dimension(NGLLX,nspec_zmax,NSTEP) :: b_absorb_acoustic_top
+ double precision, dimension(NGLLX,nspec_zmin,NSTEP) :: b_absorb_acoustic_bottom
! derivatives of Lagrange polynomials
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
@@ -91,19 +112,21 @@
!--- local variables
!---
- integer :: ispec,ispec_inner_outer,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend
+ integer :: ispec,ispec_inner_outer,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend,irec,irec_local
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,dux_dxl,dux_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_dux_dxl,b_dux_dzl
real(kind=CUSTOM_REAL) :: weight,xxi,zxi,xgamma,zgamma,jacobian1D
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2
! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl,nx,nz
-! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,kappal,cpl,rhol
+! material properties of the acoustic medium
+ real(kind=CUSTOM_REAL) :: kappal,cpl,rhol,rho_vp
! loop over spectral elements
do ispec_inner_outer = 1,nspec_inner_outer
@@ -113,10 +136,8 @@
!---
!--- acoustic spectral element
!---
- if(.not. elastic(ispec)) then
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
- rhol = density(kmato(ispec))
-
! first double loop over GLL points to compute and store gradients
do j = 1,NGLLZ
do i = 1,NGLLX
@@ -125,11 +146,20 @@
dux_dxi = ZERO
dux_dgamma = ZERO
+ b_dux_dxi = ZERO
+ b_dux_dgamma = ZERO
+
! first double loop over GLL points to compute and store gradients
! we can merge the two loops because NGLLX == NGLLZ
do k = 1,NGLLX
dux_dxi = dux_dxi + potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(isolver == 2) then
+ b_dux_dxi = b_dux_dxi + b_potential_acoustic(ibool(k,j,ispec))*hprime_xx(k,i)
+ b_dux_dgamma = b_dux_dgamma + b_potential_acoustic(ibool(i,k,ispec))*hprime_zz(k,j)
+ endif
+
enddo
xixl = xix(i,j,ispec)
@@ -141,16 +171,23 @@
dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+ if(isolver == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+ endif
+
jacobianl = jacobian(i,j,ispec)
-! if external density model
- if(assign_external_model) rhol = rhoext(i,j,ispec)
-
! for acoustic medium
! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl) / rhol
- tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl) / rhol
+ tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl)
+ tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl)
+ if(isolver == 2) then
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(xixl*b_dux_dxl + xizl*b_dux_dzl)
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*b_dux_dxl + gammazl*b_dux_dzl)
+ endif
+
enddo
enddo
@@ -167,6 +204,10 @@
do k = 1,NGLLX
potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - &
(tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
+ if(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ (b_tempx1(k,j)*hprimewgll_xx(i,k) + b_tempx2(i,k)*hprimewgll_zz(j,k))
+ endif
enddo
enddo ! second loop over the GLL points
@@ -184,20 +225,20 @@
!
if(anyabs) then
- do ispecabs=1,nelemabs
+!--- left absorbing boundary
+ if( nspec_xmin > 0 ) then
- ispec = numabs(ispecabs)
+ do ispecabs = 1, nspec_xmin
-! get elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
- rhol = density(kmato(ispec))
- cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
+ ispec = ib_xmin(ispecabs)
-!--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
+! get parameters of current spectral element
+! acoustic (fluid) properties
+ kappal = poroelastcoef(1,2,kmato(ispec))
+ rhol = density(2,kmato(ispec))
+ cpl = sqrt(kappal/rhol)
+
i = 1
jbegin = jbegin_left(ispecabs)
@@ -207,29 +248,56 @@
iglob = ibool(i,j,ispec)
+ zgamma = xix(i,j,ispec) * jacobian(i,j,ispec)
+
! external velocity model
if(assign_external_model) then
cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
endif
+ rho_vp = rhol*cpl
+
xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
weight = jacobian1D * wzgll(j)
! Sommerfeld condition if acoustic
- if(.not. elastic(ispec)) &
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ if(save_forward .and. isolver ==1) then
+ b_absorb_acoustic_left(j,ispecabs,it) = potential_dot_acoustic(iglob)*weight/cpl
+ elseif(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_left(j,ispecabs,NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
enddo
endif ! end of left absorbing boundary
!--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
+ if( nspec_xmax > 0 ) then
+
+ do ispecabs = 1, nspec_xmax
+ ispec = ib_xmax(ispecabs)
+
+! get parameters of current spectral element
+! acoustic (fluid) properties
+ kappal = poroelastcoef(1,2,kmato(ispec))
+ rhol = density(2,kmato(ispec))
+
+ cpl = sqrt(kappal/rhol)
+
i = NGLLX
jbegin = jbegin_right(ispecabs)
@@ -239,102 +307,227 @@
iglob = ibool(i,j,ispec)
+ zgamma = xix(i,j,ispec) * jacobian(i,j,ispec)
+
! external velocity model
if(assign_external_model) then
cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
endif
+ rho_vp = rhol*cpl
+
xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
weight = jacobian1D * wzgll(j)
! Sommerfeld condition if acoustic
- if(.not. elastic(ispec)) &
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ if(save_forward .and. isolver ==1) then
+ b_absorb_acoustic_right(j,ispecabs,it) = potential_dot_acoustic(iglob)*weight/cpl
+ elseif(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_right(j,ispecabs,NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
enddo
endif ! end of right absorbing boundary
!--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
+ if( nspec_zmin > 0) then
+ do ispecabs = 1, nspec_zmin
+
+ ispec = ib_zmin(ispecabs)
+
+! get parameters of current spectral element
+! acoustic (fluid) properties
+ kappal = poroelastcoef(1,2,kmato(ispec))
+ rhol = density(2,kmato(ispec))
+
+ cpl = sqrt(kappal/rhol)
+
j = 1
ibegin = ibegin_bottom(ispecabs)
iend = iend_bottom(ispecabs)
! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+ if( nspec_xmin > 0 ) ibegin = 2
+ if( nspec_xmax > 0 ) iend = NGLLX-1
do i = ibegin,iend
iglob = ibool(i,j,ispec)
+ xxi = gammaz(i,j,ispec) * jacobian(i,j,ispec)
+
! external velocity model
if(assign_external_model) then
cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
endif
+ rho_vp = rhol*cpl
+
xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
weight = jacobian1D * wxgll(i)
! Sommerfeld condition if acoustic
- if(.not. elastic(ispec)) &
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ if(save_forward .and. isolver ==1) then
+ b_absorb_acoustic_bottom(j,ispecabs,it) = potential_dot_acoustic(iglob)*weight/cpl
+ elseif(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_bottom(j,ispecabs,NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
enddo
endif ! end of bottom absorbing boundary
!--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
+ if( nspec_zmax > 0 ) then
+ do ispecabs = 1, nspec_zmax
+
+ ispec = ib_zmax(ispecabs)
+
+! get parameters of current spectral element
+! acoustic (fluid) properties
+ kappal = poroelastcoef(1,2,kmato(ispec))
+ rhol = density(2,kmato(ispec))
+
+ cpl = sqrt(kappal/rhol)
+
j = NGLLZ
ibegin = ibegin_top(ispecabs)
iend = iend_top(ispecabs)
! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+ if( nspec_xmin > 0) ibegin = 2
+ if( nspec_xmax > 0) iend = NGLLX-1
do i = ibegin,iend
iglob = ibool(i,j,ispec)
+ xxi = gammaz(i,j,ispec) * jacobian(i,j,ispec)
+
! external velocity model
if(assign_external_model) then
cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
endif
+ rho_vp = rhol*cpl
+
xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
weight = jacobian1D * wxgll(i)
! Sommerfeld condition if acoustic
- if(.not. elastic(ispec)) &
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ if(save_forward .and. isolver ==1) then
+ b_absorb_acoustic_top(j,ispecabs,it) = potential_dot_acoustic(iglob)*weight/cpl
+ elseif(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - b_absorb_acoustic_top(j,ispecabs,NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
enddo
endif ! end of top absorbing boundary
- enddo
-
endif ! end of absorbing boundaries
+! --- add the source
+ if(.not. initialfield) then
+
+ if (is_proc_source == 1 ) then
+! collocated force
+! beware, for acoustic medium, source is a pressure source
+ if(source_type == 1) then
+ if(.not. elastic(ispec_selected_source) .and. .not. poroelastic(ispec_selected_source)) then
+
+ if(isolver == 1) then ! forward wavefield
+ potential_dot_dot_acoustic(iglob_source) = potential_dot_dot_acoustic(iglob_source) + source_time_function(it)
+ else ! backward wavefield
+ b_potential_dot_dot_acoustic(iglob_source) = b_potential_dot_dot_acoustic(iglob_source) + source_time_function(NSTEP-it+1)
+ endif
+
+ endif
+
+! moment tensor
+ else if(source_type == 2) then
+
+ if(.not. elastic(ispec_selected_source) .and. .not. poroelastic(ispec_selected_source)) then
+ call exit_MPI('cannot have moment tensor source in acoustic element')
+ endif
+ endif
+ endif
+
+ if(isolver == 2) then ! adjoint wavefield
+ irec_local = 0
+ do irec = 1,nrec
+! add the source (only if this proc carries the source)
+ if(myrank == which_proc_receiver(irec)) then
+ if(.not. elastic(ispec_selected_rec(irec)) .and. .not. poroelastic(ispec_selected_rec(irec))) then
+ irec_local = irec_local + 1
+! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ xxi = + gammaz(i,j,ispec_selected_rec(irec)) * jacobian(i,j,ispec_selected_rec(irec))
+ zxi = - gammax(i,j,ispec_selected_rec(irec)) * jacobian(i,j,ispec_selected_rec(irec))
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*&
+ (nx*adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j) + nz*adj_sourcearrays(irec_local,NSTEP-it+1,2,i,j))
+ enddo
+ enddo
+ endif
+ endif ! if this processor carries the adjoint source
+ enddo ! irec = 1,nrec
+ endif ! isolver == 2 adjoint wavefield
+
+ else
+ call exit_MPI('wrong source type')
+ endif
+
endif ! end of computation that needs to be done only once, during the first call to compute_forces_acoustic
end subroutine compute_forces_acoustic
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_elastic.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_elastic.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_elastic.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,13 +1,15 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.2
+! S P E C F E M 2 D Version 6.3
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -40,19 +42,22 @@
!
!========================================================================
- subroutine compute_forces_elastic(npoin,nspec,nelemabs,numat, &
- ispec_selected_source,is_proc_source,source_type,it,NSTEP,anyabs,assign_external_model, &
+ subroutine compute_forces_elastic(npoin,nspec,myrank,nelemabs,numat,iglob_source, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs,assign_external_model, &
initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
- accel_elastic,veloc_elastic,displ_elastic,density,elastcoef,xix,xiz,gammax,gammaz, &
- jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,e1,e11, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,elastic, &
+ accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic,&
+ density,elastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,adj_sourcearrays,e1,e11, &
e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
nspec_inner_outer,ispec_inner_outer_to_glob,num_phase_inner_outer,deltat,coord,add_Bielak_conditions, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset,f0, &
- v0x_left,v0z_left,v0x_right,v0z_right,v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot,&
- nleft,nright,nbot,over_critical_angle)
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset,f0,&
+ nrec,isolver,save_forward,b_absorb_elastic_left,&
+ b_absorb_elastic_right,b_absorb_elastic_bottom,b_absorb_elastic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,mu_k,kappa_k)
! compute forces for the elastic elements
@@ -60,26 +65,40 @@
include "constants.h"
- integer :: npoin,nspec,nelemabs,numat,ispec_selected_source,is_proc_source,source_type,it,NSTEP
+ integer :: npoin,nspec,myrank,nelemabs,numat,iglob_source,ispec_selected_source,&
+ is_proc_source,source_type,it,NSTEP
+ integer :: nrec,isolver
+ integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nspec_xmin) :: ib_xmin
+ integer, dimension(nspec_xmax) :: ib_xmax
+ integer, dimension(nspec_zmin) :: ib_zmin
+ integer, dimension(nspec_zmax) :: ib_zmax
logical :: anyabs,assign_external_model,initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,add_Bielak_conditions
+ logical :: save_forward
double precision :: angleforce,deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
integer, dimension(nspec) :: kmato
- integer, dimension(nelemabs) :: numabs
logical, dimension(nspec) :: elastic
- logical, dimension(4,nelemabs) :: codeabs
real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: accel_elastic,veloc_elastic,displ_elastic
- double precision, dimension(numat) :: density
- double precision, dimension(4,numat) :: elastcoef
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accel_elastic,b_displ_elastic
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: elastcoef
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NSTEP) :: source_time_function
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,NDIM,NGLLX,NGLLZ) :: adj_sourcearrays
+ real(kind=CUSTOM_REAL), dimension(npoin) :: mu_k,kappa_k
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_elastic_left
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_elastic_right
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmax,NSTEP) :: b_absorb_elastic_top
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmin,NSTEP) :: b_absorb_elastic_bottom
integer :: N_SLS
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11,e13
@@ -108,15 +127,21 @@
!--- local variables
!---
- integer :: ispec,ispec_inner_outer,i,j,k,iglob,ispecabs,ibegin,iend
+ integer :: ispec,ispec_inner_outer,i,j,k,iglob,ispecabs,ibegin,iend,irec_local,irec
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
+ real(kind=CUSTOM_REAL) :: dsxx,dsxz,dszz
+ real(kind=CUSTOM_REAL) :: b_dsxx,b_dsxz,b_dszz
real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xz,sigma_zz
+ real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xz,b_sigma_zz
real(kind=CUSTOM_REAL) :: nx,nz,vx,vz,vn,rho_vp,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempz1,b_tempz2
! Jacobian matrix and determinant
real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
@@ -133,13 +158,6 @@
double precision, dimension(NDIM,npoin), intent(in) :: coord
double precision x0_source, z0_source, angleforce_refl, c_inc, c_refl, time_offset, f0
double precision, dimension(NDIM) :: A_plane, B_plane, C_plane
-!over critical angle
- logical :: over_critical_angle
- integer :: nleft, nright, nbot
- double precision, dimension(nleft) :: v0x_left,v0z_left,t0x_left,t0z_left
- double precision, dimension(nright) :: v0x_right,v0z_right,t0x_right,t0z_right
- double precision, dimension(nbot) :: v0x_bot,v0z_bot,t0x_bot,t0z_bot
- integer count_left,count_right,count_bot
! only for the first call to compute_forces_elastic (during computation on outer elements)
if ( num_phase_inner_outer ) then
@@ -160,9 +178,9 @@
if(elastic(ispec)) then
! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- lambdalplus2mul_relaxed = elastcoef(3,kmato(ispec))
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = elastcoef(3,1,kmato(ispec))
! first double loop over GLL points to compute and store gradients
do j = 1,NGLLZ
@@ -185,6 +203,14 @@
dux_dgamma = ZERO
duz_dgamma = ZERO
+ if(isolver == 2) then ! backward wavefield
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+ endif
+
! first double loop over GLL points to compute and store gradients
! we can merge the two loops because NGLLX == NGLLZ
do k = 1,NGLLX
@@ -192,6 +218,12 @@
duz_dxi = duz_dxi + displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
duz_dgamma = duz_dgamma + displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ if(isolver == 2) then ! backward wavefield
+ b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ endif
enddo
xixl = xix(i,j,ispec)
@@ -206,6 +238,14 @@
duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+ if(isolver == 2) then ! backward wavefield
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+ endif
+
! compute stress tensor (include attenuation or anisotropy if needed)
if(TURN_ATTENUATION_ON) then
@@ -249,6 +289,12 @@
sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+ if(isolver == 2) then ! backward wavefield
+ b_sigma_xx = lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
+ b_sigma_xz = mul_relaxed*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
+ endif
+
endif
! full anisotropy
@@ -261,6 +307,22 @@
endif
+! kernels calculation
+ if(isolver == 2) then
+ iglob = ibool(i,j,ispec)
+ dsxx = dux_dxl
+ dsxz = HALF * (duz_dxl + dux_dzl)
+ dszz = duz_dzl
+
+ b_dsxx = b_dux_dxl
+ b_dsxz = HALF * (b_duz_dxl + b_dux_dzl)
+ b_dszz = b_duz_dzl
+
+ kappa_k(iglob) = (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl)
+ mu_k(iglob) = dsxx * b_dsxx + dszz * b_dszz + &
+ 2._CUSTOM_REAL * dsxz * b_dsxz - 1._CUSTOM_REAL/3._CUSTOM_REAL * kappa_k(iglob)
+ endif
+
jacobianl = jacobian(i,j,ispec)
! weak formulation term based on stress tensor (non-symmetric form)
@@ -271,6 +333,14 @@
tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
+ if(isolver == 2) then ! backward wavefield
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
+ b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
+
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
+ b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
+ endif
+
enddo
enddo
@@ -288,6 +358,14 @@
do k = 1,NGLLX
accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tempz1(k,j)*hprimewgll_xx(k,i) + tempz2(i,k)*hprimewgll_zz(k,j))
+
+ if(isolver == 2) then ! backward wavefield
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
+ (b_tempx1(k,j)*hprimewgll_xx(k,i) + b_tempx2(i,k)*hprimewgll_zz(k,j))
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
+ (b_tempz1(k,j)*hprimewgll_xx(k,i) + b_tempz2(i,k)*hprimewgll_zz(k,j))
+ endif
+
enddo
enddo ! second loop over the GLL points
@@ -305,25 +383,21 @@
!
if(anyabs) then
- count_left=1
- count_right=1
- count_bot=1
+!--- left absorbing boundary
+ if( nspec_xmin > 0 ) then
- do ispecabs = 1,nelemabs
+ do ispecabs = 1, nspec_xmin
- ispec = numabs(ispecabs)
+ ispec = ib_xmin(ispecabs)
! get elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- rhol = density(kmato(ispec))
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
csl = sqrt(mul_relaxed/rhol)
-!--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
-
i = 1
do j = 1,NGLLZ
@@ -333,19 +407,11 @@
! for analytical initial plane wave for Bielak's conditions
! left or right edge, horizontal normal vector
if(add_Bielak_conditions .and. initialfield) then
- if (.not.over_critical_angle) then
- call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
- traction_z_t0 = mul_relaxed*(dxUz + dzUx)
- else
- veloc_horiz=v0x_left(count_left)
- veloc_vert=v0z_left(count_left)
- traction_x_t0=t0x_left(count_left)
- traction_z_t0=t0z_left(count_left)
- count_left=count_left+1
- end if
+ call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
+ traction_z_t0 = mul_relaxed*(dxUz + dzUx)
else
veloc_horiz = 0
veloc_vert = 0
@@ -383,15 +449,37 @@
accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz + traction_z_t0)*weight
- endif
+ if(save_forward .and. isolver ==1) then
+ b_absorb_elastic_left(1,j,ispecabs,it) = tx*weight
+ b_absorb_elastic_left(2,j,ispecabs,it) = tz*weight
+ elseif(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_left(1,j,ispecabs,NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_left(2,j,ispecabs,NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
enddo
endif ! end of left absorbing boundary
!--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
+ if( nspec_xmax > 0 ) then
+ do ispecabs = 1, nspec_xmax
+
+ ispec = ib_xmax(ispecabs)
+
+! get elastic parameters of current spectral element
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
+ csl = sqrt(mul_relaxed/rhol)
+
i = NGLLX
do j = 1,NGLLZ
@@ -401,19 +489,11 @@
! for analytical initial plane wave for Bielak's conditions
! left or right edge, horizontal normal vector
if(add_Bielak_conditions .and. initialfield) then
- if (.not.over_critical_angle) then
- call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
- traction_z_t0 = mul_relaxed*(dxUz + dzUx)
- else
- veloc_horiz=v0x_right(count_right)
- veloc_vert=v0z_right(count_right)
- traction_x_t0=t0x_right(count_right)
- traction_z_t0=t0z_right(count_right)
- count_right=count_right+1
- end if
+ call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
+ traction_z_t0 = mul_relaxed*(dxUz + dzUx)
else
veloc_horiz = 0
veloc_vert = 0
@@ -451,22 +531,44 @@
accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz - traction_z_t0)*weight
- endif
+ if(save_forward .and. isolver ==1) then
+ b_absorb_elastic_right(1,j,ispecabs,it) = tx*weight
+ b_absorb_elastic_right(2,j,ispecabs,it) = tz*weight
+ elseif(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_right(1,j,ispecabs,NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_right(2,j,ispecabs,NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
enddo
endif ! end of right absorbing boundary
!--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
+ if( nspec_zmin > 0 ) then
+ do ispecabs = 1, nspec_zmin
+
+ ispec = ib_zmin(ispecabs)
+
+! get elastic parameters of current spectral element
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
+ csl = sqrt(mul_relaxed/rhol)
+
j = 1
! exclude corners to make sure there is no contradiction on the normal
ibegin = 1
iend = NGLLX
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+ if( nspec_xmin > 0) ibegin = 2
+ if( nspec_xmax > 0) iend = NGLLX-1
do i = ibegin,iend
@@ -475,19 +577,11 @@
! for analytical initial plane wave for Bielak's conditions
! top or bottom edge, vertical normal vector
if(add_Bielak_conditions .and. initialfield) then
- if (.not.over_critical_angle) then
- call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = mul_relaxed*(dxUz + dzUx)
- traction_z_t0 = lambdal_relaxed*dxUx + (lambdal_relaxed+2*mul_relaxed)*dzUz
- else
- veloc_horiz=v0x_bot(count_bot)
- veloc_vert=v0z_bot(count_bot)
- traction_x_t0=t0x_bot(count_bot)
- traction_z_t0=t0z_bot(count_bot)
- count_bot=count_bot+1
- end if
+ call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = mul_relaxed*(dxUz + dzUx)
+ traction_z_t0 = lambdal_relaxed*dxUx + (lambdal_relaxed+2*mul_relaxed)*dzUz
else
veloc_horiz = 0
veloc_vert = 0
@@ -525,22 +619,44 @@
accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz + traction_z_t0)*weight
- endif
+ if(save_forward .and. isolver ==1) then
+ b_absorb_elastic_bottom(1,i,ispecabs,it) = tx*weight
+ b_absorb_elastic_bottom(2,i,ispecabs,it) = tz*weight
+ elseif(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_bottom(1,i,ispecabs,NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_bottom(2,i,ispecabs,NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
enddo
endif ! end of bottom absorbing boundary
!--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
+ if( nspec_zmax > 0 ) then
+ do ispecabs = 1, nspec_zmax
+
+ ispec = ib_zmax(ispecabs)
+
+! get elastic parameters of current spectral element
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
+ csl = sqrt(mul_relaxed/rhol)
+
j = NGLLZ
! exclude corners to make sure there is no contradiction on the normal
ibegin = 1
iend = NGLLX
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+ if( nspec_xmin > 0) ibegin = 2
+ if( nspec_xmax > 0) iend = NGLLX-1
do i = ibegin,iend
@@ -591,35 +707,90 @@
accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz - traction_z_t0)*weight
- endif
+ if(save_forward .and. isolver ==1) then
+ b_absorb_elastic_top(1,i,ispecabs,it) = tx*weight
+ b_absorb_elastic_top(2,i,ispecabs,it) = tz*weight
+ elseif(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_top(1,i,ispecabs,NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_top(2,i,ispecabs,NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
enddo
endif ! end of top absorbing boundary
- enddo
-
endif ! end of absorbing boundaries
-! --- add the source if it is a moment tensor
+! --- add the source
if(.not. initialfield) then
! if this processor carries the source and the source element is elastic
if (is_proc_source == 1 .and. elastic(ispec_selected_source)) then
+! collocated force
+! beware, for acoustic medium, source is a potential, therefore source time function
+! gives shape of velocity, not displacement
+ if(source_type == 1) then
+
+ if(isolver == 1) then ! forward wavefield
+ accel_elastic(1,iglob_source) = accel_elastic(1,iglob_source) - sin(angleforce)*source_time_function(it)
+ accel_elastic(2,iglob_source) = accel_elastic(2,iglob_source) + cos(angleforce)*source_time_function(it)
+ else ! backward wavefield
+ b_accel_elastic(1,iglob_source) = b_accel_elastic(1,iglob_source) - sin(angleforce)*source_time_function(NSTEP-it+1)
+ b_accel_elastic(2,iglob_source) = b_accel_elastic(2,iglob_source) + cos(angleforce)*source_time_function(NSTEP-it+1)
+ endif !endif isolver == 1
+
! moment tensor
- if(source_type == 2) then
+ else if(source_type == 2) then
+
+ if(isolver == 1) then ! forward wavefield
! add source array
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source)
- accel_elastic(:,iglob) = accel_elastic(:,iglob) + sourcearray(:,i,j)*source_time_function(it)
- enddo
- enddo
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source)
+ accel_elastic(:,iglob) = accel_elastic(:,iglob) + sourcearray(:,i,j)*source_time_function(it)
+ enddo
+ enddo
+ else ! backward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source)
+ b_accel_elastic(:,iglob) = b_accel_elastic(:,iglob) + sourcearray(:,i,j)*source_time_function(NSTEP-it+1)
+ enddo
+ enddo
+ endif !endif isolver == 1
+
+ else
+ call exit_MPI('wrong source type in elastic element')
endif
endif ! if this processor carries the source and the source element is elastic
+ if(isolver == 2) then ! adjoint wavefield
+
+ irec_local = 0
+ do irec = 1,nrec
+! add the source (only if this proc carries the source)
+ if(myrank == which_proc_receiver(irec) .and. elastic(ispec_selected_rec(irec))) then
+
+ irec_local = irec_local + 1
+! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ accel_elastic(:,iglob) = accel_elastic(:,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,:,i,j)
+ enddo
+ enddo
+
+ endif ! if this processor carries the adjoint source and the source element is elastic
+ enddo ! irec = 1,nrec
+
+ endif ! if isolver == 2 adjoint wavefield
+
endif ! if not using an initial field
else
@@ -694,7 +865,7 @@
endif ! end of test on attenuation
- endif ! end of test on attenuation
+ endif ! if ( num_phase_inner_outer )
end subroutine compute_forces_elastic
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_gradient_attenuation.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_gradient_attenuation.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_gradient_attenuation.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_pressure.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_pressure.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_pressure.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,10 +4,12 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -40,9 +42,10 @@
!
!========================================================================
- subroutine compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,elastic,vector_field_display, &
+ subroutine compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,e1,e11, &
TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
! compute pressure in acoustic elements and in elastic elements
@@ -56,14 +59,16 @@
integer, dimension(nspec) :: kmato
integer, dimension(NGLLX,NGLLX,nspec) :: ibool
- double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: poroelastcoef
double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_dot_dot_acoustic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic,displs_poroelastic,displw_poroelastic
double precision, dimension(NDIM,npoin) :: vector_field_display
! array with derivatives of Lagrange polynomials
@@ -86,9 +91,10 @@
do ispec = 1,nspec
! compute pressure in this element
- call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
+ call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
! use vector_field_display as temporary storage, store pressure in its second component
@@ -107,12 +113,13 @@
!=====================================================================
!
- subroutine compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
+ subroutine compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
-! compute pressure in acoustic elements and in elastic elements
+! compute pressure in acoustic elements and in (poro)elastic elements
implicit none
@@ -123,7 +130,9 @@
integer, dimension(nspec) :: kmato
integer, dimension(NGLLX,NGLLX,nspec) :: ibool
- double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: poroelastcoef
double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
@@ -131,9 +140,9 @@
! pressure in this element
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_dot_dot_acoustic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic,displs_poroelastic,displw_poroelastic
! array with derivatives of Lagrange polynomials
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
@@ -156,12 +165,21 @@
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: sigma_xx,sigma_zz
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_zz,sigmap
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dzl
-! material properties of the elastic medium
+! material properties of the (poro)elastic medium
+ integer :: material
real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,denst
real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed,cpl,csl
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
+ real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
+
! if elastic element
!
! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction,
@@ -187,9 +205,9 @@
if(elastic(ispec)) then
! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- lambdalplus2mul_relaxed = elastcoef(3,kmato(ispec))
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec))
do j = 1,NGLLZ
do i = 1,NGLLX
@@ -283,16 +301,158 @@
enddo
enddo
-! pressure = - Chi_dot_dot if acoustic element
+ elseif(poroelastic(ispec)) then
+
+! get poroelastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+!where T = G:grad u_s + C div w I
+!and T_f = C div u_s I + M div w I
+!we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
+ mul_G = mul_fr
+ lambdal_G = H_biot - TWO*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+!--- if external medium, get elastic parameters of current grid point
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+! mul_relaxed = denst*csl*csl
+! lambdal_relaxed = denst*cpl*cpl - TWO*mul_relaxed
+ endif
+
+! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+! compute diagonal components of the stress tensor (include attenuation or anisotropy if needed)
+
+ if(TURN_ATTENUATION_ON) then
+!-------------------- ATTENTION TO BE DEFINED ------------------------------!
+
+! attenuation is implemented following the memory variable formulation of
+! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993). More details can be found in
+! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1 - mul_relaxed * Mu_nu2
+ mul_unrelaxed = mul_relaxed * Mu_nu2
+ lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
+
+! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
+ sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
+
+! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
+! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
+ e1_sum = 0._CUSTOM_REAL
+ e11_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_SLS
+ e1_sum = e1_sum + e1(i,j,ispec,i_sls)
+ e11_sum = e11_sum + e11(i,j,ispec,i_sls)
+ enddo
+
+ sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum + TWO * mul_relaxed * e11_sum
+ sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum - TWO * mul_relaxed * e11_sum
+
else
+! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+ endif
+
+! full anisotropy
+ if(TURN_ANISOTROPY_ON) then
+!-------------------- ATTENTION TO BE DEFINED ------------------------------!
+
+! implement anisotropy in 2D
+ sigma_xx = c11val*dux_dxl + c15val*(duz_dxl + dux_dzl) + c13val*duz_dzl
+ sigma_zz = c13val*dux_dxl + c35val*(duz_dxl + dux_dzl) + c33val*duz_dzl
+
+ endif
+
+! store pressure
+ pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
+! pressure_element2(i,j) = - sigmap
+ enddo
+ enddo
+
+ else ! pressure = - rho * Chi_dot_dot if acoustic element
+
do j = 1,NGLLZ
do i = 1,NGLLX
iglob = ibool(i,j,ispec)
+ material = kmato(ispec)
+ denst = density(2,material)
+ if(assign_external_model) denst = rhoext(i,j,ispec)
+
! store pressure
- pressure_element(i,j) = - potential_dot_dot_acoustic(iglob)
+ pressure_element(i,j) = - denst * potential_dot_dot_acoustic(iglob)
enddo
enddo
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_vector_field.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_vector_field.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_vector_field.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,13 +1,15 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.2
+! S P E C F E M 2 D Version 6.3
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -40,8 +42,9 @@
!
!========================================================================
- subroutine compute_vector_whole_medium(potential_acoustic,veloc_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
+ subroutine compute_vector_whole_medium(potential_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
! compute Grad(potential) in acoustic elements
! and combine with existing velocity vector field in elastic elements
@@ -50,23 +53,15 @@
include "constants.h"
- integer nspec,npoin,numat
+ integer nspec,npoin
- logical :: assign_external_model
-
- integer, dimension(nspec) :: kmato
-
- double precision, dimension(NGLLX,NGLLX,nspec) :: rhoext
-
- double precision, dimension(numat) :: density
-
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_acoustic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: veloc_elastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: veloc_elastic,velocs_poroelastic
double precision, dimension(NDIM,npoin) :: vector_field_display
! array with derivatives of Lagrange polynomials
@@ -83,8 +78,9 @@
do ispec = 1,nspec
! compute vector field in this element
- call compute_vector_one_element(vector_field_element,potential_acoustic,veloc_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_one_element(vector_field_element,potential_acoustic,veloc_elastic,&
+ velocs_poroelastic,elastic,poroelastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
! store the result
do j = 1,NGLLZ
@@ -102,8 +98,9 @@
!=====================================================================
!
- subroutine compute_vector_one_element(vector_field_element,potential_acoustic,veloc_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
+ subroutine compute_vector_one_element(vector_field_element,potential_acoustic,veloc_elastic,&
+ velocs_poroelastic,elastic,poroelastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
! compute Grad(potential) if acoustic element or copy existing vector if elastic element
@@ -111,16 +108,8 @@
include "constants.h"
- integer nspec,npoin,ispec,numat
+ integer nspec,npoin,ispec
- logical :: assign_external_model
-
- integer, dimension(nspec) :: kmato
-
- double precision, dimension(NGLLX,NGLLX,nspec) :: rhoext
-
- double precision, dimension(numat) :: density
-
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
@@ -128,9 +117,9 @@
! vector field in this element
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_acoustic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: veloc_elastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: veloc_elastic,velocs_poroelastic
! array with derivatives of Lagrange polynomials
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
@@ -146,9 +135,6 @@
! jacobian
real(kind=CUSTOM_REAL) xixl,xizl,gammaxl,gammazl
-! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: rhol
-
! simple copy of existing vector if elastic element
if(elastic(ispec)) then
@@ -160,12 +146,18 @@
enddo
enddo
+ elseif(poroelastic(ispec)) then
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_element(1,i,j) = velocs_poroelastic(1,iglob)
+ vector_field_element(2,i,j) = velocs_poroelastic(2,iglob)
+ enddo
+ enddo
+
! compute gradient of potential to calculate vector if acoustic element
-! we then need to divide by density because the potential is a potential of (density * displacement)
else
- rhol = density(kmato(ispec))
-
! double loop over GLL points to compute and store gradients
do j = 1,NGLLZ
do i = 1,NGLLX
@@ -191,11 +183,9 @@
gammaxl = gammax(i,j,ispec)
gammazl = gammaz(i,j,ispec)
- if(assign_external_model) rhol = rhoext(i,j,ispec)
-
! derivatives of potential
- vector_field_element(1,i,j) = (tempx1l*xixl + tempx2l*gammaxl) / rhol
- vector_field_element(2,i,j) = (tempx1l*xizl + tempx2l*gammazl) / rhol
+ vector_field_element(1,i,j) = tempx1l*xixl + tempx2l*gammaxl
+ vector_field_element(2,i,j) = tempx1l*xizl + tempx2l*gammazl
enddo
enddo
Modified: seismo/2D/SPECFEM2D/branches/BIOT/constants.h
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/constants.h 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/constants.h 2008-09-11 18:24:41 UTC (rev 12864)
@@ -25,10 +25,6 @@
! select fast (Paul Fischer) or slow (topology only) global numbering algorithm
logical, parameter :: FAST_NUMBERING = .true.
-! further reduce cache misses inner/outer in two passes in the case of an MPI simulation
-! this flag is ignored in the case of a serial simulation
- logical, parameter :: FURTHER_REDUCE_CACHE_MISSES = .true.
-
! mesh tolerance for fast global numbering
double precision, parameter :: SMALLVALTOL = 0.000001d0
Modified: seismo/2D/SPECFEM2D/branches/BIOT/construct_acoustic_surface.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/construct_acoustic_surface.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/construct_acoustic_surface.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/convolve_source_timefunction.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/convolve_source_timefunction.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/convolve_source_timefunction.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/create_color_image.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/create_color_image.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/create_color_image.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
@@ -252,7 +252,7 @@
close(27)
! open image file and create system command to convert image to more convenient format
- write(system_command,"('cd OUTPUT_FILES ; convert image',i7.7,'.pnm image',i7.7,'.gif')") it,it
+ write(system_command,"('cd OUTPUT_FILES ; convert image',i7.7,'.pnm image',i7.7,'.gif ; rm -f image',i7.7,'.pnm')") it,it,it
! call the system to convert image to GIF
call system(system_command)
Modified: seismo/2D/SPECFEM2D/branches/BIOT/createnum_fast.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/createnum_fast.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/createnum_fast.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/createnum_slow.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/createnum_slow.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/createnum_slow.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/datim.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/datim.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/datim.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/define_derivation_matrices.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/define_derivation_matrices.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/define_derivation_matrices.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/define_external_model.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/define_external_model.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/define_external_model.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/define_shape_functions.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/define_shape_functions.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/define_shape_functions.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/enforce_acoustic_free_surface.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/enforce_acoustic_free_surface.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/enforce_acoustic_free_surface.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/gmat01.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/gmat01.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/gmat01.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,16 +1,18 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.2
+! S P E C F E M 2 D Version 6.3
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic wave equation
+! the two-dimensional viscoelastic anisotropic and poroelastic wave equations
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
@@ -40,71 +42,95 @@
!
!========================================================================
- subroutine gmat01(density_array,elastcoef,numat)
+ subroutine gmat01(density_array,porosity_array,tortuosity_array,permeability,poroelastcoef,numat)
-! read properties of a 2D isotropic or anisotropic linear elastic element
+! read properties of a 2D isotropic or anisotropic (to be defined) linear elastic element
+! velocities cpI, cpII, and cs are calculated using solid, fluid, and frame properties
implicit none
include "constants.h"
character(len=80) datlin
- double precision lambdaplus2mu,kappa
integer numat
- double precision density_array(numat),elastcoef(4,numat)
+ double precision density_array(2,numat),poroelastcoef(4,3,numat),porosity_array(numat)
+ double precision tortuosity_array(numat),permeability(3,numat)
integer in,n,indic
- double precision young,poisson,density,cp,cs,mu,two_mu,lambda
- double precision val1,val2,val3,val4
+ double precision lambdaplus2mu_s,lambdaplus2mu_fr,kappa_s,kappa_f,kappa_fr
+ double precision young_s,poisson_s,density(2),phi,tortuosity,permxx,permzz,permxz
+ double precision cpIsquare,cpIIsquare,cssquare,mu_s,mu_fr,eta_f,lambda_s,lambda_fr
+ double precision vals(2),valf(2),valfr(2)
double precision c11,c13,c33,c44
+ double precision afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,density_bar
!
!---- loop over the different material sets
!
- density_array(:) = zero
- elastcoef(:,:) = zero
+ density_array(:,:) = zero
+ porosity_array(:) = zero
+ tortuosity_array(:) = zero
+ permeability(:,:) = zero
+ poroelastcoef(:,:,:) = zero
write(iout,100) numat
read(iin ,"(a80)") datlin
do in = 1,numat
- read(iin ,*) n,indic,density,val1,val2,val3,val4
+ read(iin ,*) n,indic,density(1),density(2),phi,tortuosity,permxx,permxz,permzz,vals(1),valf(1),valfr(1),vals(2),valf(2),valfr(2)
if(n<1 .or. n>numat) call exit_MPI('Wrong material set number')
-!---- isotropic material, P and S velocities given
+!---- isotropic material, kappa and mu/eta, for solid, fluid, and frame given
if(indic == 1) then
-! P and S velocity
- cp = val1
- cs = val2
+! Solid properties
+ kappa_s = vals(1)
+ mu_s = vals(2)
+! Fluid properties
+ kappa_f = valf(1)
+ eta_f = valf(2)
+! Frame properties
+ kappa_fr = valfr(1)
+ mu_fr = valfr(2)
+! Lam'e parameters for the solid phase and the frame
+ lambdaplus2mu_s = kappa_s + FOUR_THIRDS*mu_s
+ lambda_s = lambdaplus2mu_s - 2.d0*mu_s
+ lambdaplus2mu_fr = kappa_fr + FOUR_THIRDS*mu_fr
+ lambda_fr = lambdaplus2mu_fr - 2.d0*mu_fr
-! Lam'e parameters
- lambdaplus2mu = density*cp*cp
- mu = density*cs*cs
- two_mu = 2.d0*mu
- lambda = lambdaplus2mu - two_mu
+! Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+! Approximated velocities (no viscous dissipation)
+ density_bar = (1.d0 - phi)*density(1) + phi*density(2)
+ afactor = density_bar - phi/tortuosity*density(2)
+ bfactor = H_biot + phi*density_bar/(tortuosity*density(2))*M_biot - 2.d0*phi/tortuosity*C_biot
+ cfactor = phi/(tortuosity*density(2))*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cssquare = mu_fr/afactor
-! bulk modulus Kappa
- kappa = lambda + two_mu/3.d0
+! Young modulus for the solid phase
+ young_s = 9.d0*kappa_s*mu_s/(3.d0*kappa_s + mu_s)
-! Young modulus
- young = 9.d0*kappa*mu/(3.d0*kappa + mu)
+! Poisson's ratio for the solid phase
+ poisson_s = HALF*(3.d0*kappa_s- 2.d0*mu_s)/(3.d0*kappa_s+mu_s)
-! Poisson's ratio
- poisson = half*(3.d0*kappa-two_mu)/(3.d0*kappa+mu)
-
! Poisson's ratio must be between -1 and +1/2
- if (poisson < -1.d0 .or. poisson > 0.5d0) call exit_MPI('Poisson''s ratio out of range')
+ if (poisson_s < -1.d0 .or. poisson_s > 0.5d0) stop 'Poisson''s ratio for the solid phase out of range'
!---- anisotropic material, c11, c13, c33 and c44 given in Pascal
else if (indic == 2) then
- c11 = val1
- c13 = val2
- c33 = val3
- c44 = val4
+ stop 'Attention, anisotropic still needs to be defined'
+! c11 = val1
+! c13 = val2
+! c33 = val3
+! c44 = val4
else
call exit_MPI('wrong model flag read')
@@ -114,35 +140,59 @@
!
!---- set elastic coefficients and density
!
-! Isotropic : lambda, mu, K (= lambda + 2*mu), zero
+! Isotropic : lambda, mu, K (= lambda + 2*mu), zero for the solid phase (1) and the frame (3)
! Transverse anisotropic : c11, c13, c33, c44
!
if(indic == 1) then
- elastcoef(1,n) = lambda
- elastcoef(2,n) = mu
- elastcoef(3,n) = lambdaplus2mu
- elastcoef(4,n) = zero
+ poroelastcoef(1,1,n) = lambda_s
+ poroelastcoef(2,1,n) = mu_s
+ poroelastcoef(3,1,n) = lambdaplus2mu_s
+ poroelastcoef(4,1,n) = zero
+
+ poroelastcoef(1,2,n) = kappa_f
+ poroelastcoef(2,2,n) = eta_f
+ poroelastcoef(3,2,n) = zero
+ poroelastcoef(4,2,n) = zero
+
+ poroelastcoef(1,3,n) = lambda_fr
+ poroelastcoef(2,3,n) = mu_fr
+ poroelastcoef(3,3,n) = lambdaplus2mu_fr
+ poroelastcoef(4,3,n) = zero
else
- elastcoef(1,n) = c11
- elastcoef(2,n) = c13
- elastcoef(3,n) = c33
- elastcoef(4,n) = c44
+ stop 'Attention, anisotropic still needs to be defined'
+ poroelastcoef(1,1,n) = c11
+ poroelastcoef(2,1,n) = c13
+ poroelastcoef(3,1,n) = c33
+ poroelastcoef(4,1,n) = c44
endif
- density_array(n) = density
+ density_array(1,n) = density(1)
+ density_array(2,n) = density(2)
+ porosity_array(n) = phi
+ tortuosity_array(n) = tortuosity
+ permeability(1,n) = permxx
+ permeability(2,n) = permxz
+ permeability(3,n) = permzz
!
!---- check the input
!
if(indic == 1) then
-! material can be acoustic (fluid) or elastic (solid)
- if(elastcoef(2,n) > TINYVAL) then
- write(iout,200) n,cp,cs,density,poisson,lambda,mu,kappa,young
- else
- write(iout,300) n,cp,density,kappa
+! material can be acoustic (fluid) or poroelastic (solid/fluid) or elastic (solid)
+ if(phi < TINYVAL) then ! material is elastic
+ write(iout,800) n,sqrt(cpIsquare),sqrt(cssquare),density(1),poisson_s,lambda_s,mu_s,kappa_s,young_s
+ elseif(phi >=1.d0)then ! material is acoustic
+ write(iout,900) n,sqrt(kappa_f/density(2)),density(2),kappa_f
+ else ! material is poroelastic
+ write(iout,200) n,sqrt(cpIsquare),sqrt(cpIIsquare),sqrt(cssquare)
+ write(iout,300) density(1),poisson_s,lambda_s,mu_s,kappa_s,young_s
+ write(iout,400) density(2),kappa_f,eta_f
+ write(iout,500) lambda_fr,mu_fr,kappa_fr,phi,tortuosity,permxx,permxz,permzz
+ write(iout,600) D_biot,H_biot,C_biot,M_biot
endif
else
- write(iout,400) n,c11,c13,c33,c44,density,sqrt(c33/density),sqrt(c11/density),sqrt(c44/density),sqrt(c44/density)
+ stop 'Attention, anisotropic still needs to be defined'
+ write(iout,700) n,c11,c13,c33,c44,density(1),sqrt(c33/density(1)),sqrt(c11/density(1)),sqrt(c44/density(1)),sqrt(c44/density(1))
endif
enddo
@@ -151,31 +201,52 @@
!---- formats
!
100 format(//,' M a t e r i a l s e t s : ', &
- ' 2 D e l a s t i c i t y', &
+ ' 2 D (p o r o) e l a s t i c i t y', &
/1x,54('='),//5x,'Number of material sets . . . . . . (numat) =',i6)
200 format(//5x,'----------------------------------------',/5x, &
- '-- Elastic (solid) isotropic material --',/5x, &
+ '-- Poroelastic isotropic material --',/5x, &
'----------------------------------------',/5x, &
'Material set number. . . . . . . . (jmat) =',i6,/5x, &
- 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
- 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8,/5x, &
- 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
- 'Poisson''s ratio. . . . . . . . .(poisson) =',1pe15.8,/5x, &
- 'First Lame parameter Lambda. . . (lambda) =',1pe15.8,/5x, &
- 'Second Lame parameter Mu. . . . . . .(mu) =',1pe15.8,/5x, &
- 'Bulk modulus Kappa . . . . . . . .(kappa) =',1pe15.8,/5x, &
- 'Young''s modulus E. . . . . . . . .(young) =',1pe15.8)
+ 'First P-wave velocity. . . . . . . . . . . (cpI) =',1pe15.8,/5x, &
+ 'Second P-wave velocity. . . . . . . . . . . (cpII) =',1pe15.8,/5x, &
+ 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8)
300 format(//5x,'-------------------------------',/5x, &
- '-- Acoustic (fluid) material --',/5x, &
+ '-- Solid phase properties --',/5x, &
+ 'Mass density. . . . . . . . . . (density_s) =',1pe15.8,/5x, &
+ 'Poisson''s ratio. . . . . . . . .(poisson_s) =',1pe15.8,/5x, &
+ 'First Lame parameter Lambda. . . (lambda_s) =',1pe15.8,/5x, &
+ 'Second Lame parameter Mu. . . . . . .(mu_s) =',1pe15.8,/5x, &
+ 'Solid bulk modulus Kappa . . . . . . . .(kappa_s) =',1pe15.8,/5x, &
+ 'Young''s modulus E. . . . . . . . .(young_s) =',1pe15.8)
+
+ 400 format(//5x,'-------------------------------',/5x, &
+ '-- Fluid phase properties --',/5x, &
+ 'Mass density. . . . . . . . . . (density_f) =',1pe15.8,/5x, &
+ 'Fluid bulk modulus Kappa . . . . . . . .(kappa_f) =',1pe15.8,/5x, &
+ 'Fluid viscosity Eta . . . . . . . .(eta_f) =',1pe15.8)
+
+ 500 format(//5x,'-------------------------------',/5x, &
+ '-- Frame properties --',/5x, &
+ 'First Lame parameter Lambda. . . (lambda_fr) =',1pe15.8,/5x, &
+ 'Second Lame parameter Mu. . . . . . .(mu_fr) =',1pe15.8,/5x, &
+ 'Frame bulk modulus Kappa . . . . . . . .(kappa_fr) =',1pe15.8,/5x, &
+ 'Porosity. . . . . . . . . . . . . . . . .(phi) =',1pe15.8,/5x,&
+ 'Tortuosity. . . . . . . . . . . . . . . . . . =',1pe15.8,/5x,&
+ 'Permeability xx component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Permeability zx component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Permeability zz component. . . . . . . . . . =',1pe15.8)
+
+ 600 format(//5x,'-------------------------------',/5x, &
+ '-- Biot coefficients --',/5x, &
'-------------------------------',/5x, &
- 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
- 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
- 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
- 'Bulk modulus Kappa . . . . . . . .(kappa) =',1pe15.8)
+ 'D. . . . . . . . =',1pe15.8,/5x, &
+ 'H. . . . . . . . =',1pe15.8,/5x, &
+ 'C. . . . . . . . =',1pe15.8,/5x, &
+ 'M. . . . . . . . =',1pe15.8)
- 400 format(//5x,'-------------------------------------',/5x, &
+ 700 format(//5x,'-------------------------------------',/5x, &
'-- Transverse anisotropic material --',/5x, &
'-------------------------------------',/5x, &
'Material set number. . . . . . . . (jmat) =',i6,/5x, &
@@ -189,5 +260,26 @@
'Velocity of qSV along vertical axis . . . =',1pe15.8,/5x, &
'Velocity of qSV along horizontal axis . . =',1pe15.8)
+ 800 format(//5x,'--------------------------------------------------',/5x, &
+ '-- Elastic (solid - phi = 0) isotropic material --',/5x, &
+ '--------------------------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
+ 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
+ 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8,/5x, &
+ 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
+ 'Poisson''s ratio. . . . . . . . .(poisson) =',1pe15.8,/5x, &
+ 'First Lame parameter Lambda. . . (lambda) =',1pe15.8,/5x, &
+ 'Second Lame parameter Mu. . . . . . .(mu) =',1pe15.8,/5x, &
+ 'Bulk modulus Kappa . . . . . . . .(kappa) =',1pe15.8,/5x, &
+ 'Young''s modulus E. . . . . . . . .(young) =',1pe15.8)
+
+ 900 format(//5x,'-------------------------------',/5x, &
+ '-- Acoustic (fluid) material --',/5x, &
+ '-------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
+ 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
+ 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
+ 'Bulk modulus Kappa . . . . . . . .(kappa) =',1pe15.8)
+
end subroutine gmat01
Modified: seismo/2D/SPECFEM2D/branches/BIOT/lagrange_poly.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/lagrange_poly.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/lagrange_poly.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/locate_receivers.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/locate_receivers.F90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/locate_receivers.F90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/locate_source_force.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/locate_source_force.F90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/locate_source_force.F90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
@@ -40,8 +40,8 @@
!
!========================================================================
- subroutine locate_source_force(coord,ibool,npoin,nspec,x_source,z_source,ix_source,iz_source, &
- ispec_source,iglob_source,is_proc_source,nb_proc_source)
+ subroutine locate_source_force(coord,ibool,npoin,nspec,x_source,z_source,source_type,ix_source,iz_source, &
+ ispec_source,iglob_source,is_proc_source,nb_proc_source)
!
!----- calculer la position reelle de la source
@@ -54,7 +54,7 @@
include "mpif.h"
#endif
- integer npoin,nspec
+ integer npoin,nspec,source_type
integer ibool(NGLLX,NGLLZ,nspec)
double precision x_source,z_source
@@ -80,22 +80,29 @@
ihighx = NGLLX
ihighz = NGLLZ
-! look for the closest grid point
- do numelem = 1,nspec
+! on ne fait la recherche que sur l'interieur de l'element si source explosive
+ if(source_type == 2) then
+ ilowx = 2
+ ilowz = 2
+ ihighx = NGLLX-1
+ ihighz = NGLLZ-1
+ endif
- do ix = ilowx,ihighx
- do iz = ilowz,ihighz
+! recherche du point de grille le plus proche
+ do numelem=1,nspec
+ do ix=ilowx,ihighx
+ do iz=ilowz,ihighz
-! global point number
- ip = ibool(ix,iz,numelem)
+! numero global du point
+ ip=ibool(ix,iz,numelem)
-! coordinates of this grid point
+! coordonnees du point de grille
xp = coord(1,ip)
zp = coord(2,ip)
dist = sqrt((xp-x_source)**2 + (zp-z_source)**2)
-! keep the point for which distance is minimum
+! retenir le point pour lequel l'ecart est minimal
if(dist < distmin) then
distmin = dist
iglob_source = ip
@@ -106,13 +113,13 @@
enddo
enddo
-
enddo
distminmax = max(distmin,distminmax)
+
#ifdef USE_MPI
-! global minimum distance computed over all processes
+ ! global minimum distance computed over all processes
call MPI_ALLREDUCE (distminmax, dist_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ierror)
#else
@@ -120,11 +127,15 @@
#endif
-! check if this process contains the source
- if ( dist_glob == distminmax ) is_proc_source = 1
+ ! check if this process contains the source
+ if ( dist_glob == distminmax ) then
+ is_proc_source = 1
+ end if
+
+
#ifdef USE_MPI
-! determining the number of processes that contain the source (useful when the source is located on an interface)
+ ! determining the number of processes that contain the source (useful when the source is located on an interface)
call MPI_ALLREDUCE (is_proc_source, nb_proc_source, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierror)
#else
Modified: seismo/2D/SPECFEM2D/branches/BIOT/locate_source_moment_tensor.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/locate_source_moment_tensor.F90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/locate_source_moment_tensor.F90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
@@ -91,24 +91,24 @@
! **************
if ( myrank == 0 .or. nproc == 1 ) then
- write(IOUT,*)
- write(IOUT,*) '*******************************'
- write(IOUT,*) ' locating moment-tensor source'
- write(IOUT,*) '*******************************'
- write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,*) '*******************************'
+ write(IOUT,*) ' locating moment-tensor source'
+ write(IOUT,*) '*******************************'
+ write(IOUT,*)
end if
! set distance to huge initial value
- distmin = HUGEVAL
+ distmin=HUGEVAL
is_proc_source = 0
- do ispec = 1,nspec
+ do ispec=1,nspec
! loop only on points inside the element
! exclude edges to ensure this point is not shared with other elements
- do j = 2,NGLLZ-1
- do i = 2,NGLLX-1
+ do j=2,NGLLZ-1
+ do i=2,NGLLX-1
iglob = ibool(i,j,ispec)
dist = sqrt((x_source-dble(coord(1,iglob)))**2 + (z_source-dble(coord(2,iglob)))**2)
@@ -127,6 +127,7 @@
! end of loop on all the spectral elements
enddo
+
#ifdef USE_MPI
! global minimum distance computed over all processes
call MPI_ALLREDUCE (distmin, dist_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ierror)
@@ -136,9 +137,13 @@
#endif
-! check if this process contains the source
- if ( dist_glob == distmin ) is_proc_source = 1
+ ! check if this process contains the source
+ if ( dist_glob == distmin ) then
+ is_proc_source = 1
+ end if
+
+
#ifdef USE_MPI
! determining the number of processes that contain the source (useful when the source is located on an interface)
call MPI_ALLREDUCE (is_proc_source, nb_proc_source, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierror)
@@ -170,8 +175,8 @@
! ****************************************
! use initial guess in xi and gamma
- xi = xigll(ix_initial_guess)
- gamma = zigll(iz_initial_guess)
+ xi = xigll(ix_initial_guess)
+ gamma = zigll(iz_initial_guess)
! iterate to solve the non linear system
do iter_loop = 1,NUM_ITER
Modified: seismo/2D/SPECFEM2D/branches/BIOT/meshfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/meshfem2D.F90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/meshfem2D.F90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,13 +1,15 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.2
+! S P E C F E M 2 D Version 6.3
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -66,20 +68,6 @@
! volume=88,
! number=2,
! pages={368-392}}
-!
-! If you use the METIS / SCOTCH / CUBIT non-structured version, please also cite:
-!
-! @INPROCEEDINGS{MaKoBlLe08,
-! author = {R. Martin and D. Komatitsch and C. Blitz and N. {Le Goff}},
-! title = {Simulation of seismic wave propagation in an asteroid based upon
-! an unstructured {MPI} spectral-element method: blocking and non-blocking communication strategies}
-! booktitle = {Proceedings of the VECPAR'2008 8th International Meeting
-! on High Performance Computing for Computational Science},
-! year = {2008},
-! pages = {999998-999999},
-! address = {Toulouse, France},
-! note = {24-27 June 2008},
-! url = {http://vecpar.fe.up.pt/2008}}
program meshfem2D
@@ -95,8 +83,9 @@
integer :: ioffset
double precision :: gamma,absx,a00,a01,bot0,top0
-! to store density and velocity model
- double precision, dimension(:), allocatable :: rho,cp,cs,aniso3,aniso4
+! to store model properties
+ double precision, dimension(:), allocatable :: rho_s,rho_f,phi,tortuosity,permxx,permxz,&
+ permzz,kappa_s,kappa_f,kappa_fr,mu_s,eta_f,mu_fr
integer, dimension(:), allocatable :: icodemat
integer, dimension(:), allocatable :: num_material
@@ -131,7 +120,9 @@
double precision tang1,tangN,vpregion,vsregion,poisson_ratio
double precision cutsnaps,sizemax_arrows,anglerec,xmin,xmax,deltat
- double precision rhoread,cpread,csread,aniso3read,aniso4read
+! double precision rhoread,cpread,csread,aniso3read,aniso4read
+ double precision rhosread,rhofread,phiread,tortuosityread,kappasread,kappafread,kappafrread,musread,etafread,mufrread
+ double precision permxxread,permxzread,permzzread
double precision, dimension(:), allocatable :: xdeb,zdeb,xfin,zfin
@@ -145,6 +136,10 @@
integer, external :: num_4, num_9
double precision, external :: value_spline
+! flag to save the last frame for kernels calculation purpose and type of solver
+ logical :: save_forward
+ integer :: isolver
+
! flag to indicate an anisotropic material
integer, parameter :: ANISOTROPIC_MATERIAL = 2
@@ -182,8 +177,15 @@
integer, dimension(:), allocatable :: my_interfaces
integer, dimension(:), allocatable :: my_nb_interfaces
+! for acoustic/elastic coupled elements
integer :: nedges_coupled, nedges_coupled_loc
integer, dimension(:,:), pointer :: edges_coupled
+! for acoustic/poroelastic coupled elements
+ integer :: nedges_acporo_coupled, nedges_acporo_coupled_loc
+ integer, dimension(:,:), pointer :: edges_acporo_coupled
+! for poroelastic/elastic coupled elements
+ integer :: nedges_elporo_coupled, nedges_elporo_coupled_loc
+ integer, dimension(:,:), pointer :: edges_elporo_coupled
integer :: num_start
integer :: nelmnts
@@ -200,10 +202,10 @@
integer, dimension(:), pointer :: ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right
-! variables used for partitioning
+! variables used for partitionning
integer :: nproc
- integer :: partitioning_method
- character(len=256) :: partitioning_strategy
+ integer :: partitionning_method
+ character(len=256) :: partitionning_strategy
character(len=256) :: scotch_strategy
integer, dimension(0:4) :: metis_options
character(len=256) :: prname
@@ -247,7 +249,7 @@
call read_value_string(IIN,IGNORE_JUNK,free_surface_file)
call read_value_string(IIN,IGNORE_JUNK,absorbing_surface_file)
-! read info about partitioning
+! read info about partitionning
call read_value_integer(IIN,IGNORE_JUNK,nproc)
if ( nproc <= 0 ) then
print *, 'Number of processes (nproc) must be greater than or equal to one.'
@@ -263,26 +265,26 @@
#endif
- call read_value_integer(IIN,IGNORE_JUNK,partitioning_method)
- call read_value_string(IIN,IGNORE_JUNK,partitioning_strategy)
- select case(partitioning_method)
+ call read_value_integer(IIN,IGNORE_JUNK,partitionning_method)
+ call read_value_string(IIN,IGNORE_JUNK,partitionning_strategy)
+ select case(partitionning_method)
case(1)
case(2)
- partitioning_strategy = trim(partitioning_strategy)
- if ( partitioning_strategy(1:1) == '0' ) then
+ partitionning_strategy = trim(partitionning_strategy)
+ if ( partitionning_strategy(1:1) == '0' ) then
metis_options(0) = 0
else
do i = 1, 5
- metis_options = iachar(partitioning_strategy(i:i)) - iachar('0')
+ metis_options = iachar(partitionning_strategy(i:i)) - iachar('0')
end do
endif
case(3)
- scotch_strategy = trim(partitioning_strategy)
+ scotch_strategy = trim(partitionning_strategy)
case default
- print *, 'Invalid partitioning method number.'
- print *, 'Partitioning method ',partitioning_method,' was requested, but is not available.'
+ print *, 'Invalid partionning method number.'
+ print *, 'Partionning method', partitionning_method, 'was requested, but is not available.'
stop
end select
@@ -420,6 +422,7 @@
! read time step parameters
call read_value_integer(IIN,IGNORE_JUNK,nt)
call read_value_double_precision(IIN,IGNORE_JUNK,deltat)
+ call read_value_integer(IIN,IGNORE_JUNK,isolver)
! read source parameters
call read_value_logical(IIN,IGNORE_JUNK,source_surf)
@@ -470,6 +473,7 @@
! read receiver line parameters
call read_value_integer(IIN,IGNORE_JUNK,seismotype)
+ call read_value_logical(IIN,IGNORE_JUNK,save_forward)
call read_value_logical(IIN,IGNORE_JUNK,generate_STATIONS)
call read_value_integer(IIN,IGNORE_JUNK,nreceiverlines)
call read_value_double_precision(IIN,IGNORE_JUNK,anglerec)
@@ -523,55 +527,85 @@
if(nb_materials <= 0) stop 'Negative number of materials not allowed!'
allocate(icodemat(nb_materials))
- allocate(rho(nb_materials))
- allocate(cp(nb_materials))
- allocate(cs(nb_materials))
- allocate(aniso3(nb_materials))
- allocate(aniso4(nb_materials))
+ allocate(rho_s(nb_materials))
+ allocate(rho_f(nb_materials))
+ allocate(phi(nb_materials))
+ allocate(tortuosity(nb_materials))
+ allocate(permxx(nb_materials))
+ allocate(permxz(nb_materials))
+ allocate(permzz(nb_materials))
+ allocate(kappa_s(nb_materials))
+ allocate(kappa_f(nb_materials))
+ allocate(kappa_fr(nb_materials))
+ allocate(mu_s(nb_materials))
+ allocate(eta_f(nb_materials))
+ allocate(mu_fr(nb_materials))
allocate(num_material(nelmnts))
icodemat(:) = 0
- rho(:) = 0.d0
- cp(:) = 0.d0
- cs(:) = 0.d0
- aniso3(:) = 0.d0
- aniso4(:) = 0.d0
+ rho_s(:) = 0.d0
+ rho_f(:) = 0.d0
+ phi(:) = 0.d0
+ tortuosity(:) = 0.d0
+ permxx(:) = 0.d0
+ permxz(:) = 0.d0
+ permzz(:) = 0.d0
+ kappa_s(:) = 0.d0
+ kappa_f(:) = 0.d0
+ kappa_fr(:) = 0.d0
+ mu_s(:) = 0.d0
+ eta_f(:) = 0.d0
+ mu_fr(:) = 0.d0
num_material(:) = 0
do imaterial=1,nb_materials
- call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read)
+ call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread,rhosread,rhofread,phiread, &
+ tortuosityread,permxxread,permxzread,permzzread,kappasread,kappafread,&
+ kappafrread,musread,etafread,mufrread)
if(i < 1 .or. i > nb_materials) stop 'Wrong material number!'
icodemat(i) = icodematread
- rho(i) = rhoread
- cp(i) = cpread
- cs(i) = csread
+ rho_s(i) = rhosread
+ rho_f(i) = rhofread
+ phi(i) = phiread
+ tortuosity(i) = tortuosityread
+ permxx(i) = permxxread
+ permxz(i) = permxzread
+ permzz(i) = permzzread
+ kappa_s(i) = kappasread
+ kappa_f(i) = kappafread
+ kappa_fr(i) = kappafrread
+ mu_s(i) = musread
+ eta_f(i) = etafread
+ mu_fr(i) = mufrread
- if(rho(i) <= 0.d0 .or. cp(i) <= 0.d0 .or. cs(i) < 0.d0) stop 'negative value of velocity or density'
-
- aniso3(i) = aniso3read
- aniso4(i) = aniso4read
enddo
print *
- print *, 'Nb of solid or fluid materials = ',nb_materials
+ print *, 'Nb of solid, fluid or porous materials = ',nb_materials
print *
do i=1,nb_materials
if(icodemat(i) /= ANISOTROPIC_MATERIAL) then
print *,'Material #',i,' isotropic'
- print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
- if(cs(i) < TINYVAL) then
+ print *,'rho_s, kappa_s, mu_s= ',rho_s(i),kappa_s(i),mu_s(i)
+ print *,'rho_f, kappa_f, eta_f= ',rho_f(i),kappa_f(i),eta_f(i)
+ print *,'phi, tortuosity, permxx, permxz, permzz= ',phi(i),tortuosity(i),permxx(i),permxz(i),permzz(i)
+ print *,'kappa_fr, mu_fr= ',kappa_fr(i),mu_fr(i)
+! if(cs(i) < TINYVAL) then
+ if(phi(i) >= 1.d0) then ! acoustic domain
print *,'Material is fluid'
- else
+ elseif(phi(i) < TINYVAL) then ! elastic domain
print *,'Material is solid'
+ else ! poroelastic domain
+ print *,'Material is porous'
endif
else
print *,'Material #',i,' anisotropic'
- print *,'rho,c11,c13,c33,c44 = ',rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
+ print *,'ATTENTION: to be defined'
+! print *,'rho,c11,c13,c33,c44 = ',rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
endif
print *
enddo
-
if ( read_external_mesh ) then
call read_mat(materials_file, nelmnts, num_material)
else
@@ -598,32 +632,32 @@
print *,'IX from ',ixdebregion,' to ',ixfinregion
print *,'IZ from ',izdebregion,' to ',izfinregion
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL) then
- vpregion = cp(imaterial_number)
- vsregion = cs(imaterial_number)
- print *,'Material # ',imaterial_number,' isotropic'
- if(vsregion < TINYVAL) then
- print *,'Material is fluid'
- else
- print *,'Material is solid'
- endif
- print *,'vp = ',vpregion
- print *,'vs = ',vsregion
- print *,'rho = ',rho(imaterial_number)
- poisson_ratio = 0.5d0*(vpregion*vpregion-2.d0*vsregion*vsregion) / (vpregion*vpregion-vsregion*vsregion)
- print *,'Poisson''s ratio = ',poisson_ratio
- if(poisson_ratio <= -1.00001d0 .or. poisson_ratio >= 0.50001d0) stop 'incorrect value of Poisson''s ratio'
- else
- print *,'Material # ',imaterial_number,' anisotropic'
- print *,'c11 = ',cp(imaterial_number)
- print *,'c13 = ',cs(imaterial_number)
- print *,'c33 = ',aniso3(imaterial_number)
- print *,'c44 = ',aniso4(imaterial_number)
- print *,'rho = ',rho(imaterial_number)
- endif
- print *,' -----'
+! if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL) then
+! vpregion = cp(imaterial_number)
+! vsregion = cs(imaterial_number)
+! print *,'Material # ',imaterial_number,' isotropic'
+! if(vsregion < TINYVAL) then
+! print *,'Material is fluid'
+! else
+! print *,'Material is solid'
+! endif
+! print *,'vp = ',vpregion
+! print *,'vs = ',vsregion
+! print *,'rho = ',rho(imaterial_number)
+! poisson_ratio = 0.5d0*(vpregion*vpregion-2.d0*vsregion*vsregion) / (vpregion*vpregion-vsregion*vsregion)
+! print *,'Poisson''s ratio = ',poisson_ratio
+! if(poisson_ratio <= -1.00001d0 .or. poisson_ratio >= 0.50001d0) stop 'incorrect value of Poisson''s ratio'
+! else
+! print *,'Material # ',imaterial_number,' anisotropic'
+! print *,'c11 = ',cp(imaterial_number)
+! print *,'c13 = ',cs(imaterial_number)
+! print *,'c33 = ',aniso3(imaterial_number)
+! print *,'c44 = ',aniso4(imaterial_number)
+! print *,'rho = ',rho(imaterial_number)
+! endif
+! print *,' -----'
- ! store density and velocity model
+ ! store model properties
do i = ixdebregion,ixfinregion
do j = izdebregion,izfinregion
num_material((j-1)*nxread+i) = imaterial_number
@@ -632,7 +666,7 @@
enddo
- if(minval(num_material) <= 0) stop 'Velocity model not entirely set...'
+ if(minval(num_material) <= 0) stop 'Model properties not entirely set...'
endif
@@ -786,7 +820,7 @@
if ( read_external_mesh ) then
call read_acoustic_surface(free_surface_file, nelem_acoustic_surface, acoustic_surface, &
- nelmnts, num_material, ANISOTROPIC_MATERIAL, nb_materials, icodemat, cs, num_start)
+ nelmnts, num_material, ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
if ( any_abs ) then
call read_abs_surface(absorbing_surface_file, nelemabs, abs_surface, num_start)
@@ -803,7 +837,7 @@
j = nzread
do i = 1,nxread
imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL ) then
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
nelem_acoustic_surface = nelem_acoustic_surface + 1
endif
enddo
@@ -814,7 +848,7 @@
j = nzread
do i = 1,nxread
imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL ) then
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
nelem_acoustic_surface = nelem_acoustic_surface + 1
acoustic_surface(1,nelem_acoustic_surface) = (j-1)*nxread + (i-1)
acoustic_surface(2,nelem_acoustic_surface) = 2
@@ -948,9 +982,9 @@
endif
-!*****************************
-! partitioning
-!*****************************
+ !*****************************
+ ! Partitionning
+ !*****************************
allocate(part(0:nelmnts-1))
! if ngnod == 9, we work on a subarray of elmnts, which represents the elements with for nodes only
@@ -983,7 +1017,7 @@
call read_weights(nelmnts, vwgt, nb_edges, adjwgt)
! partitioning
- select case (partitioning_method)
+ select case (partitionning_method)
case(1)
do iproc = 0, nproc-2
part(iproc*floor(real(nelmnts)/real(nproc)):(iproc+1)*floor(real(nelmnts)/real(nproc))-1) = iproc
@@ -1014,12 +1048,28 @@
! beware of fluid solid edges : coupled elements are transfered to the same partition
if ( ngnod == 9 ) then
- call acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts_bis, nb_materials, cs, num_material, &
+ call acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts_bis, nb_materials, phi, num_material, &
nproc, part, nedges_coupled, edges_coupled)
else
- call acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, cs, num_material, &
+ call acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi, num_material, &
nproc, part, nedges_coupled, edges_coupled)
endif
+! beware of fluid porous edges : coupled elements are transfered to the same partition
+ if ( ngnod == 9 ) then
+ call acoustic_poroelastic_repartitioning (nelmnts, nnodes, elmnts_bis, nb_materials, phi, num_material, &
+ nproc, part, nedges_acporo_coupled, edges_acporo_coupled)
+ else
+ call acoustic_poroelastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi, num_material, &
+ nproc, part, nedges_acporo_coupled, edges_acporo_coupled)
+ endif
+! beware of porous solid edges : coupled elements are transfered to the same partition
+ if ( ngnod == 9 ) then
+ call poroelastic_elastic_repartitioning (nelmnts, nnodes, elmnts_bis, nb_materials, phi, num_material, &
+ nproc, part, nedges_elporo_coupled, edges_elporo_coupled)
+ else
+ call poroelastic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi, num_material, &
+ nproc, part, nedges_elporo_coupled, edges_elporo_coupled)
+ endif
! local number of each element for each partition
call Construct_glob2loc_elmnts(nelmnts, part, nproc, glob2loc_elmnts)
@@ -1063,10 +1113,10 @@
if ( nproc /= 1 ) then
if ( ngnod == 9 ) then
call Construct_interfaces(nelmnts, nproc, part, elmnts_bis, xadj, adjncy, tab_interfaces, &
- tab_size_interfaces, ninterfaces, nb_materials, cs, num_material)
+ tab_size_interfaces, ninterfaces, nb_materials, phi, num_material)
else
call Construct_interfaces(nelmnts, nproc, part, elmnts, xadj, adjncy, tab_interfaces, &
- tab_size_interfaces, ninterfaces, nb_materials, cs, num_material)
+ tab_size_interfaces, ninterfaces, nb_materials, phi, num_material)
endif
print *, '04'
allocate(my_interfaces(0:ninterfaces-1))
@@ -1079,7 +1129,8 @@
call merge_abs_boundaries(nelemabs, nelemabs_merge, abs_surface, abs_surface_char, abs_surface_merge, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right, &
- nedges_coupled, edges_coupled, nb_materials, cs, num_material, &
+ nedges_coupled, edges_coupled, nedges_acporo_coupled, edges_acporo_coupled, nedges_elporo_coupled, &
+ edges_elporo_coupled,nb_materials, phi, num_material, &
nelmnts, &
elmnts, ngnod)
print *, 'nelemabs_merge', nelemabs_merge
@@ -1094,7 +1145,7 @@
write(15,*) '#'
write(15,*) '# Database for SPECFEM2D'
- write(15,*) '# Dimitri Komatitsch, (c) University of Pau, France'
+ write(15,*) '# (c) University of Pau, France and Caltech, Pasadena'
write(15,*) '#'
write(15,*) 'Title of the simulation'
@@ -1130,14 +1181,14 @@
write(15,*) 'initialfield add_Bielak_conditions'
write(15,*) initialfield,add_Bielak_conditions
- write(15,*) 'seismotype imagetype'
- write(15,*) seismotype,imagetype
+ write(15,*) 'seismotype imagetype save_forward'
+ write(15,*) seismotype,imagetype,save_forward
write(15,*) 'assign_external_model outputgrid TURN_ANISOTROPY_ON TURN_ATTENUATION_ON'
write(15,*) assign_external_model,outputgrid,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
- write(15,*) 'nt deltat'
- write(15,*) nt,deltat
+ write(15,*) 'nt deltat isolver'
+ write(15,*) nt,deltat,isolver
write(15,*) 'source'
write(15,*) source_type,time_function_type,xs,zs,f0,t0,factor,angleforce,Mxx,Mzz,Mxz
@@ -1173,14 +1224,21 @@
call write_fluidsolid_edges_database(15, nedges_coupled, nedges_coupled_loc, &
edges_coupled, glob2loc_elmnts, part, iproc, 1)
+ call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
+ edges_acporo_coupled, glob2loc_elmnts, part, iproc, 1)
+ call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
+ edges_elporo_coupled, glob2loc_elmnts, part, iproc, 1)
- write(15,*) 'nelemabs nelem_acoustic_surface num_fluid_solid_edges'
- write(15,*) nelemabs_loc,nelem_acoustic_surface_loc,nedges_coupled_loc
+ write(15,*) 'nelemabs nelem_acoustic_surface num_fluid_solid_edges num_fluid_poro_edges num_solid_poro_edges'
+ write(15,*) nelemabs_loc,nelem_acoustic_surface_loc,nedges_coupled_loc,nedges_acporo_coupled_loc,nedges_elporo_coupled_loc
+ write(15,*) 'nxread, nzread'
+ write(15,*) nxread,nzread
- write(15,*) 'Material sets (num 1 rho vp vs 0 0) or (num 2 rho c11 c13 c33 c44)'
+ write(15,*) 'Material sets Isotropic (Anisotropic: to be defined)'
do i=1,nb_materials
- write(15,*) i,icodemat(i),rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
+ write(15,*) i,icodemat(i),rho_s(i),rho_f(i),phi(i),tortuosity(i),permxx(i),permxz(i),permzz(i),kappa_s(i),&
+ kappa_f(i),kappa_fr(i),mu_s(i),eta_f(i),mu_fr(i)
enddo
write(15,*) 'Arrays kmato and knods for each bloc:'
@@ -1226,6 +1284,15 @@
write(15,*) 'List of acoustic elastic coupled edges:'
call write_fluidsolid_edges_database(15, nedges_coupled, nedges_coupled_loc, &
edges_coupled, glob2loc_elmnts, part, iproc, 2)
+
+ write(15,*) 'List of acoustic poroelastic coupled edges:'
+ call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
+ edges_acporo_coupled, glob2loc_elmnts, part, iproc, 2)
+
+ write(15,*) 'List of poroelastic elastic coupled edges:'
+ call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
+ edges_elporo_coupled, glob2loc_elmnts, part, iproc, 2)
+
end do
Modified: seismo/2D/SPECFEM2D/branches/BIOT/part_unstruct.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/part_unstruct.F90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/part_unstruct.F90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,13 +1,15 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.2
+! S P E C F E M 2 D Version 6.3
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -43,6 +45,7 @@
!
! This module contains subroutines related to unstructured meshes and partitioning of the
! corresponding graphs.
+! This module has been modified from the fluid/solid initial version to account for porous media.
!
module part_unstruct
@@ -142,7 +145,7 @@
! 3/ first node on the free surface, 4/ second node on the free surface, if relevant (if 2/ is equal to 2)
!-----------------------------------------------
subroutine read_acoustic_surface(filename, nelem_acoustic_surface, acoustic_surface, &
- nelmnts, num_material, ANISOTROPIC_MATERIAL, nb_materials, icodemat, cs, num_start)
+ nelmnts, num_material, ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
include './constants.h'
@@ -154,7 +157,7 @@
integer, intent(in) :: ANISOTROPIC_MATERIAL
integer, intent(in) :: nb_materials
integer, dimension(1:nb_materials), intent(in) :: icodemat
- double precision, dimension(1:nb_materials), intent(in) :: cs
+ double precision, dimension(1:nb_materials), intent(in) :: phi
integer, intent(in) :: num_start
@@ -182,7 +185,7 @@
nelem_acoustic_surface = 0
do i = 1, nelmnts_surface
imaterial_number = num_material(acoustic_surface_tmp(1,i))
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL ) then
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
nelem_acoustic_surface = nelem_acoustic_surface + 1
end if
@@ -193,7 +196,7 @@
nelem_acoustic_surface = 0
do i = 1, nelmnts_surface
imaterial_number = num_material(acoustic_surface_tmp(1,i))
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL ) then
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
nelem_acoustic_surface = nelem_acoustic_surface + 1
acoustic_surface(:,nelem_acoustic_surface) = acoustic_surface_tmp(:,i)
end if
@@ -473,7 +476,7 @@
! No interface between acoustic and elastic elements.
!--------------------------------------------------
subroutine Construct_interfaces(nelmnts, nparts, part, elmnts, xadj, adjncy, tab_interfaces, &
- tab_size_interfaces, ninterfaces, nb_materials, cs_material, num_material)
+ tab_size_interfaces, ninterfaces, nb_materials, phi_material, num_material)
include 'constants.h'
@@ -485,14 +488,14 @@
integer, dimension(:),pointer :: tab_size_interfaces, tab_interfaces
integer, intent(out) :: ninterfaces
integer, dimension(1:nelmnts), intent(in) :: num_material
- double precision, dimension(1:nb_materials), intent(in) :: cs_material
+ double precision, dimension(1:nb_materials), intent(in) :: phi_material
integer, intent(in) :: nb_materials
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
+ logical :: is_acoustic_el, is_acoustic_el_adj, is_elastic_el, is_elastic_el_adj
ninterfaces = 0
do i = 0, nparts-1
@@ -511,20 +514,33 @@
do num_part_bis = num_part+1, nparts-1
do el = 0, nelmnts-1
if ( part(el) == num_part ) then
- if ( cs_material(num_material(el+1)) < TINYVAL) then
+ if ( phi_material(num_material(el+1)) >= 1.d0 ) then
is_acoustic_el = .true.
else
is_acoustic_el = .false.
end if
+ if ( phi_material(num_material(el+1)) < TINYVAL ) then
+ is_elastic_el = .true.
+ else
+ is_elastic_el = .false.
+ end if
+
do el_adj = xadj(el), xadj(el+1)-1
- if ( cs_material(num_material(adjncy(el_adj)+1)) < TINYVAL) then
+ if ( phi_material(num_material(adjncy(el_adj)+1)) >= 1.d0 ) then
is_acoustic_el_adj = .true.
else
is_acoustic_el_adj = .false.
end if
- if ( (part(adjncy(el_adj)) == num_part_bis) .and. (is_acoustic_el .eqv. is_acoustic_el_adj) ) then
+ if ( phi_material(num_material(adjncy(el_adj)+1)) < TINYVAL ) then
+ is_elastic_el_adj = .true.
+ else
+ is_elastic_el_adj = .false.
+ end if
+
+ if(part(adjncy(el_adj)) == num_part_bis) then
+ if((is_acoustic_el.eqv.is_acoustic_el_adj).and.(is_elastic_el.eqv.is_elastic_el_adj))then
num_edge = num_edge + 1
-
+ end if
end if
end do
end if
@@ -546,18 +562,31 @@
do num_part_bis = num_part+1, nparts-1
do el = 0, nelmnts-1
if ( part(el) == num_part ) then
- if ( cs_material(num_material(el+1)) < TINYVAL) then
+ if ( phi_material(num_material(el+1)) >= 1.d0 ) then
is_acoustic_el = .true.
else
is_acoustic_el = .false.
end if
+ if ( phi_material(num_material(el+1)) < TINYVAL ) then
+ is_elastic_el = .true.
+ else
+ is_elastic_el = .false.
+ end if
+
do el_adj = xadj(el), xadj(el+1)-1
- if ( cs_material(num_material(adjncy(el_adj)+1)) < TINYVAL) then
+ if ( phi_material(num_material(adjncy(el_adj)+1)) >= 1.d0 ) then
is_acoustic_el_adj = .true.
else
is_acoustic_el_adj = .false.
end if
- if ( (part(adjncy(el_adj)) == num_part_bis) .and. (is_acoustic_el .eqv. is_acoustic_el_adj) ) then
+ if ( phi_material(num_material(adjncy(el_adj)+1)) < TINYVAL ) then
+ is_elastic_el_adj = .true.
+ else
+ is_elastic_el_adj = .false.
+ end if
+
+ if(part(adjncy(el_adj))==num_part_bis) then
+ if((is_acoustic_el.eqv.is_acoustic_el_adj).and.(is_elastic_el.eqv.is_elastic_el_adj))then
tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+0) = el
tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+1) = adjncy(el_adj)
ncommon_nodes = 0
@@ -577,6 +606,7 @@
end if
num_edge = num_edge + 1
end if
+ end if
end do
end if
@@ -874,7 +904,8 @@
!--------------------------------------------------
! Set absorbing boundaries by elements instead of edges.
- ! Excludes points that have both absorbing condition and coupled fluid/solid relation (this is the
+ ! Excludes points that have both absorbing condition and coupled fluid/solid fluid/poro poro/solid
+ ! relation (this is the
! reason arrays ibegin_..., iend_... were included here).
! Under development : exluding points that have two different normals in two different elements.
!--------------------------------------------------
@@ -882,7 +913,8 @@
subroutine merge_abs_boundaries(nelemabs, nelemabs_merge, abs_surface, abs_surface_char, abs_surface_merge, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right, &
- nedges_coupled, edges_coupled, nb_materials, cs_material, num_material, &
+ nedges_coupled, edges_coupled, nedges_acporo_coupled, edges_acporo_coupled, nedges_elporo_coupled, &
+ edges_elporo_coupled, nb_materials, phi_material, num_material, &
nelmnts, &
elmnts, ngnod)
@@ -898,15 +930,15 @@
integer, intent(in) :: ngnod
integer, dimension(:), pointer :: ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right
- integer :: nedges_coupled
- integer, dimension(:,:), pointer :: edges_coupled
+ integer :: nedges_coupled,nedges_acporo_coupled,nedges_elporo_coupled
+ integer, dimension(:,:), pointer :: edges_coupled,edges_acporo_coupled,edges_elporo_coupled
integer :: nb_materials
- double precision, dimension(nb_materials), intent(in) :: cs_material
+ double precision, dimension(nb_materials), intent(in) :: phi_material
integer, dimension(1:nelmnts), intent(in) :: num_material
integer :: nelmnts
- logical, dimension(nb_materials) :: is_acoustic
+ logical, dimension(nb_materials) :: is_acoustic,is_poroelastic
integer :: num_edge, nedge_bound
integer :: match
integer :: nb_elmnts_abs
@@ -1024,11 +1056,14 @@
jend_left(:) = NGLLZ
is_acoustic(:) = .false.
+ is_poroelastic(:) = .false.
do i = 1, nb_materials
- if (cs_material(i) < TINYVAL) then
+ if (phi_material(i) >=1.d0) then
is_acoustic(i) = .true.
end if
-
+ if (phi_material(i) > TINYVAL .and. phi_material(i) <1.d0) then
+ is_poroelastic(i) = .true.
+ end if
end do
do num_edge = 1, nedge_bound
@@ -1110,6 +1145,146 @@
end if
+
+ if ( is_acoustic(num_material(abs_surface(1,num_edge)+1)) ) then
+
+ do iedge = 1, nedges_acporo_coupled
+
+ do inode1 = 0, 3
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_acporo_coupled(1,iedge)+inode1) ) then
+ do inode2 = 0, 3
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_acporo_coupled(2,iedge)+inode2) ) then
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) ) then
+ ibegin_bottom(match) = 2
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ jbegin_right(match) = 2
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ ibegin_top(match) = 2
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) ) then
+ jbegin_left(match) = 2
+
+ end if
+
+ end if
+ end do
+
+ end if
+
+ if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_acporo_coupled(1,iedge)+inode1) ) then
+ do inode2 = 0, 3
+ if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_acporo_coupled(2,iedge)+inode2) ) then
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) ) then
+ iend_bottom(match) = NGLLX - 1
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ jend_right(match) = NGLLZ - 1
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ iend_top(match) = NGLLX - 1
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) ) then
+ jend_left(match) = NGLLZ - 1
+
+ end if
+ end if
+ end do
+
+ end if
+
+ end do
+
+
+ end do
+
+ end if
+
+
+ if ( is_poroelastic(num_material(abs_surface(1,num_edge)+1)) ) then
+
+ do iedge = 1, nedges_elporo_coupled
+
+ do inode1 = 0, 3
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_elporo_coupled(1,iedge)+inode1) ) then
+ do inode2 = 0, 3
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_elporo_coupled(2,iedge)+inode2) ) then
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) ) then
+ ibegin_bottom(match) = 2
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ jbegin_right(match) = 2
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ ibegin_top(match) = 2
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) ) then
+ jbegin_left(match) = 2
+
+ end if
+
+ end if
+ end do
+
+ end if
+
+ if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_elporo_coupled(1,iedge)+inode1) ) then
+ do inode2 = 0, 3
+ if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_elporo_coupled(2,iedge)+inode2) ) then
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) ) then
+ iend_bottom(match) = NGLLX - 1
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ jend_right(match) = NGLLZ - 1
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ iend_top(match) = NGLLX - 1
+
+ end if
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) ) then
+ jend_left(match) = NGLLZ - 1
+
+ end if
+ end if
+ end do
+
+ end if
+
+ end do
+
+
+ end do
+
+ end if
+
end do
end subroutine merge_abs_boundaries
@@ -1286,7 +1461,7 @@
! Repartitioning : two coupled acoustic/elastic elements are transfered to the same partition
!--------------------------------------------------
-subroutine acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, cs_material, num_material, &
+subroutine acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
nproc, part, nedges_coupled, edges_coupled)
implicit none
@@ -1294,7 +1469,7 @@
include 'constants.h'
integer, intent(in) :: nelmnts, nnodes, nproc, nb_materials
- double precision, dimension(nb_materials), intent(in) :: cs_material
+ double precision, dimension(nb_materials), intent(in) :: phi_material
integer, dimension(1:nelmnts), intent(in) :: num_material
integer, dimension(:), pointer :: elmnts
integer, dimension(:), pointer :: part
@@ -1302,7 +1477,7 @@
integer, dimension(:,:), pointer :: edges_coupled
- logical, dimension(nb_materials) :: is_acoustic
+ logical, dimension(nb_materials) :: is_acoustic, is_elastic
integer, dimension(:), pointer :: xadj
integer, dimension(:), pointer :: adjncy
integer, dimension(:), pointer :: nodes_elmnts
@@ -1313,11 +1488,14 @@
logical :: is_repartitioned
is_acoustic(:) = .false.
+ is_elastic(:) = .false.
do i = 1, nb_materials
- if (cs_material(i) < TINYVAL) then
+ if (phi_material(i) >=1.d0) then
is_acoustic(i) = .true.
end if
-
+ if (phi_material(i) < TINYVAL) then
+ is_elastic(i) = .true.
+ end if
end do
call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,2)
@@ -1326,7 +1504,7 @@
do el = 0, nelmnts-1
if ( is_acoustic(num_material(el+1)) ) then
do el_adj = xadj(el), xadj(el+1) - 1
- if ( .not. is_acoustic(num_material(adjncy(el_adj)+1)) ) then
+ if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
nedges_coupled = nedges_coupled + 1
end if
@@ -1334,7 +1512,7 @@
end if
end do
- print *, 'nedges_coupled', nedges_coupled
+ print *, 'nedges_coupled (acoustic/elastic)', nedges_coupled
allocate(edges_coupled(2,nedges_coupled))
@@ -1342,7 +1520,7 @@
do el = 0, nelmnts-1
if ( is_acoustic(num_material(el+1)) ) then
do el_adj = xadj(el), xadj(el+1) - 1
- if ( .not. is_acoustic(num_material(adjncy(el_adj)+1)) ) then
+ if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
nedges_coupled = nedges_coupled + 1
edges_coupled(1,nedges_coupled) = el
edges_coupled(2,nedges_coupled) = adjncy(el_adj)
@@ -1372,9 +1550,195 @@
end subroutine acoustic_elastic_repartitioning
+ !--------------------------------------------------
+ ! Repartitioning : two coupled acoustic/poroelastic elements are transfered to the same partition
+ !--------------------------------------------------
+subroutine acoustic_poroelastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
+ nproc, part, nedges_acporo_coupled, edges_acporo_coupled)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer, intent(in) :: nelmnts, nnodes, nproc, nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+ integer, dimension(:), pointer :: elmnts
+ integer, dimension(:), pointer :: part
+ integer, intent(out) :: nedges_acporo_coupled
+ integer, dimension(:,:), pointer :: edges_acporo_coupled
+
+
+ logical, dimension(nb_materials) :: is_acoustic,is_poroelastic
+ integer, dimension(:), pointer :: xadj
+ integer, dimension(:), pointer :: adjncy
+ integer, dimension(:), pointer :: nodes_elmnts
+ integer, dimension(:), pointer :: nnodes_elmnts
+
+ integer :: i, num_edge
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ is_acoustic(:) = .false.
+ is_poroelastic(:) = .false.
+ do i = 1, nb_materials
+ if (phi_material(i) >=1.d0) then
+ is_acoustic(i) = .true.
+ end if
+ if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
+ is_poroelastic(i) = .true.
+ end if
+ end do
+
+ call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,2)
+
+ nedges_acporo_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_poroelastic(num_material(adjncy(el_adj)+1)) ) then
+ nedges_acporo_coupled = nedges_acporo_coupled + 1
+ end if
+
+ end do
+ end if
+ end do
+
+ print *, 'nedges_coupled (acoustic/poroelastic)', nedges_acporo_coupled
+
+ allocate(edges_acporo_coupled(2,nedges_acporo_coupled))
+
+ nedges_acporo_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_poroelastic(num_material(adjncy(el_adj)+1)) ) then
+ nedges_acporo_coupled = nedges_acporo_coupled + 1
+ edges_acporo_coupled(1,nedges_acporo_coupled) = el
+ edges_acporo_coupled(2,nedges_acporo_coupled) = adjncy(el_adj)
+ end if
+
+ end do
+ end if
+ end do
+
+ do i = 1, nedges_acporo_coupled*nproc
+ is_repartitioned = .false.
+ do num_edge = 1, nedges_acporo_coupled
+ if ( part(edges_acporo_coupled(1,num_edge)) /= part(edges_acporo_coupled(2,num_edge)) ) then
+ if ( part(edges_acporo_coupled(1,num_edge)) < part(edges_acporo_coupled(2,num_edge)) ) then
+ part(edges_acporo_coupled(2,num_edge)) = part(edges_acporo_coupled(1,num_edge))
+ else
+ part(edges_acporo_coupled(1,num_edge)) = part(edges_acporo_coupled(2,num_edge))
+ end if
+ is_repartitioned = .true.
+ end if
+
+ end do
+ if ( .not. is_repartitioned ) then
+ exit
+ end if
+ end do
+
+end subroutine acoustic_poroelastic_repartitioning
+
!--------------------------------------------------
- ! Write fluid/solid edges (fluid elements and corresponding solid elements)
+ ! Repartitioning : two coupled poroelastic/elastic elements are transfered to the same partition
+ !--------------------------------------------------
+
+subroutine poroelastic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
+ nproc, part, nedges_elporo_coupled, edges_elporo_coupled)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer, intent(in) :: nelmnts, nnodes, nproc, nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+ integer, dimension(:), pointer :: elmnts
+ integer, dimension(:), pointer :: part
+ integer, intent(out) :: nedges_elporo_coupled
+ integer, dimension(:,:), pointer :: edges_elporo_coupled
+
+
+ logical, dimension(nb_materials) :: is_elastic,is_poroelastic
+ integer, dimension(:), pointer :: xadj
+ integer, dimension(:), pointer :: adjncy
+ integer, dimension(:), pointer :: nodes_elmnts
+ integer, dimension(:), pointer :: nnodes_elmnts
+
+ integer :: i, num_edge
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ is_elastic(:) = .false.
+ is_poroelastic(:) = .false.
+ do i = 1, nb_materials
+ if (phi_material(i) < TINYVAL) then
+ is_elastic(i) = .true.
+ end if
+ if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
+ is_poroelastic(i) = .true.
+ end if
+ end do
+
+ call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,2)
+
+ nedges_elporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_poroelastic(num_material(el+1)) ) then
+ do el_adj = xadj(el), xadj(el+1) - 1
+ if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
+ nedges_elporo_coupled = nedges_elporo_coupled + 1
+ end if
+
+ end do
+ end if
+ end do
+
+ print *, 'nedges_coupled (poroelastic/elastic)', nedges_elporo_coupled
+
+ allocate(edges_elporo_coupled(2,nedges_elporo_coupled))
+
+ nedges_elporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_poroelastic(num_material(el+1)) ) then
+ do el_adj = xadj(el), xadj(el+1) - 1
+ if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
+ nedges_elporo_coupled = nedges_elporo_coupled + 1
+ edges_elporo_coupled(1,nedges_elporo_coupled) = el
+ edges_elporo_coupled(2,nedges_elporo_coupled) = adjncy(el_adj)
+ end if
+
+ end do
+ end if
+ end do
+
+ do i = 1, nedges_elporo_coupled*nproc
+ is_repartitioned = .false.
+ do num_edge = 1, nedges_elporo_coupled
+ if ( part(edges_elporo_coupled(1,num_edge)) /= part(edges_elporo_coupled(2,num_edge)) ) then
+ if ( part(edges_elporo_coupled(1,num_edge)) < part(edges_elporo_coupled(2,num_edge)) ) then
+ part(edges_elporo_coupled(2,num_edge)) = part(edges_elporo_coupled(1,num_edge))
+ else
+ part(edges_elporo_coupled(1,num_edge)) = part(edges_elporo_coupled(2,num_edge))
+ end if
+ is_repartitioned = .true.
+ end if
+
+ end do
+ if ( .not. is_repartitioned ) then
+ exit
+ end if
+ end do
+
+end subroutine poroelastic_elastic_repartitioning
+
+
+ !--------------------------------------------------
+ ! Write fluid/solid edges (fluid (or porous) elements and corresponding solid (or porous) elements)
! pertaining to iproc partition in the corresponding Database
!--------------------------------------------------
Modified: seismo/2D/SPECFEM2D/branches/BIOT/plotgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/plotgll.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/plotgll.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/plotpost.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/plotpost.F90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/plotpost.F90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,10 +4,12 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -41,7 +43,8 @@
!========================================================================
subroutine plotpost(displ,coord,vpext,x_source,z_source,st_xval,st_zval,it,dt,coorg, &
- xinterp,zinterp,shapeint,Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ xinterp,zinterp,shapeint,Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
numabs,codeabs,anyabs,&
nelem_acoustic_surface, acoustic_edges, &
simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
@@ -77,7 +80,7 @@
double precision Uxinterp(pointsdisp,pointsdisp)
double precision Uzinterp(pointsdisp,pointsdisp)
double precision flagrange(NGLLX,pointsdisp)
- double precision density(numat),elastcoef(4,numat)
+ double precision density(2,numat),poroelastcoef(4,3,numat),porosity(numat),tortuosity(numat)
double precision dt,timeval,x_source,z_source
double precision displ(NDIM,npoin),coord(NDIM,npoin)
@@ -104,9 +107,16 @@
equivalence (postscript_line,ch1)
logical :: first
- double precision convert,x1,rlamda,rmu,denst,rKvol,cploc,xa,za,xb,zb
+ double precision convert,x1,cpIloc,xa,za,xb,zb
+! double precision convert,x1,rlamda,rmu,denst,rKvol,cploc,xa,za,xb,zb
double precision z1,x2,z2,d,d1,d2,dummy,theta,thetaup,thetadown
+ double precision :: mul_s,kappal_s,rhol_s
+ double precision :: kappal_f,rhol_f
+ double precision :: mul_fr,kappal_fr,phil,tortl
+ double precision :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,rhol_bar
+ double precision :: cpIsquare
+
integer k,j,ispec,material,is,ir,imat,icol,l,line_length
integer index_char,ii,ipoin,in,nnum,inum,ideb,ifin,iedge
@@ -1579,12 +1589,32 @@
x1 = (vpext(i,j,ispec)-vpmin) / (vpmax-vpmin)
else
material = kmato(ispec)
- rlamda = elastcoef(1,material)
- rmu = elastcoef(2,material)
- denst = density(material)
- rKvol = rlamda + 2.d0*rmu/3.d0
- cploc = sqrt((rKvol + 4.d0*rmu/3.d0)/denst)
- x1 = (cploc-vpmin)/(vpmax-vpmin)
+! get elastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = rhol_bar - phil/tortl*rhol_f
+ bfactor = H_biot + phil*rhol_bar/(tortl*rhol_f)*M_biot - 2.d0*phil/tortl*C_biot
+ cfactor = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIloc = sqrt(cpIsquare)
+ x1 = (cpIloc-vpmin)/(vpmax-vpmin)
endif
else
x1 = 0.5d0
Modified: seismo/2D/SPECFEM2D/branches/BIOT/read_value_parameters.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/read_value_parameters.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/read_value_parameters.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
@@ -139,18 +139,21 @@
!--------------------
- subroutine read_material_parameters(iin,ignore_junk,i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read)
+ subroutine read_material_parameters(iin,ignore_junk,i,icodematread,rhosread,rhofread,phiread,tortuosityread,&
+ permxxread,permxzread,permzzread,kappasread,kappafread,kappafrread,musread,etafread,mufrread)
implicit none
integer iin
logical ignore_junk
integer i,icodematread
- double precision rhoread,cpread,csread,aniso3read,aniso4read
+ double precision rhosread,rhofread,phiread,tortuosityread,permxxread,permxzread,permzzread
+ double precision kappasread,kappafread,kappafrread,musread,etafread,mufrread
character(len=100) string_read
call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read
+ read(string_read,*) i,icodematread,rhosread,rhofread,phiread,tortuosityread,permxxread,permxzread,&
+ permzzread,kappasread,kappafread,kappafrread,musread,etafread,mufrread
end subroutine read_material_parameters
Modified: seismo/2D/SPECFEM2D/branches/BIOT/recompute_jacobian.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/recompute_jacobian.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/recompute_jacobian.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/specfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/specfem2D.F90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/specfem2D.F90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -1,13 +1,15 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.2
+! S P E C F E M 2 D Version 6.3
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT gps DOT caltech DOT edu
+! Jeroen Tromp, jtromp aT gps DOT caltech DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic wave equation
@@ -67,28 +69,27 @@
! volume=88,
! number=2,
! pages={368-392}}
+
+! version 6.3, Christina Morency, February 2008
+! - adjoint method: attenuation is not taken into account yet
!
-! If you use the METIS / SCOTCH / CUBIT non-structured version, please also cite:
+! version 6.2, Christina Morency, October 2007
+! - domain decomposition to solve for acoustic/poroelastic/elastic problems
+! - flag acoustic/poroelastic/elastic based on the porosity value
!
-! @INPROCEEDINGS{MaKoBlLe08,
-! author = {R. Martin and D. Komatitsch and C. Blitz and N. {Le Goff}},
-! title = {Simulation of seismic wave propagation in an asteroid based upon
-! an unstructured {MPI} spectral-element method: blocking and non-blocking communication strategies}
-! booktitle = {Proceedings of the VECPAR'2008 8th International Meeting
-! on High Performance Computing for Computational Science},
-! year = {2008},
-! pages = {999998-999999},
-! address = {Toulouse, France},
-! note = {24-27 June 2008},
-! url = {http://vecpar.fe.up.pt/2008}}
-
+! version 6.1, Christina Morency, July 2007:
+! - Solve Biot poroelastic equations
+! - Acoustic/poroelastic coupling
+! - Energy calculation available (flag in constants.h)
!
-! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, February 2008:
+! version 6.0, Christina Morency, May 2007:
+! - Solve Biot poroelastic equations
+!
+! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, November 2007:
! - MPI implementation of the code based on domain decomposition
! with METIS or SCOTCH
! - general fluid/solid implementation with any number, shape and orientation of
! matching edges
-! - fluid potential of density * displacement instead of displacement
! - absorbing edges with any normal vector
! - general numbering of absorbing and acoustic free surface edges
! - cleaned implementation of attenuation as in Carcione (1993)
@@ -124,21 +125,14 @@
! Institut de Physique du Globe de Paris, France
!
-! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
+! in case of an acoustic medium, a displacement potential Chi 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).
+! Displacement is then: u = grad(Chi)
+! Velocity is then: v = grad(Chi_dot) (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - rho * 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.
program specfem2D
@@ -165,7 +159,7 @@
character(len=150) dummystring
! for seismograms
- double precision, dimension(:,:), allocatable :: sisux,sisuz,siscurl
+ double precision, dimension(:,:), allocatable :: sisux,sisuz
integer :: seismo_offset, seismo_current
! vector field in an element
@@ -174,12 +168,9 @@
! pressure in an element
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
-! curl in an element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
-
- integer :: i,j,k,l,it,irec,ipoin,ip,id,n,ispec,npoin,npgeo,iglob
+ integer :: i,j,k,l,it,irec,ipoin,ip,id,nbpoin,inump,n,ispec,npoin,npgeo,iglob
logical :: anyabs
- double precision :: dxd,dzd,dcurld,valux,valuz,valcurl,hlagrange,rhol,cosrot,sinrot,xi,gamma,x,z
+ double precision :: dxd,dzd,valux,valuz,hlagrange,cosrot,sinrot,xi,gamma,x,z
! coefficients of the explicit Newmark time scheme
integer NSTEP
@@ -199,20 +190,40 @@
double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
! material properties of the elastic medium
- double precision :: mul_relaxed,lambdal_relaxed,kappal
+ double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,cpsquare
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_elastic,veloc_elastic,displ_elastic
- double precision, dimension(:,:), allocatable :: coord, flagrange,xinterp,zinterp,Uxinterp,Uzinterp,elastcoef,vector_field_display
+ double precision, dimension(:,:), allocatable :: coord, flagrange,xinterp,zinterp,Uxinterp,Uzinterp,vector_field_display
+! material properties of the poroelastic medium (solid phase:s and fluid phase [defined as w=phi(u_f-u_s)]: w)
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accels_poroelastic,velocs_poroelastic,displs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accelw_poroelastic,velocw_poroelastic,displw_poroelastic
+ double precision, dimension(:), allocatable :: porosity,tortuosity
+ double precision, dimension(:,:), allocatable :: density,permeability
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
+
+! poroelastic and elastic coefficients
+ double precision, dimension(:,:,:), allocatable :: poroelastcoef
+
+! to evaluate cpI, cpII, and cs, and rI
+ real(kind=CUSTOM_REAL) :: rhol,rhol_s,rhol_f,rhol_bar,phil,tortl
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s
+ real(kind=CUSTOM_REAL) :: kappal_f
+! double precision :: etal_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr
+! double precision :: permlxx,permlxz,permlzz
+ real(kind=CUSTOM_REAL) :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,B_biot,cpIsquare,cpIIsquare
+ real(kind=CUSTOM_REAL) :: gamma1,gamma2,gamma3,gamma4,ratio,dd1
+
! for acoustic medium
real(kind=CUSTOM_REAL), dimension(:), allocatable :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_inverse_elastic,rmass_inverse_acoustic
- double precision, dimension(:), allocatable :: density
+ double precision, dimension(:), allocatable :: displread,velocread,accelread
double precision, dimension(:), allocatable :: vp_display
double precision, dimension(:,:,:), allocatable :: vpext,vsext,rhoext
- double precision :: previous_vsext,rho_at_source_location
+ double precision :: previous_vsext
double precision, dimension(:,:,:), allocatable :: shape2D,shape2D_display
real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: xix,xiz,gammax,gammaz,jacobian
@@ -221,15 +232,16 @@
integer, dimension(:,:,:), allocatable :: ibool
integer, dimension(:,:), allocatable :: knods
- integer, dimension(:), allocatable :: kmato,numabs, &
- ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
+ integer, dimension(:), allocatable :: kmato,numabs
+ integer, dimension(:), allocatable :: ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,&
+ jend_left,jbegin_right,jend_right
integer ispec_selected_source,iglob_source,ix_source,iz_source,is_proc_source,nb_proc_source
- double precision aval,displnorm_all,displnorm_all_glob
+ double precision aval,displnorm_all,displnorm_all_glob,displnormw_all,displnormw_all_glob
real(kind=CUSTOM_REAL), dimension(:), allocatable :: source_time_function
double precision, external :: netlib_specfun_erf
- double precision :: vpmin,vpmax
+ double precision :: vpImin,vpImax,vpIImin,vpIImax
integer :: colors,numbers,subsamp,imagetype,NTSTEP_BETWEEN_OUTPUT_INFO,NTSTEP_BETWEEN_OUTPUT_SEISMO,seismotype
integer :: numat,ngnod,nspec,pointsdisp,nelemabs,nelem_acoustic_surface,ispecabs
@@ -241,7 +253,7 @@
double precision :: cutsnaps,sizemax_arrows,anglerec,xirec,gammarec
! for absorbing and acoustic free surface conditions
- integer :: ispec_acoustic_surface,inum,numabsread
+ integer :: ispec_acoustic_surface,inum,numabsread,nxread,nzread
logical :: codeabsread(4)
real(kind=CUSTOM_REAL) :: nx,nz,weight,xxi,zgamma
@@ -271,8 +283,68 @@
integer :: num_fluid_solid_edges,ispec_acoustic,ispec_elastic, &
iedge_acoustic,iedge_elastic,ipoin1D,iglob2
logical :: any_acoustic,any_acoustic_glob,any_elastic,any_elastic_glob,coupled_acoustic_elastic
- real(kind=CUSTOM_REAL) :: displ_x,displ_z,displ_n,zxi,xgamma,jacobian1D,pressure
+ real(kind=CUSTOM_REAL) :: displ_x,displ_z,displw_x,displw_z,displ_n,zxi,xgamma,jacobian1D,pressure,b_pressure
+ real(kind=CUSTOM_REAL) :: b_displ_x,b_displ_z,b_displw_x,b_displw_z
+! for fluid/porous medium coupling and edge detection
+ logical, dimension(:), allocatable :: poroelastic
+ logical :: any_poroelastic,any_poroelastic_glob
+ integer, dimension(:), allocatable :: fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge, &
+ fluid_poro_poroelastic_ispec,fluid_poro_poroelastic_iedge
+ integer :: num_fluid_poro_edges,num_fluid_poro_edges_alloc,iedge_poroelastic
+ logical :: coupled_acoustic_poroelastic
+ double precision :: mul_G,lambdal_G,lambdalplus2mul_G
+ double precision :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ double precision :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ double precision :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ double precision :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
+
+! for solid/porous medium coupling and edge detection
+ integer, dimension(:), allocatable :: solid_poro_elastic_ispec,solid_poro_elastic_iedge, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge
+ integer :: num_solid_poro_edges,num_solid_poro_edges_alloc,ispec_poroelastic,ii2,jj2
+ logical :: coupled_elastic_poroelastic
+ double precision, dimension(2) :: displ
+ double precision, dimension(2) :: veloc
+ double precision :: sigma_xx,sigma_xz,sigma_zz,sigmap,kappal
+ integer, dimension(:), allocatable :: ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,&
+ iend_top_poro,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro
+
+! for adjoint method
+ logical :: save_forward ! whether or not the last frame is saved to reconstruct the forward field
+ integer :: isolver ! 1 = forward wavefield, 2 = backward and adjoint wavefields and kernels
+ double precision :: b_deltatover2,b_deltatsquareover2,b_deltat ! coefficients of the explicit Newmark time scheme
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accels_poroelastic,b_velocs_poroelastic,b_displs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accelw_poroelastic,b_velocw_poroelastic,b_displw_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accel_elastic,b_veloc_elastic,b_displ_elastic
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_potential_dot_dot_acoustic,b_potential_dot_acoustic,b_potential_acoustic
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rho_kl, mu_kl, kappa_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_global, mul_global, kappal_global
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: mu_k, kappa_k,rho_k
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhop_kl, beta_kl, alpha_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhot_kl, rhof_kl, sm_kl, eta_kl, mufr_kl, B_kl, &
+ C_kl, M_kl, rhob_kl, rhofb_kl, phi_kl, Bb_kl, Cb_kl, Mb_kl, mufrb_kl, &
+ rhobb_kl, rhofbb_kl, phib_kl, cpI_kl, cpII_kl, cs_kl, r_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhot_k, rhof_k, sm_k, eta_k, mufr_k, B_k, &
+ C_k, M_k
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: phil_global,etal_f_global,rhol_s_global,rhol_f_global,rhol_bar_global, &
+ tortl_global
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: permlxx_global,permlxz_global,permlzz_global
+ character(len=150) :: adj_source_file,filename,filename2,filename3
+ integer :: irec_local,nadj_rec_local
+ double precision :: xx,zz,rholb
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: adj_sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearrays
+ double precision :: rhopmin,rhopmax,alphamin,alphamax,betamin,betamax
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_left,b_absorb_poro_s_left,b_absorb_poro_w_left
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_right,b_absorb_poro_s_right,b_absorb_poro_w_right
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_bottom,b_absorb_poro_s_bottom,b_absorb_poro_w_bottom
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_top,b_absorb_poro_s_top,b_absorb_poro_w_top
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_absorb_acoustic_left,b_absorb_acoustic_right,&
+ b_absorb_acoustic_bottom, b_absorb_acoustic_top
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(:), allocatable :: ib_xmin,ib_xmax,ib_zmin,ib_zmax
+
! for color images
integer :: NX_IMAGE_color,NZ_IMAGE_color
integer :: npgeo_glob
@@ -321,7 +393,7 @@
integer ihours,iminutes,iseconds,int_tCPU
double precision :: time_start,time_end,tCPU
-! for MPI and partitioning
+! for MPI and partitionning
integer :: ier
integer :: nproc
integer :: myrank
@@ -333,11 +405,11 @@
integer, dimension(:), allocatable :: my_neighbours
integer, dimension(:), allocatable :: my_nelmnts_neighbours
integer, dimension(:,:,:), allocatable :: my_interfaces
- integer, dimension(:,:), allocatable :: ibool_interfaces_acoustic,ibool_interfaces_elastic
- integer, dimension(:), allocatable :: nibool_interfaces_acoustic,nibool_interfaces_elastic
+ integer, dimension(:,:), allocatable :: ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(:), allocatable :: nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
- integer :: ninterface_acoustic, ninterface_elastic
- integer, dimension(:), allocatable :: inum_interfaces_acoustic, inum_interfaces_elastic
+ integer :: ninterface_acoustic, ninterface_elastic,ninterface_poroelastic
+ integer, dimension(:), allocatable :: inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
#ifdef USE_MPI
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_ac
@@ -346,7 +418,13 @@
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_el
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_el
integer, dimension(:), allocatable :: tab_requests_send_recv_elastic
- integer :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_pos
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_pos
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_pow
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_pow
+ integer, dimension(:), allocatable :: tab_requests_send_recv_poroelastic
+
+ integer :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, max_ibool_interfaces_size_po
#endif
! for overlapping MPI communications with computation
@@ -376,16 +454,6 @@
double precision, dimension(2) :: A_plane, B_plane, C_plane
double precision :: PP, PS, SP, SS, z0_source, x0_source, xmax, xmin, zmax, zmin, time_offset
-! beyond critical angle
- integer , dimension(:), allocatable :: left_bound,right_bound,bot_bound
- double precision , dimension(:,:), allocatable :: v0x_left,v0z_left,v0x_right,v0z_right,v0x_bot,v0z_bot
- double precision , dimension(:,:), allocatable :: t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot
- integer count_left,count_right,count_bot,ibegin,iend
- logical :: over_critical_angle
-
-! further reduce cache misses inner/outer in two passes in the case of an MPI simulation
- integer :: ipass,ispec_inner,ispec_outer,NUMBER_OF_PASSES
-
!***********************************************************************
!
! i n i t i a l i z a t i o n p h a s e
@@ -397,29 +465,23 @@
call MPI_COMM_SIZE(MPI_COMM_WORLD,nproc,ier)
call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
- if(FURTHER_REDUCE_CACHE_MISSES) then
- NUMBER_OF_PASSES = 2
- else
- NUMBER_OF_PASSES = 1
- endif
-
#else
nproc = 1
myrank = 0
ier = 0
ninterface_acoustic = 0
ninterface_elastic = 0
+ ninterface_poroelastic = 0
iproc = 0
- ispec_inner = 0
- ispec_outer = 0
- NUMBER_OF_PASSES = 1
#endif
- write(prname,230) myrank
- 230 format('./OUTPUT_FILES/Database',i5.5)
+ write(prname,230)myrank
+230 format('./OUTPUT_FILES/Database',i5.5)
+
open(unit=IIN,file=prname,status='old',action='read')
+
! determine if we write to file instead of standard output
if(IOUT /= ISTANDARD_OUTPUT) open(IOUT,file='simulation_results.txt',status='unknown')
@@ -436,16 +498,18 @@
!
!---- print the date, time and start-up banner
!
- if (myrank == 0) call datim(simulation_title)
+ if ( myrank == 0 ) then
+ call datim(simulation_title)
+ endif
- if (myrank == 0) then
- write(IOUT,*)
- write(IOUT,*)
- write(IOUT,*) '*********************'
- write(IOUT,*) '**** ****'
- write(IOUT,*) '**** SPECFEM2D ****'
- write(IOUT,*) '**** ****'
- write(IOUT,*) '*********************'
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,*) '*********************'
+ write(IOUT,*) '**** ****'
+ write(IOUT,*) '**** SPECFEM2D ****'
+ write(IOUT,*) '**** ****'
+ write(IOUT,*) '*********************'
endif
!
@@ -476,9 +540,15 @@
if(add_Bielak_conditions .and. .not. initialfield) stop 'need to have an initial field to add Bielak plane wave conditions'
read(IIN,"(a80)") datlin
- read(IIN,*) seismotype,imagetype
- if(seismotype < 1 .or. seismotype > 5) call exit_MPI('Wrong type for seismogram output')
+ read(IIN,*) seismotype,imagetype,save_forward
+ if(seismotype < 1 .or. seismotype > 4) call exit_MPI('Wrong type for seismogram output')
if(imagetype < 1 .or. imagetype > 4) call exit_MPI('Wrong type for snapshots')
+ if(save_forward .and. seismotype /= 1) then
+ seismotype = 1
+ print*, '***** WARNING *****'
+ print*, 'Save forward wavefield => seismogram must be in displacement'
+ print*, 'seismotype has been changed to 1'
+ endif
read(IIN,"(a80)") datlin
read(IIN,*) assign_external_model,outputgrid,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
@@ -492,10 +562,27 @@
!---- read time step
read(IIN,"(a80)") datlin
- read(IIN,*) NSTEP,deltat
- if (myrank == 0) write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+ read(IIN,*) NSTEP,deltat,isolver
+ if ( myrank == 0 ) then
+ write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+ endif
NTSTEP_BETWEEN_OUTPUT_SEISMO = min(NSTEP,NTSTEP_BETWEEN_OUTPUT_INFO)
+ if ( myrank == 0 ) then
+ if(isolver == 1) then
+ print*, ' *************************** '
+ print*, ' **** Forward wavefield **** '
+ print*, ' *************************** '
+ elseif(isolver == 2) then
+ print*, ' *************************** '
+ print*, ' **** Adjoint wavefield, *** '
+ print*, ' **** Backward wavefield *** '
+ print*, ' **** and kernels ********** '
+ print*, ' *************************** '
+ else
+ stop ' wrong isolver, must be 1 or 2 '
+ endif
+ endif
!
!---- read source information
@@ -514,26 +601,18 @@
!
if(.not. initialfield) then
if (source_type == 1) then
- if (myrank == 0) write(IOUT,212) x_source,z_source,f0,t0,factor,angleforce
+ if ( myrank == 0 ) then
+ write(IOUT,212) x_source,z_source,f0,t0,factor,angleforce
+ endif
else if(source_type == 2) then
- if (myrank == 0) write(IOUT,222) x_source,z_source,f0,t0,factor,Mxx,Mzz,Mxz
+ if ( myrank == 0 ) then
+ write(IOUT,222) x_source,z_source,f0,t0,factor,Mxx,Mzz,Mxz
+ endif
else
- call exit_MPI('Unknown source type number')
+ call exit_MPI('Unknown source type number !')
endif
endif
-! if Dirac source time function, use a very thin Gaussian instead
-! if Heaviside source time function, use a very thin error function instead
-! time delay of the source in seconds, use a 20 % security margin (use 2 / f0 if error function)
- if(time_function_type == 4 .or. time_function_type == 5) then
- f0 = 1.d0 / (10.d0 * deltat)
- if(time_function_type == 5) then
- t0 = 2.0d0 / f0
- else
- t0 = 1.20d0 / f0
- endif
- endif
-
! for the source time function
aval = pi*pi*f0*f0
@@ -561,8 +640,9 @@
read(IIN,"(a80)") datlin
read(IIN,*) numat,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
read(IIN,"(a80)") datlin
- read(IIN,*) nelemabs,nelem_acoustic_surface,num_fluid_solid_edges
-
+ read(IIN,*) nelemabs,nelem_acoustic_surface,num_fluid_solid_edges,num_fluid_poro_edges,num_solid_poro_edges
+ read(IIN,"(a80)") datlin
+ read(IIN,*) nxread,nzread
!
!---- allocate arrays
!
@@ -580,12 +660,16 @@
allocate(zinterp(pointsdisp,pointsdisp))
allocate(Uxinterp(pointsdisp,pointsdisp))
allocate(Uzinterp(pointsdisp,pointsdisp))
- allocate(density(numat))
- allocate(elastcoef(4,numat))
+ allocate(density(2,numat))
+ allocate(porosity(numat))
+ allocate(tortuosity(numat))
+ allocate(permeability(3,numat))
+ allocate(poroelastcoef(4,3,numat))
allocate(kmato(nspec))
allocate(knods(ngnod,nspec))
allocate(ibool(NGLLX,NGLLZ,nspec))
allocate(elastic(nspec))
+ allocate(poroelastic(nspec))
allocate(inv_tau_sigma_nu1(N_SLS))
allocate(inv_tau_sigma_nu2(N_SLS))
allocate(phi_nu1(N_SLS))
@@ -601,16 +685,26 @@
allocate(numabs(nelemabs))
allocate(codeabs(4,nelemabs))
- allocate(ibegin_bottom(nelemabs))
- allocate(iend_bottom(nelemabs))
- allocate(ibegin_top(nelemabs))
- allocate(iend_top(nelemabs))
+ allocate(ibegin_bottom(nxread))
+ allocate(iend_bottom(nxread))
+ allocate(ibegin_top(nxread))
+ allocate(iend_top(nxread))
- allocate(jbegin_left(nelemabs))
- allocate(jend_left(nelemabs))
- allocate(jbegin_right(nelemabs))
- allocate(jend_right(nelemabs))
+ allocate(jbegin_left(nzread))
+ allocate(jend_left(nzread))
+ allocate(jbegin_right(nzread))
+ allocate(jend_right(nzread))
+ allocate(ibegin_bottom_poro(nxread))
+ allocate(iend_bottom_poro(nxread))
+ allocate(ibegin_top_poro(nxread))
+ allocate(iend_top_poro(nxread))
+
+ allocate(jbegin_left_poro(nzread))
+ allocate(jend_left_poro(nzread))
+ allocate(jbegin_right_poro(nzread))
+ allocate(jend_right_poro(nzread))
+
!
!---- print element group main parameters
!
@@ -623,8 +717,7 @@
!
!---- read the material properties
!
- call gmat01(density,elastcoef,numat)
-
+ call gmat01(density,porosity,tortuosity,permeability,poroelastcoef,numat)
!
!---- read spectral macrobloc data
!
@@ -634,19 +727,25 @@
read(IIN,*) n,kmato(n),(knods(k,n), k=1,ngnod)
enddo
-!
-!---- determine if each spectral element is elastic or acoustic
-!
- any_acoustic = .false.
- any_elastic = .false.
+!-------------------------------------------------------------------------------
+!---- determine if each spectral element is elastic, poroelastic, or acoustic
+!-------------------------------------------------------------------------------
+ any_acoustic = .false.
+ any_elastic = .false.
+ any_poroelastic = .false.
do ispec = 1,nspec
- mul_relaxed = elastcoef(2,kmato(ispec))
- if(mul_relaxed < TINYVAL) then
+ if(porosity(kmato(ispec)) >= 1.d0) then ! acoustic domain
elastic(ispec) = .false.
+ poroelastic(ispec) = .false.
any_acoustic = .true.
- else
+ elseif(porosity(kmato(ispec)) < TINYVAL) then ! elastic domain
elastic(ispec) = .true.
+ poroelastic(ispec) = .false.
any_elastic = .true.
+ else ! poroelastic domain
+ elastic(ispec) = .false.
+ poroelastic(ispec) = .true.
+ any_poroelastic = .true.
endif
enddo
@@ -680,18 +779,29 @@
!
!---- read interfaces data
!
+ print *, 'read the interfaces', myrank
read(IIN,"(a80)") datlin
read(IIN,*) ninterface, max_interface_size
- if ( ninterface > 0 ) then
+ if ( ninterface == 0 ) then
+ !allocate(my_neighbours(1))
+ !allocate(my_nelmnts_neighbours(1))
+ !allocate(my_interfaces(4,1,1))
+ !allocate(ibool_interfaces(NGLLX*1,1,1))
+ !allocate(nibool_interfaces(1,1))
+
+ else
allocate(my_neighbours(ninterface))
allocate(my_nelmnts_neighbours(ninterface))
allocate(my_interfaces(4,max_interface_size,ninterface))
allocate(ibool_interfaces_acoustic(NGLLX*max_interface_size,ninterface))
allocate(ibool_interfaces_elastic(NGLLX*max_interface_size,ninterface))
+ allocate(ibool_interfaces_poroelastic(NGLLX*max_interface_size,ninterface))
allocate(nibool_interfaces_acoustic(ninterface))
allocate(nibool_interfaces_elastic(ninterface))
+ allocate(nibool_interfaces_poroelastic(ninterface))
allocate(inum_interfaces_acoustic(ninterface))
allocate(inum_interfaces_elastic(ninterface))
+ allocate(inum_interfaces_poroelastic(ninterface))
do num_interface = 1, ninterface
read(IIN,*) my_neighbours(num_interface), my_nelmnts_neighbours(num_interface)
@@ -699,19 +809,25 @@
read(IIN,*) my_interfaces(1,ie,num_interface), my_interfaces(2,ie,num_interface), &
my_interfaces(3,ie,num_interface), my_interfaces(4,ie,num_interface)
- enddo
- enddo
- endif
+ end do
+ end do
+ print *, 'end read the interfaces', myrank
+ end if
+
+
!
!---- read absorbing boundary data
!
-
read(IIN,"(a80)") datlin
if(anyabs) then
do inum = 1,nelemabs
- read(IIN,*) numabsread,codeabsread(1),codeabsread(2),codeabsread(3),codeabsread(4), ibegin_bottom(inum), iend_bottom(inum), &
- jbegin_right(inum), jend_right(inum), ibegin_top(inum), iend_top(inum), jbegin_left(inum), jend_left(inum)
+!chris
+! evantually suppress lecture of ibegin_bottom(inum), iend_bottom(inum), jbegin_right(inum), jend_right(inum), ibegin_top(inum),
+! iend_top(inum), jbegin_left(inum), jend_left(inum)
+! read(IIN,*) numabsread,codeabsread(1),codeabsread(2),codeabsread(3),codeabsread(4), ibegin_bottom(inum), iend_bottom(inum), &
+! jbegin_right(inum), jend_right(inum), ibegin_top(inum), iend_top(inum), jbegin_left(inum), jend_left(inum)
+ read(IIN,*) numabsread,codeabsread(1),codeabsread(2),codeabsread(3),codeabsread(4)
if(numabsread < 1 .or. numabsread > nspec) call exit_MPI('Wrong absorbing element number')
numabs(inum) = numabsread
codeabs(IBOTTOM,inum) = codeabsread(1)
@@ -721,6 +837,63 @@
enddo
write(IOUT,*)
write(IOUT,*) 'Number of absorbing elements: ',nelemabs
+
+ nspec_xmin = ZERO
+ nspec_xmax = ZERO
+ nspec_zmin = ZERO
+ nspec_zmax = ZERO
+ allocate(ib_xmin(nzread))
+ allocate(ib_xmax(nzread))
+ allocate(ib_zmin(nxread))
+ allocate(ib_zmax(nxread))
+ do inum = 1,nelemabs
+ if (codeabs(IBOTTOM,inum)) then
+ nspec_zmin = nspec_zmin + 1
+ ib_zmin(nspec_zmin) = numabs(inum)
+ endif
+ if (codeabs(IRIGHT,inum)) then
+ nspec_xmax = nspec_xmax + 1
+ ib_xmax(nspec_xmax) = numabs(inum)
+ endif
+ if (codeabs(ITOP,inum)) then
+ nspec_zmax = nspec_zmax + 1
+ ib_zmax(nspec_zmax) = numabs(inum)
+ endif
+ if (codeabs(ILEFT,inum)) then
+ nspec_xmin = nspec_xmin + 1
+ ib_xmin(nspec_xmin) = numabs(inum)
+ endif
+ enddo
+! Files to save absorbed waves needed to reconstruct backward wavefield for adjoint method
+ if(any_elastic .and. (save_forward .or. isolver == 2)) then
+ allocate(b_absorb_elastic_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_elastic_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_elastic_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_elastic_top(NDIM,NGLLX,nspec_zmax,NSTEP))
+ endif
+ if(any_poroelastic .and. (save_forward .or. isolver == 2)) then
+ allocate(b_absorb_poro_s_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_poro_s_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_poro_s_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_poro_s_top(NDIM,NGLLX,nspec_zmax,NSTEP))
+ allocate(b_absorb_poro_w_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_poro_w_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_poro_w_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_poro_w_top(NDIM,NGLLX,nspec_zmax,NSTEP))
+ endif
+ if(any_acoustic .and. (save_forward .or. isolver == 2)) then
+ allocate(b_absorb_acoustic_left(NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_acoustic_right(NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_acoustic_bottom(NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_acoustic_top(NGLLX,nspec_zmax,NSTEP))
+ endif
+
+ write(IOUT,*)
+ write(IOUT,*) 'nspec_xmin = ',nspec_xmin
+ write(IOUT,*) 'nspec_xmax = ',nspec_xmax
+ write(IOUT,*) 'nspec_zmin = ',nspec_zmin
+ write(IOUT,*) 'nspec_zmax = ',nspec_zmax
+
endif
!
@@ -732,7 +905,7 @@
do inum = 1,nelem_acoustic_surface
read(IIN,*) acoustic_edges(1,inum), acoustic_edges(2,inum), acoustic_edges(3,inum), &
acoustic_edges(4,inum)
- enddo
+ end do
allocate(acoustic_surface(5,nelem_acoustic_surface))
call construct_acoustic_surface ( nspec, ngnod, knods, nelem_acoustic_surface, &
acoustic_edges, acoustic_surface)
@@ -754,16 +927,56 @@
allocate(fluid_solid_elastic_iedge(num_fluid_solid_edges))
do inum = 1, num_fluid_solid_edges
read(IIN,*) fluid_solid_acoustic_ispec(inum), fluid_solid_elastic_ispec(inum)
- enddo
+ end do
else
allocate(fluid_solid_acoustic_ispec(1))
allocate(fluid_solid_acoustic_iedge(1))
allocate(fluid_solid_elastic_ispec(1))
allocate(fluid_solid_elastic_iedge(1))
- endif
+ end if
!
+!---- read acoustic poroelastic coupled edges
+!
+ read(IIN,"(a80)") datlin
+ if ( num_fluid_poro_edges > 0 ) then
+ allocate(fluid_poro_acoustic_ispec(num_fluid_poro_edges))
+ allocate(fluid_poro_acoustic_iedge(num_fluid_poro_edges))
+ allocate(fluid_poro_poroelastic_ispec(num_fluid_poro_edges))
+ allocate(fluid_poro_poroelastic_iedge(num_fluid_poro_edges))
+ do inum = 1, num_fluid_poro_edges
+ read(IIN,*) fluid_poro_acoustic_ispec(inum), fluid_poro_poroelastic_ispec(inum)
+ end do
+ else
+ allocate(fluid_poro_acoustic_ispec(1))
+ allocate(fluid_poro_acoustic_iedge(1))
+ allocate(fluid_poro_poroelastic_ispec(1))
+ allocate(fluid_poro_poroelastic_iedge(1))
+
+ end if
+
+!
+!---- read poroelastic elastic coupled edges
+!
+ read(IIN,"(a80)") datlin
+ if ( num_solid_poro_edges > 0 ) then
+ allocate(solid_poro_elastic_ispec(num_solid_poro_edges))
+ allocate(solid_poro_elastic_iedge(num_solid_poro_edges))
+ allocate(solid_poro_poroelastic_ispec(num_solid_poro_edges))
+ allocate(solid_poro_poroelastic_iedge(num_solid_poro_edges))
+ do inum = 1, num_solid_poro_edges
+ read(IIN,*) solid_poro_poroelastic_ispec(inum), solid_poro_elastic_ispec(inum)
+ end do
+ else
+ allocate(solid_poro_elastic_ispec(1))
+ allocate(solid_poro_elastic_iedge(1))
+ allocate(solid_poro_poroelastic_ispec(1))
+ allocate(solid_poro_poroelastic_iedge(1))
+
+ end if
+
+!
!---- close input file
!
close(IIN)
@@ -788,15 +1001,10 @@
call createnum_slow(knods,ibool,npoin,nspec,ngnod)
endif
-! reduction of cache misses inner/outer in two passes
- do ipass = 1,NUMBER_OF_PASSES
-
-! create a new indirect addressing array to reduce cache misses in memory access in the solver
- if(ipass == 1) then
-
+! create a new indirect addressing array instead, to reduce cache misses
+! in memory access in the solver
allocate(copy_ibool_ori(NGLLX,NGLLZ,nspec))
allocate(mask_ibool(npoin))
-
mask_ibool(:) = -1
copy_ibool_ori(:,:,:) = ibool(:,:,:)
@@ -816,72 +1024,9 @@
enddo
enddo
enddo
-
- if(NUMBER_OF_PASSES == 1) then
- deallocate(copy_ibool_ori)
- deallocate(mask_ibool)
- endif
-
- else if(ipass == 2) then
-
- mask_ibool(:) = -1
- copy_ibool_ori(:,:,:) = ibool(:,:,:)
-
- inumber = 0
-
-! first reduce cache misses in outer elements, since they are taken first
-
-! loop over spectral elements
- do ispec_outer = 1,nspec_outer
-
-! get global numbering for inner or outer elements
- ispec = ispec_outer_to_glob(ispec_outer)
-
- do j=1,NGLLZ
- do i=1,NGLLX
- if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
-! create a new point
- inumber = inumber + 1
- ibool(i,j,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
- else
-! use an existing point created previously
- ibool(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
- endif
- enddo
- enddo
- enddo
-
-! then reduce cache misses in inner elements, since they are taken second
-
-! loop over spectral elements
- do ispec_inner = 1,nspec_inner
-
-! get global numbering for inner or outer elements
- ispec = ispec_inner_to_glob(ispec_inner)
-
- do j=1,NGLLZ
- do i=1,NGLLX
- if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
-! create a new point
- inumber = inumber + 1
- ibool(i,j,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
- else
-! use an existing point created previously
- ibool(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
- endif
- enddo
- enddo
- enddo
-
deallocate(copy_ibool_ori)
deallocate(mask_ibool)
- else
- stop 'incorrect pass number for reduction of cache misses'
- endif
-
!---- compute shape functions and their derivatives for regular interpolated display grid
do j = 1,pointsdisp
do i = 1,pointsdisp
@@ -918,8 +1063,6 @@
if(nrec < 1) call exit_MPI('need at least one receiver')
! receiver information
- if(ipass == 1) then
-
allocate(ispec_selected_rec(nrec))
allocate(st_xval(nrec))
allocate(st_zval(nrec))
@@ -956,8 +1099,6 @@
allocate(rhoext(1,1,1))
endif
- endif
-
!
!---- set the coordinates of the points of the global grid
!
@@ -987,19 +1128,17 @@
!--- save the grid of points in a file
!
if(outputgrid) then
- write(IOUT,*)
- write(IOUT,*) 'Saving the grid in a text file...'
- write(IOUT,*)
- open(unit=55,file='OUTPUT_FILES/grid_points_and_model.txt',status='unknown')
- zmax=maxval(coord(2,:))
- write(55,*) npoin
- do n = 1,npoin
- write(55,*) (coord(i,n), i=1,NDIM)
- enddo
- close(55)
+ write(IOUT,*)
+ write(IOUT,*) 'Saving the grid in a text file...'
+ write(IOUT,*)
+ open(unit=55,file='OUTPUT_FILES/grid_points_and_model.txt',status='unknown')
+ write(55,*) npoin
+ do n = 1,npoin
+ write(55,*) (coord(i,n), i=1,NDIM)
+ enddo
+ close(55)
endif
-
!
!----- plot the GLL mesh in a Gnuplot file
!
@@ -1010,12 +1149,13 @@
!
if(assign_external_model) then
write(IOUT,*)
- write(IOUT,*) 'Assigning external velocity and density model...'
+ write(IOUT,*) 'Assigning external velocity and density model (elastic and/or acoustic)...'
write(IOUT,*)
if(TURN_ANISOTROPY_ON .or. TURN_ATTENUATION_ON) &
call exit_MPI('cannot have anisotropy nor attenuation if external model in current version')
any_acoustic = .false.
any_elastic = .false.
+ any_poroelastic = .false.
do ispec = 1,nspec
previous_vsext = -1.d0
do j = 1,NGLLZ
@@ -1030,8 +1170,10 @@
call exit_MPI('external velocity model cannot be both fluid and solid inside the same spectral element')
if(vsext(i,j,ispec) < TINYVAL) then
elastic(ispec) = .false.
+ poroelastic(ispec) = .false.
any_acoustic = .true.
else
+ poroelastic(ispec) = .false.
elastic(ispec) = .true.
any_elastic = .true.
endif
@@ -1044,13 +1186,16 @@
!
!---- perform basic checks on parameters read
!
- any_elastic_glob = any_elastic
+any_elastic_glob = any_elastic
#ifdef USE_MPI
call MPI_ALLREDUCE(any_elastic, any_elastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
#endif
-
- any_acoustic_glob = any_acoustic
+any_poroelastic_glob = any_poroelastic
#ifdef USE_MPI
+ call MPI_ALLREDUCE(any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+any_acoustic_glob = any_acoustic
+#ifdef USE_MPI
call MPI_ALLREDUCE(any_acoustic, any_acoustic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
#endif
@@ -1062,46 +1207,44 @@
call exit_MPI('currently cannot have attenuation if acoustic simulation only')
! for attenuation
- if(TURN_ANISOTROPY_ON .and. TURN_ATTENUATION_ON) &
+ if(TURN_ANISOTROPY_ON .and. TURN_ATTENUATION_ON) then
call exit_MPI('cannot have anisotropy and attenuation both turned on in current version')
-
+ end if
!
!---- define coefficients of the Newmark time scheme
!
deltatover2 = HALF*deltat
deltatsquareover2 = HALF*deltat*deltat
+ if(isolver == 2) then
+! define coefficients of the Newmark time scheme for the backward wavefield
+ b_deltat = - deltat
+ b_deltatover2 = HALF*b_deltat
+ b_deltatsquareover2 = HALF*b_deltat*b_deltat
+ endif
+
!---- define actual location of source and receivers
if(source_type == 1) then
-
! collocated force source
- call locate_source_force(coord,ibool,npoin,nspec,x_source,z_source, &
+ call locate_source_force(coord,ibool,npoin,nspec,x_source,z_source,source_type, &
ix_source,iz_source,ispec_selected_source,iglob_source,is_proc_source,nb_proc_source)
-! get density at the source in order to implement collocated force with the right
-! amplitude later
- if(is_proc_source == 1) then
- rho_at_source_location = density(kmato(ispec_selected_source))
-! external velocity model
- if(assign_external_model) rho_at_source_location = rhoext(ix_source,iz_source,ispec_selected_source)
- endif
-
! check that acoustic source is not exactly on the free surface because pressure is zero there
- if(is_proc_source == 1) then
+ if ( is_proc_source == 1 ) then
do ispec_acoustic_surface = 1,nelem_acoustic_surface
ispec = acoustic_surface(1,ispec_acoustic_surface)
- if( .not. elastic(ispec) .and. ispec == ispec_selected_source ) then
+ if( .not. elastic(ispec) .and. .not. poroelastic(ispec) .and. ispec == ispec_selected_source ) then
do j = acoustic_surface(4,ispec_acoustic_surface), acoustic_surface(5,ispec_acoustic_surface)
do i = acoustic_surface(2,ispec_acoustic_surface), acoustic_surface(3,ispec_acoustic_surface)
iglob = ibool(i,j,ispec)
if ( iglob_source == iglob ) then
call exit_MPI('an acoustic source cannot be located exactly on the free surface because pressure is zero there')
- endif
- enddo
- enddo
+ end if
+ end do
+ end do
endif
enddo
- endif
+ end if
else if(source_type == 2) then
! moment-tensor source
@@ -1112,22 +1255,47 @@
call compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,nspec)
- else if(.not.initialfield) then
+ else
call exit_MPI('incorrect source type')
endif
+
! locate receivers in the mesh
call locate_receivers(ibool,coord,nspec,npoin,xigll,zigll,nrec,nrecloc,recloc,which_proc_receiver,nproc,myrank,&
st_xval,st_zval,ispec_selected_rec, &
xi_receiver,gamma_receiver,station_name,network_name,x_source,z_source,coorg,knods,ngnod,npgeo)
-! allocate seismogram arrays
- if(ipass == 1) then
- allocate(sisux(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
- allocate(sisuz(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
- allocate(siscurl(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
+! compute source array for adjoint source
+ if(isolver == 2) then ! adjoint calculation
+ nadj_rec_local = 0
+ do irec = 1,nrec
+ if(myrank == which_proc_receiver(irec))then
+! check that the source proc number is okay
+ if(which_proc_receiver(irec) < 0 .or. which_proc_receiver(irec) > NPROC-1) &
+ call exit_MPI(myrank,'something is wrong with the source proc number in adjoint simulation')
+ nadj_rec_local = nadj_rec_local + 1
+ endif
+ enddo
+ allocate(adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLZ))
+ if (nadj_rec_local > 0) allocate(adj_sourcearrays(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLZ))
+ irec_local = 0
+ do irec = 1, nrec
+! compute only adjoint source arrays in the local proc
+ if(myrank == which_proc_receiver(irec))then
+ irec_local = irec_local + 1
+ adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+ call compute_arrays_adj_source(myrank,adj_source_file, &
+ xi_receiver(irec), gamma_receiver(irec), &
+ adj_sourcearray, xigll,zigll,NSTEP)
+ adj_sourcearrays(irec_local,:,:,:,:) = adj_sourcearray(:,:,:,:)
+ endif
+ enddo
endif
+! allocate seismogram arrays
+ allocate(sisux(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
+ allocate(sisuz(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
+
! check if acoustic receiver is exactly on the free surface because pressure is zero there
do ispec_acoustic_surface = 1,nelem_acoustic_surface
ispec = acoustic_surface(1,ispec_acoustic_surface)
@@ -1137,7 +1305,7 @@
izmax = acoustic_surface(5,ispec_acoustic_surface)
do irecloc = 1,nrecloc
irec = recloc(irecloc)
- if(.not. elastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
if ( (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==NGLLX .and. &
gamma_receiver(irec) < -0.99d0) .or.&
(izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==NGLLX .and. &
@@ -1177,8 +1345,6 @@
enddo
! displacement, velocity, acceleration and inverse of the mass matrix for elastic elements
- if(ipass == 1) then
-
if(any_elastic) then
allocate(displ_elastic(NDIM,npoin))
allocate(veloc_elastic(NDIM,npoin))
@@ -1191,7 +1357,156 @@
allocate(accel_elastic(1,1))
allocate(rmass_inverse_elastic(1))
endif
+! extra array if adjoint and kernels calculation
+ if(isolver == 2 .and. any_elastic) then
+ allocate(b_displ_elastic(NDIM,npoin))
+ allocate(b_veloc_elastic(NDIM,npoin))
+ allocate(b_accel_elastic(NDIM,npoin))
+ allocate(rho_kl(npoin))
+ allocate(rho_k(npoin))
+ allocate(rhol_global(npoin))
+ allocate(mu_kl(npoin))
+ allocate(mu_k(npoin))
+ allocate(mul_global(npoin))
+ allocate(kappa_kl(npoin))
+ allocate(kappa_k(npoin))
+ allocate(kappal_global(npoin))
+ allocate(rhop_kl(npoin))
+ allocate(alpha_kl(npoin))
+ allocate(beta_kl(npoin))
+ else
+ allocate(b_displ_elastic(1,1))
+ allocate(b_veloc_elastic(1,1))
+ allocate(b_accel_elastic(1,1))
+ allocate(rho_kl(1))
+ allocate(rho_k(1))
+ allocate(rhol_global(1))
+ allocate(mu_kl(1))
+ allocate(mu_k(1))
+ allocate(mul_global(1))
+ allocate(kappa_kl(1))
+ allocate(kappa_k(1))
+ allocate(kappal_global(1))
+ allocate(rhop_kl(1))
+ allocate(alpha_kl(1))
+ allocate(beta_kl(1))
+ endif
+ if(any_poroelastic) then
+ allocate(displs_poroelastic(NDIM,npoin))
+ allocate(velocs_poroelastic(NDIM,npoin))
+ allocate(accels_poroelastic(NDIM,npoin))
+ allocate(rmass_s_inverse_poroelastic(npoin))
+ allocate(displw_poroelastic(NDIM,npoin))
+ allocate(velocw_poroelastic(NDIM,npoin))
+ allocate(accelw_poroelastic(NDIM,npoin))
+ allocate(rmass_w_inverse_poroelastic(npoin))
+ else
+! allocate unused arrays with fictitious size
+ allocate(displs_poroelastic(1,1))
+ allocate(velocs_poroelastic(1,1))
+ allocate(accels_poroelastic(1,1))
+ allocate(rmass_s_inverse_poroelastic(1))
+ allocate(displw_poroelastic(1,1))
+ allocate(velocw_poroelastic(1,1))
+ allocate(accelw_poroelastic(1,1))
+ allocate(rmass_w_inverse_poroelastic(1))
+ endif
+! extra array if adjoint and kernels calculation
+ if(isolver == 2 .and. any_poroelastic) then
+ allocate(b_displs_poroelastic(NDIM,npoin))
+ allocate(b_velocs_poroelastic(NDIM,npoin))
+ allocate(b_accels_poroelastic(NDIM,npoin))
+ allocate(b_displw_poroelastic(NDIM,npoin))
+ allocate(b_velocw_poroelastic(NDIM,npoin))
+ allocate(b_accelw_poroelastic(NDIM,npoin))
+ allocate(rhot_kl(npoin))
+ allocate(rhot_k(npoin))
+ allocate(rhof_kl(npoin))
+ allocate(rhof_k(npoin))
+ allocate(sm_kl(npoin))
+ allocate(sm_k(npoin))
+ allocate(eta_kl(npoin))
+ allocate(eta_k(npoin))
+ allocate(mufr_kl(npoin))
+ allocate(mufr_k(npoin))
+ allocate(B_kl(npoin))
+ allocate(B_k(npoin))
+ allocate(C_kl(npoin))
+ allocate(C_k(npoin))
+ allocate(M_kl(npoin))
+ allocate(M_k(npoin))
+ allocate(rhob_kl(npoin))
+ allocate(rhofb_kl(npoin))
+ allocate(phi_kl(npoin))
+ allocate(Bb_kl(npoin))
+ allocate(Cb_kl(npoin))
+ allocate(Mb_kl(npoin))
+ allocate(mufrb_kl(npoin))
+ allocate(rhobb_kl(npoin))
+ allocate(rhofbb_kl(npoin))
+ allocate(phib_kl(npoin))
+ allocate(cpI_kl(npoin))
+ allocate(cpII_kl(npoin))
+ allocate(cs_kl(npoin))
+ allocate(r_kl(npoin))
+ allocate(phil_global(npoin))
+ allocate(etal_f_global(npoin))
+ allocate(rhol_s_global(npoin))
+ allocate(rhol_f_global(npoin))
+ allocate(rhol_bar_global(npoin))
+ allocate(tortl_global(npoin))
+ allocate(permlxx_global(npoin))
+ allocate(permlxz_global(npoin))
+ allocate(permlzz_global(npoin))
+ else
+ allocate(b_displs_poroelastic(1,1))
+ allocate(b_velocs_poroelastic(1,1))
+ allocate(b_accels_poroelastic(1,1))
+ allocate(b_displw_poroelastic(1,1))
+ allocate(b_velocw_poroelastic(1,1))
+ allocate(b_accelw_poroelastic(1,1))
+ allocate(rhot_kl(1))
+ allocate(rhot_k(1))
+ allocate(rhof_kl(1))
+ allocate(rhof_k(1))
+ allocate(sm_kl(1))
+ allocate(sm_k(1))
+ allocate(eta_kl(1))
+ allocate(eta_k(1))
+ allocate(mufr_kl(1))
+ allocate(mufr_k(1))
+ allocate(B_kl(1))
+ allocate(B_k(1))
+ allocate(C_kl(1))
+ allocate(C_k(1))
+ allocate(M_kl(1))
+ allocate(M_k(1))
+ allocate(rhob_kl(1))
+ allocate(rhofb_kl(1))
+ allocate(phi_kl(1))
+ allocate(Bb_kl(1))
+ allocate(Cb_kl(1))
+ allocate(Mb_kl(1))
+ allocate(mufrb_kl(1))
+ allocate(rhobb_kl(1))
+ allocate(rhofbb_kl(1))
+ allocate(phib_kl(1))
+ allocate(cpI_kl(1))
+ allocate(cpII_kl(1))
+ allocate(cs_kl(1))
+ allocate(r_kl(1))
+ allocate(phil_global(1))
+ allocate(etal_f_global(1))
+ allocate(rhol_s_global(1))
+ allocate(rhol_f_global(1))
+ allocate(rhol_bar_global(1))
+ allocate(tortl_global(1))
+ allocate(permlxx_global(1))
+ allocate(permlxz_global(1))
+ allocate(permlzz_global(1))
+ endif
+
! potential, its first and second derivative, and inverse of the mass matrix for acoustic elements
if(any_acoustic) then
allocate(potential_acoustic(npoin))
@@ -1205,35 +1520,66 @@
allocate(potential_dot_dot_acoustic(1))
allocate(rmass_inverse_acoustic(1))
endif
-
+ if(isolver == 2 .and. any_acoustic) then
+ allocate(b_potential_acoustic(npoin))
+ allocate(b_potential_dot_acoustic(npoin))
+ allocate(b_potential_dot_dot_acoustic(npoin))
+ else
+! allocate unused arrays with fictitious size
+ allocate(b_potential_acoustic(1))
+ allocate(b_potential_dot_acoustic(1))
+ allocate(b_potential_dot_dot_acoustic(1))
endif
!
!---- build the global mass matrix and invert it once and for all
!
if(any_elastic) rmass_inverse_elastic(:) = ZERO
+!
+ if(any_poroelastic) rmass_s_inverse_poroelastic(:) = ZERO
+ if(any_poroelastic) rmass_w_inverse_poroelastic(:) = ZERO
+!
if(any_acoustic) rmass_inverse_acoustic(:) = ZERO
+!
do ispec = 1,nspec
do j = 1,NGLLZ
do i = 1,NGLLX
iglob = ibool(i,j,ispec)
+
+ if(poroelastic(ispec)) then ! material is poroelastic
+ rhol_s = density(1,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ rhol_bar = (1._CUSTOM_REAL-phil)*rhol_s + phil*rhol_f
+! for the solid mass matrix
+ rmass_s_inverse_poroelastic(iglob) = rmass_s_inverse_poroelastic(iglob) + &
+ wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar - phil*rhol_f/tortl)
+! for the fluid mass matrix
+ rmass_w_inverse_poroelastic(iglob) = rmass_w_inverse_poroelastic(iglob) + &
+ wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar*rhol_f*tortl - &
+ phil*rhol_f*rhol_f)/(rhol_bar*phil)
+ elseif(elastic(ispec)) then ! material is elastic
! if external density model
if(assign_external_model) then
rhol = rhoext(i,j,ispec)
- kappal = rhol * vpext(i,j,ispec)**2
else
- rhol = density(kmato(ispec))
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- kappal = lambdal_relaxed + 2.d0*mul_relaxed
+ rhol = density(1,kmato(ispec))
endif
- if(elastic(ispec)) then
-! for elastic medium
rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
+ else ! material is acoustic
+! if external density model
+ if(assign_external_model) then
+ rhol = rhoext(i,j,ispec)
+ cpsquare = vpext(i,j,ispec)**2
else
-! for acoustic medium
- rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / kappal
+ rhol = density(2,kmato(ispec))
+ lambdal_relaxed = poroelastcoef(1,2,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,2,kmato(ispec))
+ cpsquare = (lambdal_relaxed + 2._CUSTOM_REAL*mul_relaxed) / rhol
endif
+ rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / cpsquare
+ endif
enddo
enddo
enddo
@@ -1241,26 +1587,26 @@
#ifdef USE_MPI
if ( nproc > 1 ) then
! preparing for MPI communications
- if(ipass == 1) allocate(mask_ispec_inner_outer(nspec))
+ allocate(mask_ispec_inner_outer(nspec))
mask_ispec_inner_outer(:) = .false.
call prepare_assemble_MPI (nspec,ibool, &
knods, ngnod, &
- npoin, elastic, &
+ npoin, elastic,poroelastic, &
ninterface, max_interface_size, &
my_nelmnts_neighbours, my_interfaces, &
- ibool_interfaces_acoustic, ibool_interfaces_elastic, &
- nibool_interfaces_acoustic, nibool_interfaces_elastic, &
- inum_interfaces_acoustic, inum_interfaces_elastic, &
- ninterface_acoustic, ninterface_elastic, &
+ ibool_interfaces_acoustic, ibool_interfaces_elastic, ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic, nibool_interfaces_elastic, nibool_interfaces_poroelastic, &
+ inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic, &
+ ninterface_acoustic, ninterface_elastic, ninterface_poroelastic,&
mask_ispec_inner_outer &
)
nspec_outer = count(mask_ispec_inner_outer)
nspec_inner = nspec - nspec_outer
- if(ipass == 1) allocate(ispec_outer_to_glob(nspec_outer))
- if(ipass == 1) allocate(ispec_inner_to_glob(nspec_inner))
+ allocate(ispec_outer_to_glob(nspec_outer))
+ allocate(ispec_inner_to_glob(nspec_inner))
! building of corresponding arrays between inner/outer elements and their global number
num_ispec_outer = 0
@@ -1278,89 +1624,122 @@
max_ibool_interfaces_size_ac = maxval(nibool_interfaces_acoustic(:))
max_ibool_interfaces_size_el = NDIM*maxval(nibool_interfaces_elastic(:))
- if(ipass == 1) then
- allocate(tab_requests_send_recv_acoustic(ninterface_acoustic*2))
- allocate(buffer_send_faces_vector_ac(max_ibool_interfaces_size_ac,ninterface_acoustic))
- allocate(buffer_recv_faces_vector_ac(max_ibool_interfaces_size_ac,ninterface_acoustic))
- allocate(tab_requests_send_recv_elastic(ninterface_elastic*2))
- allocate(buffer_send_faces_vector_el(max_ibool_interfaces_size_el,ninterface_elastic))
- allocate(buffer_recv_faces_vector_el(max_ibool_interfaces_size_el,ninterface_elastic))
- endif
+ max_ibool_interfaces_size_po = NDIM*maxval(nibool_interfaces_poroelastic(:))
+ allocate(tab_requests_send_recv_acoustic(ninterface_acoustic*2))
+ allocate(buffer_send_faces_vector_ac(max_ibool_interfaces_size_ac,ninterface_acoustic))
+ allocate(buffer_recv_faces_vector_ac(max_ibool_interfaces_size_ac,ninterface_acoustic))
+ allocate(tab_requests_send_recv_elastic(ninterface_elastic*2))
+ allocate(buffer_send_faces_vector_el(max_ibool_interfaces_size_el,ninterface_elastic))
+ allocate(buffer_recv_faces_vector_el(max_ibool_interfaces_size_el,ninterface_elastic))
+ allocate(tab_requests_send_recv_poroelastic(ninterface_poroelastic*2))
+ allocate(buffer_send_faces_vector_pos(max_ibool_interfaces_size_po,ninterface_poroelastic))
+ allocate(buffer_recv_faces_vector_pos(max_ibool_interfaces_size_po,ninterface_poroelastic))
+ allocate(buffer_send_faces_vector_pow(max_ibool_interfaces_size_po,ninterface_poroelastic))
+ allocate(buffer_recv_faces_vector_pow(max_ibool_interfaces_size_po,ninterface_poroelastic))
+
! creating mpi non-blocking persistent communications for acoustic elements
- call create_MPI_req_SEND_RECV_ac(ninterface, ninterface_acoustic, &
- nibool_interfaces_acoustic,my_neighbours, &
+ call create_MPI_req_SEND_RECV_ac( &
+ ninterface, ninterface_acoustic, &
+ nibool_interfaces_acoustic, &
+ my_neighbours, &
max_ibool_interfaces_size_ac, &
- buffer_send_faces_vector_ac,buffer_recv_faces_vector_ac, &
- tab_requests_send_recv_acoustic,inum_interfaces_acoustic)
+ buffer_send_faces_vector_ac, &
+ buffer_recv_faces_vector_ac, &
+ tab_requests_send_recv_acoustic, &
+ inum_interfaces_acoustic &
+ )
! creating mpi non-blocking persistent communications for elastic elements
- call create_MPI_req_SEND_RECV_el(ninterface, ninterface_elastic, &
- nibool_interfaces_elastic,my_neighbours, &
+ call create_MPI_req_SEND_RECV_el( &
+ ninterface, ninterface_elastic, &
+ nibool_interfaces_elastic, &
+ my_neighbours, &
max_ibool_interfaces_size_el, &
- buffer_send_faces_vector_el,buffer_recv_faces_vector_el, &
- tab_requests_send_recv_elastic,inum_interfaces_elastic)
+ buffer_send_faces_vector_el, &
+ buffer_recv_faces_vector_el, &
+ tab_requests_send_recv_elastic, &
+ inum_interfaces_elastic &
+ )
+! creating mpi non-blocking persistent communications for poroelastic elements
+ call create_MPI_req_SEND_RECV_po( &
+ ninterface, ninterface_poroelastic, &
+ nibool_interfaces_poroelastic, &
+ my_neighbours, &
+ max_ibool_interfaces_size_po, &
+ buffer_send_faces_vector_pos, &
+ buffer_recv_faces_vector_pos, &
+ tab_requests_send_recv_poroelastic, &
+ inum_interfaces_poroelastic &
+ )
+
+
! assembling the mass matrix
- call assemble_MPI_scalar(rmass_inverse_acoustic, rmass_inverse_elastic,npoin, &
- ninterface, max_interface_size, max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, &
- ibool_interfaces_acoustic,ibool_interfaces_elastic, nibool_interfaces_acoustic,nibool_interfaces_elastic, my_neighbours)
+ call assemble_MPI_scalar(rmass_inverse_acoustic, rmass_inverse_elastic, rmass_s_inverse_elastic,rmass_w_inverse_elastic,npoin, &
+ ninterface, max_interface_size, max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el,max_ibool_interfaces_size_po, &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic,nibool_interfaces_elastic, nibool_interfaces_poroelastic,my_neighbours)
else
ninterface_acoustic = 0
ninterface_elastic = 0
+ ninterface_poroelastic = 0
num_ispec_outer = 0
num_ispec_inner = 0
- if(ipass == 1) allocate(mask_ispec_inner_outer(1))
+ allocate(mask_ispec_inner_outer(1))
nspec_outer = 0
nspec_inner = nspec
- if(ipass == 1) allocate(ispec_inner_to_glob(nspec_inner))
+ allocate(ispec_inner_to_glob(nspec_inner))
do ispec = 1, nspec
ispec_inner_to_glob(ispec) = ispec
enddo
- endif ! end of test on wether there is more than one process (nproc > 1)
+ end if ! end of test on wether there is more than one process ( nproc>1 )
#else
num_ispec_outer = 0
num_ispec_inner = 0
- if(ipass == 1) allocate(mask_ispec_inner_outer(1))
+ allocate(mask_ispec_inner_outer(1))
nspec_outer = 0
nspec_inner = nspec
- if(ipass == 1) then
- allocate(ispec_outer_to_glob(1))
- allocate(ispec_inner_to_glob(nspec_inner))
- endif
+ allocate(ispec_outer_to_glob(1))
+ allocate(ispec_inner_to_glob(nspec_inner))
do ispec = 1, nspec
ispec_inner_to_glob(ispec) = ispec
enddo
#endif
- enddo ! end of further reduction of cache misses inner/outer in two passes
-
! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
if(any_elastic) where(rmass_inverse_elastic <= 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
+ if(any_poroelastic) where(rmass_s_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_s_inverse_poroelastic = 1._CUSTOM_REAL
+ if(any_poroelastic) where(rmass_w_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_w_inverse_poroelastic = 1._CUSTOM_REAL
if(any_acoustic) where(rmass_inverse_acoustic <= 0._CUSTOM_REAL) rmass_inverse_acoustic = 1._CUSTOM_REAL
! compute the inverse of the mass matrix
if(any_elastic) rmass_inverse_elastic(:) = 1._CUSTOM_REAL / rmass_inverse_elastic(:)
+ if(any_poroelastic) rmass_s_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_s_inverse_poroelastic(:)
+ if(any_poroelastic) rmass_w_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_w_inverse_poroelastic(:)
if(any_acoustic) rmass_inverse_acoustic(:) = 1._CUSTOM_REAL / rmass_inverse_acoustic(:)
-
! check the mesh, stability and number of points per wavelength
- call checkgrid(vpext,vsext,rhoext,density,elastcoef,ibool,kmato,coord,npoin,vpmin,vpmax, &
+ call checkgrid(vpext,vsext,rhoext,density,poroelastcoef,porosity,tortuosity,ibool,kmato,&
+ coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
assign_external_model,nspec,numat,deltat,f0,t0,initialfield,time_function_type, &
- coorg,xinterp,zinterp,shape2D_display,knods,simulation_title,npgeo,pointsdisp,ngnod,any_elastic,myrank,nproc)
+ coorg,xinterp,zinterp,shape2D_display,knods,simulation_title,npgeo,pointsdisp,ngnod,&
+ any_elastic,any_poroelastic,myrank,nproc)
! convert receiver angle to radians
anglerec = anglerec * pi / 180.d0
+
+
!
!---- for color images
!
@@ -1405,8 +1784,12 @@
NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
! check that image size is not too big
- if (NX_IMAGE_color > 99999) call exit_MPI('output image too big : NX_IMAGE_color > 99999.')
- if (NZ_IMAGE_color > 99999) call exit_MPI('output image too big : NZ_IMAGE_color > 99999.')
+ if ( NX_IMAGE_color > 99999 ) then
+ call exit_MPI('output image too big : NX_IMAGE_color > 99999.')
+ end if
+ if ( NZ_IMAGE_color > 99999 ) then
+ call exit_MPI('output image too big : NZ_IMAGE_color > 99999.')
+ end if
! allocate an array for image data
allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color))
@@ -1417,9 +1800,9 @@
allocate(copy_iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
! create all the pixels
- if (myrank == 0) then
- write(IOUT,*)
- write(IOUT,*) 'locating all the pixels of color images'
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'locating all the pixels of color images'
endif
size_pixel_horizontal = (xmax_color_image - xmin_color_image) / dble(NX_IMAGE_color-1)
@@ -1435,7 +1818,7 @@
elmnt_coords(1,k) = coorg(1,knods(k,ispec))
elmnt_coords(2,k) = coorg(2,knods(k,ispec))
- enddo
+ end do
! avoid working on the whole pixel grid
min_i = floor(minval((elmnt_coords(1,:) - xmin_color_image))/size_pixel_horizontal) + 1
@@ -1462,21 +1845,21 @@
dist_min_pixel = dist_pixel
iglob_image_color(i,j) = iglob
- endif
+ end if
- enddo
- enddo
+ end do
+ end do
if ( dist_min_pixel >= HUGEVAL ) then
call exit_MPI('Error in detecting pixel for color image')
- endif
+ end if
nb_pixel_loc = nb_pixel_loc + 1
- endif
+ end if
- enddo
- enddo
- enddo
+ end do
+ end do
+ end do
! creating and filling array num_pixel_loc with the positions of each colored
! pixel owned by the local process (useful for parallel jobs)
@@ -1489,12 +1872,13 @@
nb_pixel_loc = nb_pixel_loc + 1
num_pixel_loc(nb_pixel_loc) = (j-1)*NX_IMAGE_color + i
- endif
+ end if
- enddo
- enddo
+ end do
+ end do
+
! filling array iglob_image_color, containing info on which process owns which pixels.
#ifdef USE_MPI
allocate(nb_pixel_per_proc(nproc))
@@ -1504,11 +1888,11 @@
if ( myrank == 0 ) then
allocate(num_pixel_recv(maxval(nb_pixel_per_proc(:)),nproc))
allocate(data_pixel_recv(maxval(nb_pixel_per_proc(:))))
- endif
+ end if
allocate(data_pixel_send(nb_pixel_loc))
- if (nproc > 1) then
- if (myrank == 0) then
+ if ( nproc > 1 ) then
+ if ( myrank == 0 ) then
do iproc = 1, nproc-1
@@ -1519,15 +1903,15 @@
i = num_pixel_recv(k,iproc+1) - (j-1)*NX_IMAGE_color
iglob_image_color(i,j) = iproc
- enddo
- enddo
+ end do
+ end do
else
call MPI_SEND(num_pixel_loc(1),nb_pixel_loc,MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- endif
+ end if
- endif
+ end if
#else
allocate(nb_pixel_per_proc(1))
deallocate(nb_pixel_per_proc)
@@ -1539,7 +1923,9 @@
deallocate(data_pixel_send)
#endif
- if (myrank == 0) write(IOUT,*) 'done locating all the pixels of color images'
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'done locating all the pixels of color images'
+ endif
endif
@@ -1553,56 +1939,518 @@
sinrot = sin(anglerec)
! initialize arrays to zero
+
+! for the elastic material
displ_elastic = ZERO
veloc_elastic = ZERO
accel_elastic = ZERO
+! for the solid phase
+ displs_poroelastic = ZERO
+ velocs_poroelastic = ZERO
+ accels_poroelastic = ZERO
+
+! for the fluid phase
+ displw_poroelastic = ZERO
+ velocw_poroelastic = ZERO
+ accelw_poroelastic = ZERO
+
+! for the acoustic material
potential_acoustic = ZERO
potential_dot_acoustic = ZERO
potential_dot_dot_acoustic = ZERO
!
-!---- read initial fields from external file if needed
+!----- Files where absorbing signal are saved during forward wavefield calculation
!
-! if we are looking a plane wave beyond critical angle we use other method
- over_critical_angle = .false.
+ if( ((save_forward .and. isolver ==1) .or. isolver == 2) .and. anyabs ) then
+ if(any_elastic) then
+
+!--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ if(isolver == 2) then
+ open(unit=35,file='OUTPUT_FILES/absorb_elastic_left.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=35,file='OUTPUT_FILES/absorb_elastic_left.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ if(isolver == 2) then
+ open(unit=36,file='OUTPUT_FILES/absorb_elastic_right.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=36,file='OUTPUT_FILES/absorb_elastic_right.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ if(isolver == 2) then
+ open(unit=37,file='OUTPUT_FILES/absorb_elastic_bottom.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=37,file='OUTPUT_FILES/absorb_elastic_bottom.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ if(isolver == 2) then
+ open(unit=38,file='OUTPUT_FILES/absorb_elastic_top.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=38,file='OUTPUT_FILES/absorb_elastic_top.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif
+
+ if(any_poroelastic) then
+
+!--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ if(isolver == 2) then
+ open(unit=45,file='OUTPUT_FILES/absorb_poro_s_left.bin',status='old',&
+ form='unformatted')
+ open(unit=25,file='OUTPUT_FILES/absorb_poro_w_left.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=45,file='OUTPUT_FILES/absorb_poro_s_left.bin',status='unknown',&
+ form='unformatted')
+ open(unit=25,file='OUTPUT_FILES/absorb_poro_w_left.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ if(isolver == 2) then
+ open(unit=46,file='OUTPUT_FILES/absorb_poro_s_right.bin',status='old',&
+ form='unformatted')
+ open(unit=26,file='OUTPUT_FILES/absorb_poro_w_right.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=46,file='OUTPUT_FILES/absorb_poro_s_right.bin',status='unknown',&
+ form='unformatted')
+ open(unit=26,file='OUTPUT_FILES/absorb_poro_w_right.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ if(isolver == 2) then
+ open(unit=47,file='OUTPUT_FILES/absorb_poro_s_bottom.bin',status='old',&
+ form='unformatted')
+ open(unit=29,file='OUTPUT_FILES/absorb_poro_w_bottom.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=47,file='OUTPUT_FILES/absorb_poro_s_bottom.bin',status='unknown',&
+ form='unformatted')
+ open(unit=29,file='OUTPUT_FILES/absorb_poro_w_bottom.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ if(isolver == 2) then
+ open(unit=48,file='OUTPUT_FILES/absorb_poro_s_top.bin',status='old',&
+ form='unformatted')
+ open(unit=28,file='OUTPUT_FILES/absorb_poro_w_top.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=48,file='OUTPUT_FILES/absorb_poro_s_top.bin',status='unknown',&
+ form='unformatted')
+ open(unit=28,file='OUTPUT_FILES/absorb_poro_w_top.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif
+
+ if(any_acoustic) then
+
+!--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ print*,'Opening absorb_acoustic_left.bin....'
+ if(isolver == 2) then
+ open(unit=65,file='OUTPUT_FILES/absorb_acoustic_left.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=65,file='OUTPUT_FILES/absorb_acoustic_left.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ print*,'Opening absorb_acoustic_right.bin....'
+ if(isolver == 2) then
+ open(unit=66,file='OUTPUT_FILES/absorb_acoustic_right.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=66,file='OUTPUT_FILES/absorb_acoustic_right.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ print*,'Opening absorb_acoustic_bottom.bin....'
+ if(isolver == 2) then
+ open(unit=67,file='OUTPUT_FILES/absorb_acoustic_bottom.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=67,file='OUTPUT_FILES/absorb_acoustic_bottom.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ print*,'Opening absorb_acoustic_top.bin....'
+ if(isolver == 2) then
+ open(unit=68,file='OUTPUT_FILES/absorb_acoustic_top.bin',status='old',&
+ form='unformatted')
+ else
+ open(unit=68,file='OUTPUT_FILES/absorb_acoustic_top.bin',status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif
+
+ endif !if( ((save_forward .and. isolver ==1) .or. isolver == 2) .and. anyabs )
+
+
+ if(anyabs .and. isolver == 2) then
+
+ if(any_elastic) then
+
+ do it =1, NSTEP
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ read(35) b_absorb_elastic_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ read(36) b_absorb_elastic_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ read(37) b_absorb_elastic_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ read(38) b_absorb_elastic_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+
+ enddo
+
+ endif ! if(any_elastic)
+
+ if(any_poroelastic) then
+
+ do it =1, NSTEP
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ read(45) b_absorb_poro_s_left(id,i,ispec,it)
+ read(25) b_absorb_poro_w_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ read(46) b_absorb_poro_s_right(id,i,ispec,it)
+ read(26) b_absorb_poro_w_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ read(47) b_absorb_poro_s_bottom(id,i,ispec,it)
+ read(29) b_absorb_poro_w_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ read(48) b_absorb_poro_s_top(id,i,ispec,it)
+ read(28) b_absorb_poro_w_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+
+ enddo
+
+ endif ! if(any_poroelastic)
+
+ if(any_acoustic) then
+
+ do it =1, NSTEP
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do i=1,NGLLZ
+ read(65) b_absorb_acoustic_left(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do i=1,NGLLZ
+ read(66) b_absorb_acoustic_right(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do i=1,NGLLX
+ read(67) b_absorb_acoustic_bottom(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do i=1,NGLLX
+ read(68) b_absorb_acoustic_top(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+
+ enddo
+
+ endif ! if(any_acoustic)
+
+
+ endif ! if(anyabs .and. isolver == 2)
+
+
+
+!
+!----- Read last frame for backward wavefield calculation
+!
+
+ if(isolver == 2) then
+
+ if(any_elastic) then
+ open(unit=55,file='OUTPUT_FILES/lastframe_elastic.bin',status='old',action='read',form='unformatted')
+ do j=1,npoin
+ read(55) (b_displ_elastic(i,j), i=1,NDIM), &
+ (b_veloc_elastic(i,j), i=1,NDIM), &
+ (b_accel_elastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+
+ rho_kl(:) = ZERO
+ mu_kl(:) = ZERO
+ kappa_kl(:) = ZERO
+ endif
+
+ if(any_poroelastic) then
+ open(unit=55,file='OUTPUT_FILES/lastframe_poroelastic_s.bin',status='old',action='read',form='unformatted')
+ open(unit=56,file='OUTPUT_FILES/lastframe_poroelastic_w.bin',status='old',action='read',form='unformatted')
+ do j=1,npoin
+ read(55) (b_displs_poroelastic(i,j), i=1,NDIM), &
+ (b_velocs_poroelastic(i,j), i=1,NDIM), &
+ (b_accels_poroelastic(i,j), i=1,NDIM)
+ read(56) (b_displw_poroelastic(i,j), i=1,NDIM), &
+ (b_velocw_poroelastic(i,j), i=1,NDIM), &
+ (b_accelw_poroelastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+ close(56)
+ rhot_kl(:) = ZERO
+ rhof_kl(:) = ZERO
+ eta_kl(:) = ZERO
+ sm_kl(:) = ZERO
+ mufr_kl(:) = ZERO
+ B_kl(:) = ZERO
+ C_kl(:) = ZERO
+ M_kl(:) = ZERO
+ endif
+
+ if(any_acoustic) then
+ open(unit=55,file='OUTPUT_FILES/lastframe_acoustic.bin',status='old',action='read',form='unformatted')
+ do j=1,npoin
+ read(55) b_potential_acoustic(j),&
+ b_potential_dot_acoustic(j),&
+ b_potential_dot_dot_acoustic(j)
+ enddo
+ close(55)
+
+ endif
+
+ endif ! if(isover == 2)
+
+!
+!---- read initial fields from external file if needed
+!
if(initialfield) then
write(IOUT,*)
write(IOUT,*) 'Reading initial fields from external file...'
write(IOUT,*)
if(any_acoustic) call exit_MPI('initial field currently implemented for purely elastic simulation only')
+ if(.not. add_Bielak_conditions) then
+
+ open(unit=55,file='OUTPUT_FILES/wavefields.txt',status='unknown')
+ read(55,*) nbpoin
+ if(nbpoin /= npoin) call exit_MPI('Wrong number of points in input file')
+ allocate(displread(NDIM))
+ allocate(velocread(NDIM))
+ allocate(accelread(NDIM))
+ do n = 1,npoin
+ read(55,*) inump, (displread(i), i=1,NDIM), (velocread(i), i=1,NDIM), (accelread(i), i=1,NDIM)
+ if(inump<1 .or. inump>npoin) call exit_MPI('Wrong point number')
+ displ_elastic(:,inump) = displread
+ veloc_elastic(:,inump) = velocread
+ accel_elastic(:,inump) = accelread
+ enddo
+ deallocate(displread)
+ deallocate(velocread)
+ deallocate(accelread)
+ close(55)
+
+ else
+
+!!$! compute analytical initial plane wave field
+!!$! the analytical expression below is specific to an SV wave at 30 degrees and Poisson = 0.3333
+!!$ print *,'computing analytical initial plane wave field for SV wave at 30 degrees and Poisson = 0.3333'
+!!$
+!!$ do i = 1,npoin
+!!$
+!!$ x = coord(1,i)
+!!$ z = coord(2,i)
+!!$
+!!$! add a time offset in order for the initial field to be inside the medium
+!!$ t = 0.d0 + time_offset
+!!$
+!!$! initial analytical displacement
+!!$ displ_elastic(1,i) = (sqrt(3.d0)/2.d0) * ricker_Bielak_displ(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + (sqrt(3.d0)/2.d0) * ricker_Bielak_displ(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + sqrt(3.d0) * ricker_Bielak_displ(t - x/2.d0)
+!!$ displ_elastic(2,i) = - HALF * ricker_Bielak_displ(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + HALF * ricker_Bielak_displ(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0))
+!!$
+!!$! initial analytical velocity
+!!$ veloc_elastic(1,i) = (sqrt(3.d0)/2.d0) * ricker_Bielak_veloc(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + (sqrt(3.d0)/2.d0) * ricker_Bielak_veloc(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + sqrt(3.d0) * ricker_Bielak_veloc(t - x/2.d0)
+!!$ veloc_elastic(2,i) = - HALF * ricker_Bielak_veloc(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + HALF * ricker_Bielak_veloc(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0))
+!!$
+!!$! initial analytical acceleration
+!!$ accel_elastic(1,i) = (sqrt(3.d0)/2.d0) * ricker_Bielak_accel(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + (sqrt(3.d0)/2.d0) * ricker_Bielak_accel(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + sqrt(3.d0) * ricker_Bielak_accel(t - x/2.d0)
+!!$ accel_elastic(2,i) = - HALF * ricker_Bielak_accel(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + HALF * ricker_Bielak_accel(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0))
+!!$
+!!$ enddo
+
!=======================================================================
!
! Calculation of the initialfield for plane wave
!
!=======================================================================
- print *,'Number of grid points: ',npoin,'\n'
+ print *,'Number of grid points: ',npoin
print *,'*** calculation of initial plane wave ***'
if (source_type == 1) then
print *,'initial P wave of', angleforce*180.d0/pi, 'degrees introduced...'
else if (source_type == 2) then
print *,'initial SV wave of', angleforce*180.d0/pi, ' degrees introduced...'
-
- else if (source_type == 3) then
- print *,'Rayleigh wave introduced...'
else
call exit_MPI('Unrecognized source_type: should be 1 for plane P waves, 2 for plane SV waves!')
endif
- if ((angleforce<0.0d0.or.angleforce>=pi/2.d0).and.source_type/=3) then
- call exit_MPI("incorrect angleforce: must have 0<=angleforce<90")
- endif
-
! only implemented for homogeneous media therefore only 1 material supported
if (numat==1) then
- mu = elastcoef(2,numat)
- lambdaplus2mu = elastcoef(3,numat)
- denst = density(numat)
+ mu = poroelastcoef(2,1,numat)
+ lambdaplus2mu = poroelastcoef(3,1,numat)
+ denst = density(1,numat)
cploc = sqrt(lambdaplus2mu/denst)
csloc = sqrt(mu/denst)
@@ -1614,7 +2462,7 @@
c_inc = cploc
c_refl = csloc
- angleforce_refl = asin(p*c_refl)
+ angleforce_refl = asin(p*csloc)
! from formulas (5.26) and (5.27) p 140 in Aki & Richards (1980)
PP = (- cos(2.d0*angleforce_refl)**2/csloc**3 + 4.d0*p**2*cos(angleforce)*cos(angleforce_refl)/cploc) / &
@@ -1633,35 +2481,27 @@
C_plane(1) = PS * cos(angleforce_refl); C_plane(2) = PS * sin(angleforce_refl)
! SV wave case
- else if (source_type == 2) then
+ else
p=sin(angleforce)/csloc
c_inc = csloc
c_refl = cploc
! if this coefficient is greater than 1, we are beyond the critical SV wave angle and there cannot be a converted P wave
- if (p*c_refl<=1.d0) then
- angleforce_refl = asin(p*c_refl)
+ if (p*cploc<=1.d0) then
+ angleforce_refl = asin(p*cploc)
! from formulas (5.30) and (5.31) p 140 in Aki & Richards (1980)
- SS = (cos(2.d0*angleforce)**2/csloc**3 - 4.d0*p**2*cos(angleforce)*cos(angleforce_refl)/cploc) / &
- (cos(2.d0*angleforce)**2/csloc**3 + 4.d0*p**2*cos(angleforce)*cos(angleforce_refl)/cploc)
+ SS = (cos(2.d0*angleforce_refl)**2/csloc**3 - 4.d0*p**2*cos(angleforce)*cos(angleforce_refl)/cploc) / &
+ (cos(2.d0*angleforce_refl)**2/csloc**3 + 4.d0*p**2*cos(angleforce)*cos(angleforce_refl)/cploc)
SP = 4.d0*p*cos(angleforce)*cos(2*angleforce) / &
(cploc*csloc*(cos(2.d0*angleforce)**2/csloc**3&
+4.d0*p**2*cos(angleforce_refl)*cos(angleforce)/cploc))
print *,'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi, '\n'
- ! SV45 degree incident plane wave is a particular case
- else if (angleforce>pi/4.d0-1.0d-11 .and. angleforce<pi/4.d0+1.0d-11) then
- angleforce_refl = 0.d0
- SS = -1.0d0
- SP = 0.d0
else
- over_critical_angle=.true.
- angleforce_refl = 0.d0
- SS = 0.0d0
- SP = 0.d0
+ call exit_MPI('cannot be included for now: SV angle too high, beyond critical angle')
endif
! from Table 5.1 p141 in Aki & Richards (1980)
@@ -1670,15 +2510,10 @@
B_plane(1) = SS * cos(angleforce); B_plane(2) = SS * sin(angleforce)
C_plane(1) = SP * sin(angleforce_refl); C_plane(2) = - SP * cos(angleforce_refl)
- ! Rayleigh case
- else if (source_type == 3) then
- over_critical_angle=.true.
- A_plane(1)=0.d0; A_plane(2)=0.d0
- B_plane(1)=0.d0; B_plane(2)=0.d0
- C_plane(1)=0.d0; C_plane(2)=0.d0
endif
+
else
- call exit_MPI('not possible to have several materials with a plane wave')
+ call exit_MPI('not possible for now to have several materials with a plane wave (but could be done one day)')
endif
! get minimum and maximum values of mesh coordinates
@@ -1687,142 +2522,55 @@
xmax = maxval(coord(1,:))
zmax = maxval(coord(2,:))
- ! initialize the time offset to put the plane wave not too close to the irregularity on the free surface
- if (abs(angleforce)<1.d0*pi/180.d0 .and. source_type/=3) then
- time_offset=-1.d0*zmax/2.d0/c_inc
+ ! initialize the time offset to put the plane wave not too close to the free surface topography
+ if (abs(angleforce)<20.d0*pi/180.d0) then
+ time_offset=-1.d0*zmax/3.d0/c_inc
else
time_offset=0.d0
endif
! to correctly center the initial plane wave in the mesh
z0_source=zmax
+ x0_source=xmin + 1.d0*(xmax-xmin)/3.d0
- if (abs(angleforce)<20.d0*pi/180.d0) then
- x0_source=xmin
- else
- x0_source=xmin + 1.d0*(xmax-xmin)/4.d0
- endif
+ do i = 1,npoin
- if (.not. over_critical_angle) then
+ x = coord(1,i)
+ z = coord(2,i)
- do i = 1,npoin
+ ! z is from bottom to top therefore we take -z to make parallel with Aki & Richards
+ z = z0_source - z
+ x = x - x0_source
- x = coord(1,i)
- z = coord(2,i)
+ t = 0.d0 + time_offset
- ! z is from bottom to top therefore we take -z to make parallel with Aki & Richards
- z = z0_source - z
- x = x - x0_source
+ ! formulas for the initial displacement for a plane wave from Aki & Richards (1980)
+ displ_elastic(1,i) = A_plane(1) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
+ + B_plane(1) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
+ + C_plane(1) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ displ_elastic(2,i) = A_plane(2) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
+ + B_plane(2) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
+ + C_plane(2) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- t = 0.d0 + time_offset
+ ! formulas for the initial velocity for a plane wave (first derivative in time of the displacement)
+ veloc_elastic(1,i) = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
+ + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
+ + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ veloc_elastic(2,i) = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
+ + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
+ + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- ! formulas for the initial displacement for a plane wave from Aki & Richards (1980)
- displ_elastic(1,i) = A_plane(1) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(1) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- displ_elastic(2,i) = A_plane(2) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(2) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ ! formulas for the initial acceleration for a plane wave (second derivative in time of the displacement)
+ accel_elastic(1,i) = A_plane(1) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
+ + B_plane(1) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
+ + C_plane(1) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ accel_elastic(2,i) = A_plane(2) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
+ + B_plane(2) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
+ + C_plane(2) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- ! formulas for the initial velocity for a plane wave (first derivative in time of the displacement)
- veloc_elastic(1,i) = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- veloc_elastic(2,i) = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ enddo
+ endif ! add_Bielak
- ! formulas for the initial acceleration for a plane wave (second derivative in time of the displacement)
- accel_elastic(1,i) = A_plane(1) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(1) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- accel_elastic(2,i) = A_plane(2) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(2) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
-
- enddo
-
- else ! beyond critical angle
-
- if (source_type/=3) print *, '\n You are beyond critical angle ( > ',asin(c_inc/c_refl)*180d0/pi,')'
-
- print *, '\n *************'
- print *, 'We have to compute the initial field in the frequency domain'
- print *, 'and then convert it to the time domain (can be long... be patient...)'
- print *, '*************\n'
-
- allocate(left_bound(nelemabs*NGLLX))
- allocate(right_bound(nelemabs*NGLLX))
- allocate(bot_bound(nelemabs*NGLLZ))
-
- count_bot=0
- count_left=0
- count_right=0
- do ispecabs=1,nelemabs
- ispec=numabs(ispecabs)
- if(codeabs(ILEFT,ispecabs)) then
- i = 1
- do j = 1,NGLLZ
- count_left=count_left+1
- iglob = ibool(i,j,ispec)
- left_bound(count_left)=iglob
- enddo
- endif
- if(codeabs(IRIGHT,ispecabs)) then
- i = NGLLX
- do j = 1,NGLLZ
- count_right=count_right+1
- iglob = ibool(i,j,ispec)
- right_bound(count_right)=iglob
- enddo
- endif
- if(codeabs(IBOTTOM,ispecabs)) then
- j = 1
- ! exclude corners to make sure there is no contradiction regarding the normal
- ibegin = 1
- iend = NGLLX
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
- do i = ibegin,iend
- count_bot=count_bot+1
- iglob = ibool(i,j,ispec)
- bot_bound(count_bot)=iglob
- enddo
- endif
- enddo
-
- allocate(v0x_left(count_left,NSTEP))
- allocate(v0z_left(count_left,NSTEP))
- allocate(t0x_left(count_left,NSTEP))
- allocate(t0z_left(count_left,NSTEP))
-
- allocate(v0x_right(count_right,NSTEP))
- allocate(v0z_right(count_right,NSTEP))
- allocate(t0x_right(count_right,NSTEP))
- allocate(t0z_right(count_right,NSTEP))
-
- allocate(v0x_bot(count_bot,NSTEP))
- allocate(v0z_bot(count_bot,NSTEP))
- allocate(t0x_bot(count_bot,NSTEP))
- allocate(t0z_bot(count_bot,NSTEP))
-
-! call Paco's routine to compute in frequency and convert to time by Fourier transform
- call paco_beyond_critical(coord,npoin,deltat,NSTEP,angleforce,&
- f0,cploc,csloc,TURN_ATTENUATION_ON,Qp_attenuation,source_type,v0x_left,v0z_left,&
- v0x_right,v0z_right,v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,&
- t0x_bot,t0z_bot,left_bound(1:count_left),right_bound(1:count_right),bot_bound(1:count_bot)&
- ,count_left,count_right,count_bot,displ_elastic,veloc_elastic,accel_elastic)
-
- deallocate(left_bound)
- deallocate(right_bound)
- deallocate(bot_bound)
-
- print *, '\n ***********'
- print *, 'initial field calculated, starting propagation'
- print *, '***********\n\n'
-
- endif ! beyond critical angle
-
write(IOUT,*) 'Max norm of initial elastic displacement = ',maxval(sqrt(displ_elastic(1,:)**2 + displ_elastic(2,:)**2))
endif ! initialfield
@@ -1838,11 +2586,11 @@
allocate(source_time_function(NSTEP))
- if (myrank == 0) then
- write(IOUT,*)
- write(IOUT,*) 'Saving the source time function in a text file...'
- write(IOUT,*)
- open(unit=55,file='OUTPUT_FILES/source.txt',status='unknown')
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving the source time function in a text file...'
+ write(IOUT,*)
+ open(unit=55,file='OUTPUT_FILES/source.txt',status='unknown')
endif
! loop on all the time steps
@@ -1853,7 +2601,8 @@
! Ricker (second derivative of a Gaussian) source time function
if(time_function_type == 1) then
- source_time_function(it) = - factor * (ONE-TWO*aval*(time-t0)**2) * exp(-aval*(time-t0)**2)
+! source_time_function(it) = - factor * (ONE-TWO*aval*(time-t0)**2) * exp(-aval*(time-t0)**2)
+ source_time_function(it) = - factor * TWO*aval*sqrt(aval)*(time-t0)/pi * exp(-aval*(time-t0)**2)
! first derivative of a Gaussian source time function
else if(time_function_type == 2) then
@@ -1874,10 +2623,14 @@
endif
! output absolute time in third column, in case user wants to check it as well
- if (myrank == 0) write(55,*) sngl(time),real(source_time_function(it),4),sngl(time-t0)
+ if ( myrank == 0 ) then
+ write(55,*) sngl(time),real(source_time_function(it),4),sngl(time-t0)
+ endif
enddo
- if (myrank == 0) close(55)
+ if ( myrank == 0 ) then
+ close(55)
+ endif
! nb_proc_source is the number of processes that own the source (the nearest point). It can be greater
! than one if the nearest point is on the interface between several partitions with an explosive source.
@@ -1892,19 +2645,19 @@
endif
-! determine if coupled fluid-solid simulation
+! determine if coupled fluid-solid (elastic or poroelastic) simulation
coupled_acoustic_elastic = any_acoustic .and. any_elastic
+ coupled_acoustic_poroelastic = any_acoustic .and. any_poroelastic
-! fluid/solid edge detection
+! fluid/solid (elastic) edge detection
! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
! the common nodes forming the edge are computed here
if(coupled_acoustic_elastic) then
-
- if (myrank == 0) then
- print *
- print *,'Mixed acoustic/elastic simulation'
- print *
- print *,'Beginning of fluid/solid edge detection'
+ if ( myrank == 0 ) then
+ print *
+ print *,'Mixed acoustic/elastic simulation'
+ print *
+ print *,'Beginning of fluid/solid edge detection'
endif
! define the edges of a given element
@@ -1953,12 +2706,14 @@
enddo
+
do inum = 1, num_fluid_solid_edges
ispec_acoustic = fluid_solid_acoustic_ispec(inum)
ispec_elastic = fluid_solid_elastic_ispec(inum)
! one element must be acoustic and the other must be elastic
- if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
+ if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. &
+ .not. poroelastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
! loop on the four edges of the two elements
do iedge_acoustic = 1,NEDGES
@@ -1983,11 +2738,13 @@
enddo
-! make sure fluid/solid matching has been perfectly detected: check that the grid points
+! make sure fluid/solid (elastic) matching has been perfectly detected: check that the grid points
! have the same physical coordinates
! loop on all the coupling edges
- if(myrank == 0) print *,'Checking fluid/solid edge topology...'
+ if ( myrank == 0 ) then
+ print *,'Checking fluid/solid (elastic) edge topology...'
+ endif
do inum = 1,num_fluid_solid_edges
@@ -2020,24 +2777,206 @@
enddo
- if (myrank == 0) then
- print *,'End of fluid/solid edge detection'
- print *
+ if ( myrank == 0 ) then
+ print *,'End of fluid/solid (elastic) edge detection'
+ print *
endif
+ else
+
+
+
endif
-! exclude common points between acoustic absorbing edges and acoustic/elastic matching interfaces
+! fluid/solid (poroelastic) edge detection
+! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
+! the common nodes forming the edge are computed here
+ if(coupled_acoustic_poroelastic) then
+ if ( myrank == 0 ) then
+ print *
+ print *,'Mixed acoustic/poroelastic simulation'
+ print *
+ print *,'Beginning of fluid/solid (poroelastic) edge detection'
+ endif
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+
+ do inum = 1, num_fluid_poro_edges
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+
+! one element must be acoustic and the other must be poroelastic
+ if(ispec_acoustic /= ispec_poroelastic .and. .not. poroelastic(ispec_acoustic) .and. &
+ .not. elastic(ispec_acoustic) .and. poroelastic(ispec_poroelastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_acoustic = 1,NEDGES
+ do iedge_poroelastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic)) then
+ fluid_poro_acoustic_iedge(inum) = iedge_acoustic
+ fluid_poro_poroelastic_iedge(inum) = iedge_poroelastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+
+! make sure fluid/solid (poroelastic) matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
+
+ if ( myrank == 0 ) then
+ print *,'Checking fluid/solid (poroelastic) edge topology...'
+ endif
+
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob2 = ibool(i,j,ispec_acoustic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ call exit_MPI( 'error in fluid/solid (poroelastic) coupling buffer')
+
+ enddo
+
+ enddo
+
+ if ( myrank == 0 ) then
+ print *,'End of fluid/solid (poroelastic) edge detection'
+ print *
+ endif
+
+ else
+
+
+
+ endif
+
+! default values for acoustic absorbing edges
+ ibegin_bottom(:) = 1
+ ibegin_top(:) = 1
+
+ iend_bottom(:) = NGLLX
+ iend_top(:) = NGLLX
+
+ jbegin_left(:) = 1
+ jbegin_right(:) = 1
+
+ jend_left(:) = NGLLZ
+ jend_right(:) = NGLLZ
+
+! exclude common points between acoustic absorbing edges and acoustic/(poro)elastic matching interfaces
if(coupled_acoustic_elastic .and. anyabs) then
- if (myrank == 0) &
- print *,'excluding common points between acoustic absorbing edges and acoustic/elastic matching interfaces, if any'
+ if ( myrank == 0 ) then
+ print *,'excluding common points between acoustic absorbing edges and acoustic/elastic matching interfaces, if any'
+ endif
-! loop on all the absorbing elements
- do ispecabs = 1,nelemabs
+!--- left and right absorbing boundary
+ do ispecabs = 1,nspec_xmin
- ispec = numabs(ispecabs)
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
+
+! if acoustic absorbing element and acoustic/elastic coupled element is the same
+ if(ispec_acoustic == ib_xmin(ispecabs) .or. ispec_acoustic == ib_xmax(ispecabs)) then
+
+ if(iedge_acoustic == IBOTTOM) then
+ jbegin_left(ispecabs) = 2
+ jbegin_right(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == ITOP) then
+ jend_left(ispecabs) = NGLLZ - 1
+ jend_right(ispecabs) = NGLLZ - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+!--- top and bottom absorbing boundary
+ do ispecabs = 1,nspec_zmin
+
! loop on all the coupling edges
do inum = 1,num_fluid_solid_edges
@@ -2046,8 +2985,46 @@
iedge_acoustic = fluid_solid_acoustic_iedge(inum)
! if acoustic absorbing element and acoustic/elastic coupled element is the same
- if(ispec_acoustic == ispec) then
+ if(ispec_acoustic == ib_zmin(ispecabs) .or. ispec_acoustic == ib_zmax(ispecabs)) then
+ if(iedge_acoustic == ILEFT) then
+ ibegin_bottom(ispecabs) = 2
+ ibegin_top(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == IRIGHT) then
+ iend_bottom(ispecabs) = NGLLX - 1
+ iend_top(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+
+ endif
+
+ if(coupled_acoustic_poroelastic .and. anyabs) then
+
+ if ( myrank == 0 ) then
+ print *,'excluding common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces, if any'
+ endif
+
+!--- left and right absorbing boundary
+ do ispecabs = 1, nspec_xmin
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! if acoustic absorbing element and acoustic/poroelastic coupled element is the same
+ if(ispec_acoustic == ib_xmin(ispecabs) .or. ispec_acoustic == ib_xmax(ispecabs)) then
+
if(iedge_acoustic == IBOTTOM) then
jbegin_left(ispecabs) = 2
jbegin_right(ispecabs) = 2
@@ -2058,6 +3035,25 @@
jend_right(ispecabs) = NGLLZ - 1
endif
+ endif
+
+ enddo
+
+ enddo
+
+!--- top and bottom absorbing boundary
+ do ispecabs = 1, nspec_zmin
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! if acoustic absorbing element and acoustic/poroelastic coupled element is the same
+ if(ispec_acoustic == ib_zmin(ispecabs) .or. ispec_acoustic == ib_zmax(ispecabs)) then
+
if(iedge_acoustic == ILEFT) then
ibegin_bottom(ispecabs) = 2
ibegin_top(ispecabs) = 2
@@ -2074,8 +3070,228 @@
enddo
+
endif
+! determine if coupled elastic-poroelastic simulation
+ coupled_elastic_poroelastic = any_elastic .and. any_poroelastic
+
+! solid/porous edge detection
+! the two elements forming an edge are already known (computed in meshfem2D),
+! the common nodes forming the edge are computed here
+ if(coupled_elastic_poroelastic) then
+ if ( myrank == 0 ) then
+ print *
+ print *,'Mixed elastic/poroelastic simulation'
+ print *
+ print *,'Beginning of solid/porous edge detection'
+ endif
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+
+ do inum = 1, num_solid_poro_edges
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+
+! one element must be elastic and the other must be poroelastic
+ if(ispec_elastic /= ispec_poroelastic .and. elastic(ispec_elastic) .and. &
+ poroelastic(ispec_poroelastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_elastic = 1,NEDGES
+ do iedge_poroelastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic) == &
+ ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) .and. &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) == &
+ ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic)) then
+ solid_poro_elastic_iedge(inum) = iedge_elastic
+ solid_poro_poroelastic_iedge(inum) = iedge_poroelastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+
+! make sure solid/porous matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
+
+ if ( myrank == 0 ) then
+ print *,'Checking solid/porous edge topology...'
+ endif
+
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get point values for the elastic side
+ i = ivalue(ipoin1D,iedge_elastic)
+ j = jvalue(ipoin1D,iedge_elastic)
+ iglob2 = ibool(i,j,ispec_elastic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ call exit_MPI( 'error in solid/porous coupling buffer')
+
+ enddo
+
+ enddo
+
+ if ( myrank == 0 ) then
+ print *,'End of solid/porous edge detection'
+ print *
+ endif
+
+ else
+
+
+
+ endif
+
+! default values for poroelastic absorbing edges
+ ibegin_bottom_poro(:) = 1
+ ibegin_top_poro(:) = 1
+
+ iend_bottom_poro(:) = NGLLX
+ iend_top_poro(:) = NGLLX
+
+ jbegin_left_poro(:) = 1
+ jbegin_right_poro(:) = 1
+
+ jend_left_poro(:) = NGLLZ
+ jend_right_poro(:) = NGLLZ
+
+! exclude common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces
+ if(coupled_elastic_poroelastic .and. anyabs) then
+
+ print *,'excluding common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces, if any'
+
+! loop on all the absorbing elements
+
+!--- left and right absorbing boundary
+ do ispecabs = 1, nspec_xmin
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! if poroelastic absorbing element and elastic/porelastic coupled element is the same
+ if(ispec_poroelastic == ib_xmin(ispecabs) .or. ispec_poroelastic == ib_xmax(ispecabs)) then
+
+ if(iedge_poroelastic == IBOTTOM) then
+ jbegin_left_poro(ispecabs) = 2
+ jbegin_right_poro(ispecabs) = 2
+ endif
+
+ if(iedge_poroelastic == ITOP) then
+ jend_left_poro(ispecabs) = NGLLZ - 1
+ jend_right_poro(ispecabs) = NGLLZ - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+!--- top and bottom absorbing boundary
+ do ispecabs = 1, nspec_zmin
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! if poroelastic absorbing element and elastic/porelastic coupled element is the same
+ if(ispec_poroelastic == ib_zmin(ispecabs) .or. ispec_poroelastic == ib_zmax(ispecabs)) then
+
+ if(iedge_poroelastic == ILEFT) then
+ ibegin_bottom_poro(ispecabs) = 2
+ ibegin_top_poro(ispecabs) = 2
+ endif
+
+ if(iedge_poroelastic == IRIGHT) then
+ iend_bottom_poro(ispecabs) = NGLLX - 1
+ iend_top_poro(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+ endif !(coupled_elastic_poroelastic .and. anyabs)
+
+
#ifdef USE_MPI
if(OUTPUT_ENERGY) stop 'energy calculation only serial right now, should add an MPI_REDUCE in parallel'
#endif
@@ -2085,7 +3301,9 @@
!
!---- s t a r t t i m e i t e r a t i o n s
!
- if (myrank == 0) write(IOUT,400)
+ if ( myrank == 0 ) then
+ write(IOUT,400)
+ endif
! count elapsed wall-clock time
call date_and_time(datein,timein,zone,time_values)
@@ -2098,21 +3316,57 @@
time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
- if(output_color_image) then
+ if(output_color_image .or. isolver == 2) then
! to display the P-velocity model in background on color images
+! notice that it is cp (for acoustic or elastic media) or cpI
+! (for poroelastic media)
allocate(vp_display(npoin))
do ispec = 1,nspec
-! get relaxed elastic parameters of current spectral element
- rhol = density(kmato(ispec))
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
+!get parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ B_biot = H_biot - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+! Approximated velocities (no viscous dissipation)
+ afactor = rhol_bar - phil/tortl*rhol_f
+ bfactor = H_biot + phil*rhol_bar/(tortl*rhol_f)*M_biot - TWO*phil/tortl*C_biot
+ cfactor = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4._CUSTOM_REAL*afactor*cfactor))/(2._CUSTOM_REAL*afactor)
+ cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4._CUSTOM_REAL*afactor*cfactor))/(2._CUSTOM_REAL*afactor)
+
+! Approximated ratio r = amplitude "w" field/amplitude "s" field (no viscous dissipation)
+! used later for kernels calculation
+ gamma1 = H_biot - phil/tortl*C_biot
+ gamma2 = C_biot - phil/tortl*M_biot
+ gamma3 = phil/tortl*( M_biot*(afactor/rhol_f + phil/tortl) - C_biot)
+ gamma4 = phil/tortl*( C_biot*(afactor/rhol_f + phil/tortl) - H_biot)
+ ratio = HALF*(gamma1 - gamma3)/gamma4 + HALF*sqrt((gamma1-gamma3)**2/gamma4**2 + 4._CUSTOM_REAL * gamma2/gamma4)
+
do j = 1,NGLLZ
do i = 1,NGLLX
!--- if external medium, get elastic parameters of current grid point
if(assign_external_model) then
vp_display(ibool(i,j,ispec)) = vpext(i,j,ispec)
- else
- vp_display(ibool(i,j,ispec)) = sqrt((lambdal_relaxed + 2.d0*mul_relaxed) / rhol)
+ elseif(phil >= 1.d0) then ! acoustic
+ cpsquare = kappal_f/rhol_f
+ vp_display(ibool(i,j,ispec)) = sqrt(cpsquare)
+ else ! elastic or poroelastic
+ vp_display(ibool(i,j,ispec)) = sqrt(cpIsquare)
endif
enddo
enddo
@@ -2125,12 +3379,13 @@
j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
image_color_vp_display(i,j) = vp_display(iglob_image_color(i,j))
+
enddo
! assembling array image_color_vp_display on process zero for color output
#ifdef USE_MPI
- if (nproc > 1) then
- if (myrank == 0) then
+ if ( nproc > 1 ) then
+ if ( myrank == 0 ) then
do iproc = 1, nproc-1
call MPI_RECV(data_pixel_recv(1),nb_pixel_per_proc(iproc+1), MPI_DOUBLE_PRECISION, &
iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
@@ -2139,6 +3394,7 @@
j = ceiling(real(num_pixel_recv(k,iproc+1)) / real(NX_IMAGE_color))
i = num_pixel_recv(k,iproc+1) - (j-1)*NX_IMAGE_color
image_color_vp_display(i,j) = data_pixel_recv(k)
+
enddo
enddo
@@ -2147,6 +3403,7 @@
j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
data_pixel_send(k) = vp_display(iglob_image_color(i,j))
+
enddo
call MPI_SEND(data_pixel_send(1),nb_pixel_loc,MPI_DOUBLE_PRECISION, 0, 43, MPI_COMM_WORLD, ier)
@@ -2157,29 +3414,11 @@
#endif
endif
-! dummy allocation of plane wave arrays if they are unused (but still need to exist because
-! they are used as arguments to subroutines)
- if(.not. over_critical_angle) then
- allocate(v0x_left(1,NSTEP))
- allocate(v0z_left(1,NSTEP))
- allocate(t0x_left(1,NSTEP))
- allocate(t0z_left(1,NSTEP))
-
- allocate(v0x_right(1,NSTEP))
- allocate(v0z_right(1,NSTEP))
- allocate(t0x_right(1,NSTEP))
- allocate(t0z_right(1,NSTEP))
-
- allocate(v0x_bot(1,NSTEP))
- allocate(v0z_bot(1,NSTEP))
- allocate(t0x_bot(1,NSTEP))
- allocate(t0z_bot(1,NSTEP))
- endif
-
! initialize variables for writing seismograms
seismo_offset = 0
seismo_current = 0
+
! *********************************************************
! ************* MAIN LOOP OVER THE TIME STEPS *************
! *********************************************************
@@ -2197,18 +3436,51 @@
displ_elastic = displ_elastic + deltat*veloc_elastic + deltatsquareover2*accel_elastic
veloc_elastic = veloc_elastic + deltatover2*accel_elastic
accel_elastic = ZERO
+ if(isolver == 2) then
+ b_displ_elastic = b_displ_elastic + b_deltat*b_veloc_elastic + b_deltatsquareover2*b_accel_elastic
+ b_veloc_elastic = b_veloc_elastic + b_deltatover2*b_accel_elastic
+ b_accel_elastic = ZERO
+ endif
endif
+ if(any_poroelastic) then
+!for the solid
+ displs_poroelastic = displs_poroelastic + deltat*velocs_poroelastic + deltatsquareover2*accels_poroelastic
+ velocs_poroelastic = velocs_poroelastic + deltatover2*accels_poroelastic
+ accels_poroelastic = ZERO
+!for the fluid
+ displw_poroelastic = displw_poroelastic + deltat*velocw_poroelastic + deltatsquareover2*accelw_poroelastic
+ velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
+ accelw_poroelastic = ZERO
+ if(isolver == 2) then
+!for the solid
+ b_displs_poroelastic = b_displs_poroelastic + b_deltat*b_velocs_poroelastic + b_deltatsquareover2*b_accels_poroelastic
+ b_velocs_poroelastic = b_velocs_poroelastic + b_deltatover2*b_accels_poroelastic
+ b_accels_poroelastic = ZERO
+!for the fluid
+ b_displw_poroelastic = b_displw_poroelastic + b_deltat*b_velocw_poroelastic + b_deltatsquareover2*b_accelw_poroelastic
+ b_velocw_poroelastic = b_velocw_poroelastic + b_deltatover2*b_accelw_poroelastic
+ b_accelw_poroelastic = ZERO
+ endif
+ endif
+
if(any_acoustic) then
potential_acoustic = potential_acoustic + deltat*potential_dot_acoustic + deltatsquareover2*potential_dot_dot_acoustic
potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
potential_dot_dot_acoustic = ZERO
+ if(isolver == 2) then
+ b_potential_acoustic = b_potential_acoustic + b_deltat*b_potential_dot_acoustic + &
+ b_deltatsquareover2*b_potential_dot_dot_acoustic
+ b_potential_dot_acoustic = b_potential_dot_acoustic + b_deltatover2*b_potential_dot_dot_acoustic
+ b_potential_dot_dot_acoustic = ZERO
+ endif
! free surface for an acoustic medium
if ( nelem_acoustic_surface > 0 ) then
- call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,acoustic_surface,ibool,nelem_acoustic_surface,npoin,nspec)
+ call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
endif
! *********************************************************
@@ -2216,16 +3488,63 @@
! *********************************************************
! first call, computation on outer elements, absorbing conditions and source
- call compute_forces_acoustic(npoin,nspec,nelemabs,numat, &
- anyabs,assign_external_model,ibool,kmato,numabs, &
- elastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
- vpext,rhoext,hprime_xx,hprimewgll_xx, &
+ call compute_forces_acoustic(npoin,nspec,myrank,numat, &
+ iglob_source,ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ assign_external_model,initialfield,ibool,kmato, &
+ elastic,poroelastic,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,b_potential_dot_dot_acoustic,b_potential_acoustic,&
+ density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,source_time_function,adj_sourcearrays,hprime_xx,hprimewgll_xx, &
hprime_zz,hprimewgll_zz,wxgll,wzgll, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right, &
- nspec_outer, ispec_outer_to_glob, .true.)
+ nspec_outer, ispec_outer_to_glob, .true., &
+ nrec,isolver,save_forward,b_absorb_acoustic_left,&
+ b_absorb_acoustic_right,b_absorb_acoustic_bottom,&
+ b_absorb_acoustic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax)
+ if(anyabs .and. save_forward .and. isolver == 1) then
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do i=1,NGLLZ
+ write(65) b_absorb_acoustic_left(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do i=1,NGLLZ
+ write(66) b_absorb_acoustic_right(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do i=1,NGLLX
+ write(67) b_absorb_acoustic_bottom(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do i=1,NGLLX
+ write(68) b_absorb_acoustic_top(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+ endif ! if(anyabs .and. save_forward .and. isolver == 1)
+
endif ! end of test if any acoustic element
! *********************************************************
@@ -2256,6 +3575,11 @@
displ_x = displ_elastic(1,iglob)
displ_z = displ_elastic(2,iglob)
+ if(isolver == 2) then
+ b_displ_x = b_displ_elastic(1,iglob)
+ b_displ_z = b_displ_elastic(2,iglob)
+ endif
+
! get point values for the acoustic side
i = ivalue(ipoin1D,iedge_acoustic)
j = jvalue(ipoin1D,iedge_acoustic)
@@ -2288,44 +3612,145 @@
potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
+ if(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) +&
+ weight*(b_displ_x*nx + b_displ_z*nz)
+ endif
+
enddo
enddo
endif
+! *********************************************************
+! ************* add coupling with the poroelastic side
+! *********************************************************
+
+ if(coupled_acoustic_poroelastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+ displ_x = displs_poroelastic(1,iglob)
+ displ_z = displs_poroelastic(2,iglob)
+
+ phil = porosity(kmato(ispec_poroelastic))
+ displw_x = displw_poroelastic(1,iglob)
+ displw_z = displw_poroelastic(2,iglob)
+
+ if(isolver == 2) then
+ b_displ_x = b_displs_poroelastic(1,iglob)
+ b_displ_z = b_displs_poroelastic(2,iglob)
+
+ b_displw_x = b_displw_poroelastic(1,iglob)
+ b_displw_z = b_displw_poroelastic(2,iglob)
+ endif
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == IBOTTOM .or. iedge_acoustic == ITOP) then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ else
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ endif
+
+! compute dot product [u_s + w]*n
+ displ_n = (displ_x + displw_x)*nx + (displ_z + displw_z)*nz
+
+! formulation with generalized potential
+ weight = jacobian1D * wxgll(i)
+
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
+
+ if(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) +&
+ weight*((b_displ_x + b_displw_x)*nx + (b_displ_z + b_displw_z)*nz)
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
! assembling potential_dot_dot for acoustic elements (send)
#ifdef USE_MPI
if ( nproc > 1 .and. any_acoustic .and. ninterface_acoustic > 0) then
call assemble_MPI_vector_ac_start(potential_dot_dot_acoustic,npoin, &
- ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
+ ninterface, ninterface_acoustic, &
+ inum_interfaces_acoustic, &
max_interface_size, max_ibool_interfaces_size_ac,&
ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
- tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac)
+ tab_requests_send_recv_acoustic, &
+ buffer_send_faces_vector_ac &
+ )
endif
#endif
! second call, computation on inner elements
if(any_acoustic) then
- call compute_forces_acoustic(npoin,nspec,nelemabs,numat, &
- anyabs,assign_external_model,ibool,kmato,numabs, &
- elastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
- vpext,rhoext,hprime_xx,hprimewgll_xx, &
+ call compute_forces_acoustic(npoin,nspec,myrank,numat, &
+ iglob_source,ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ assign_external_model,initialfield,ibool,kmato, &
+ elastic,poroelastic,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,b_potential_dot_dot_acoustic,b_potential_acoustic,&
+ density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,source_time_function,adj_sourcearrays,hprime_xx,hprimewgll_xx, &
hprime_zz,hprimewgll_zz,wxgll,wzgll, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right, &
- nspec_inner, ispec_inner_to_glob, .false.)
+ nspec_inner, ispec_inner_to_glob, .false., &
+ nrec,isolver,save_forward,b_absorb_acoustic_left,&
+ b_absorb_acoustic_right,b_absorb_acoustic_bottom,&
+ b_absorb_acoustic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax)
endif
! assembling potential_dot_dot for acoustic elements (receive)
#ifdef USE_MPI
if ( nproc > 1 .and. any_acoustic .and. ninterface_acoustic > 0) then
call assemble_MPI_vector_ac_wait(potential_dot_dot_acoustic,npoin, &
- ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
+ ninterface, ninterface_acoustic, &
+ inum_interfaces_acoustic, &
max_interface_size, max_ibool_interfaces_size_ac,&
ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
- tab_requests_send_recv_acoustic,buffer_recv_faces_vector_ac)
+ tab_requests_send_recv_acoustic, &
+ buffer_recv_faces_vector_ac &
+ )
endif
#endif
@@ -2336,55 +3761,306 @@
if(any_acoustic) then
-! --- add the source
- if(.not. initialfield) then
-! if this processor carries the source and the source element is acoustic
- if (is_proc_source == 1 .and. .not. elastic(ispec_selected_source)) then
-! collocated force
-! 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
- if(source_type == 1) then
- potential_dot_dot_acoustic(iglob_source) = potential_dot_dot_acoustic(iglob_source) - source_time_function(it)
-
-! moment tensor
- else if(source_type == 2) then
- call exit_MPI('cannot have moment tensor source in acoustic element')
- endif
- endif ! if this processor carries the source and the source element is acoustic
- endif ! if not using an initial field
-
potential_dot_dot_acoustic = potential_dot_dot_acoustic * rmass_inverse_acoustic
potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
+ if(isolver == 2) then
+ b_potential_dot_dot_acoustic = b_potential_dot_dot_acoustic * rmass_inverse_acoustic
+ b_potential_dot_acoustic = b_potential_dot_acoustic + b_deltatover2*b_potential_dot_dot_acoustic
+ endif
! free surface for an acoustic medium
if ( nelem_acoustic_surface > 0 ) then
call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,acoustic_surface,ibool,nelem_acoustic_surface,npoin,nspec)
+ potential_acoustic,acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
endif
endif
+! ****************************************************************************************
+! If coupling elastic/poroelastic domain, average some arrays at the interface first
+! ****************************************************************************************
+ if(coupled_elastic_poroelastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get point values for the elastic side
+ ii2 = ivalue(ipoin1D,iedge_elastic)
+ jj2 = jvalue(ipoin1D,iedge_elastic)
+ iglob2 = ibool(ii2,jj2,ispec_elastic)
+
+ displ(1)=(displs_poroelastic(1,iglob) +displ_elastic(1,iglob2))/2.d0
+ displ(2)=(displs_poroelastic(2,iglob) +displ_elastic(2,iglob2))/2.d0
+
+ displs_poroelastic(1,iglob)=displ(1)
+ displs_poroelastic(2,iglob)=displ(2)
+ displw_poroelastic(1,iglob)= ZERO
+ displw_poroelastic(2,iglob)= ZERO
+
+ displ_elastic(1,iglob2)=displ(1)
+ displ_elastic(2,iglob2)=displ(2)
+
+ veloc(1)=(velocs_poroelastic(1,iglob) +veloc_elastic(1,iglob2))/2.d0
+ veloc(2)=(velocs_poroelastic(2,iglob) +veloc_elastic(2,iglob2))/2.d0
+
+ velocs_poroelastic(1,iglob)=veloc(1)
+ velocs_poroelastic(2,iglob)=veloc(2)
+ velocw_poroelastic(1,iglob)= ZERO
+ velocw_poroelastic(2,iglob)= ZERO
+
+ veloc_elastic(1,iglob2)=veloc(1)
+ veloc_elastic(2,iglob2)=veloc(2)
+
+ enddo
+ enddo
+ endif
+
! *********************************************************
! ************* main solver for the elastic elements
! *********************************************************
! first call, computation on outer elements, absorbing conditions and source
- if(any_elastic) &
- call compute_forces_elastic(npoin,nspec,nelemabs,numat, &
- ispec_selected_source,is_proc_source,source_type,it,NSTEP,anyabs,assign_external_model, &
+ if(any_elastic) then
+ call compute_forces_elastic(npoin,nspec,myrank,nelemabs,numat,iglob_source, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs,assign_external_model, &
initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
- accel_elastic,veloc_elastic,displ_elastic,density,elastcoef,xix,xiz,gammax,gammaz, &
- jacobian,vpext,vsext,rhoext,source_time_function,sourcearray, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,elastic, &
+ accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic,&
+ density,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,adj_sourcearrays, &
e1,e11,e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
nspec_outer, ispec_outer_to_glob,.true.,deltat,coord,add_Bielak_conditions, x0_source, z0_source, &
A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset, f0,&
- v0x_left(:,it),v0z_left(:,it),v0x_right(:,it),v0z_right(:,it),v0x_bot(:,it),v0z_bot(:,it), &
- t0x_left(:,it),t0z_left(:,it),t0x_right(:,it),t0z_right(:,it),t0x_bot(:,it),t0z_bot(:,it), &
- count_left,count_right,count_bot,over_critical_angle)
+ nrec,isolver,save_forward,b_absorb_elastic_left,&
+ b_absorb_elastic_right,b_absorb_elastic_bottom,b_absorb_elastic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,mu_k,kappa_k)
+ if(anyabs .and. save_forward .and. isolver == 1) then
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ write(35) b_absorb_elastic_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ write(36) b_absorb_elastic_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ write(37) b_absorb_elastic_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ write(38) b_absorb_elastic_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ endif ! if(anyabs .and. save_forward .and. isolver == 1)
+
+ endif !if(any_elastic)
+
+! ****************************************************************************
+! ************* add coupling with the poroelastic side
+! ****************************************************************************
+ if(coupled_elastic_poroelastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get poroelastic domain paramters
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec_poroelastic))
+ kappal_s = poroelastcoef(3,1,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec_poroelastic))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec_poroelastic))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ mul_G = mul_fr
+ lambdal_G = H_biot - TWO*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec_poroelastic)
+ xizl = xiz(i,j,ispec_poroelastic)
+ gammaxl = gammax(i,j,ispec_poroelastic)
+ gammazl = gammaz(i,j,ispec_poroelastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+! compute stress tensor (include attenuation or anisotropy if needed)
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_G*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+
+! get point values for the elastic domain, which matches our side in the inverse direction
+ i = ivalue(ipoin1D,iedge_elastic)
+ j = jvalue(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+! normal is oriented from bottom to top layer
+! we notted that n.delta u_bottom = n.delta u_top
+ if(iedge_poroelastic == ITOP)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_poroelastic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - weight*( &
+ sigma_xx*nx + sigma_xz*nz)
+
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - weight*( &
+ sigma_xz*nx + sigma_zz*nz)
+
+ enddo
+
+ enddo
+
+ endif
+
! *********************************************************
! ************* add coupling with the acoustic side
! *********************************************************
@@ -2410,8 +4086,18 @@
j = jvalue_inverse(ipoin1D,iedge_acoustic)
iglob = ibool(i,j,ispec_acoustic)
+! get density of the fluid, depending if external density model
+ if(assign_external_model) then
+ rhol = rhoext(i,j,ispec_acoustic)
+ else
+ rhol = density(2,kmato(ispec_acoustic))
+ endif
+
! compute pressure on the fluid/solid edge
- pressure = - potential_dot_dot_acoustic(iglob)
+ pressure = - rhol * potential_dot_dot_acoustic(iglob)
+ if(isolver == 2) then
+ b_pressure = - rhol * b_potential_dot_dot_acoustic(iglob)
+ endif
! get point values for the elastic side
i = ivalue(ipoin1D,iedge_elastic)
@@ -2451,42 +4137,49 @@
! assembling accel_elastic for elastic elements (send)
#ifdef USE_MPI
- if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0) then
+ if ( nproc > 1 .and. any_elastic .and. ninterface_elastic > 0) then
call assemble_MPI_vector_el_start(accel_elastic,npoin, &
- ninterface, ninterface_elastic,inum_interfaces_elastic, &
- max_interface_size, max_ibool_interfaces_size_el,&
- ibool_interfaces_elastic, nibool_interfaces_elastic, &
- tab_requests_send_recv_elastic,buffer_send_faces_vector_el)
+ ninterface, ninterface_elastic, &
+ inum_interfaces_elastic, &
+ max_interface_size, max_ibool_interfaces_size_el,&
+ ibool_interfaces_elastic, nibool_interfaces_elastic, &
+ tab_requests_send_recv_elastic, &
+ buffer_send_faces_vector_el &
+ )
endif
#endif
-! second call, computation on inner elements and update
+! second call, computation on inner elements and update of
if(any_elastic) &
- call compute_forces_elastic(npoin,nspec,nelemabs,numat, &
- ispec_selected_source,is_proc_source,source_type,it,NSTEP,anyabs,assign_external_model, &
+ call compute_forces_elastic(npoin,nspec,myrank,nelemabs,numat,iglob_source, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs,assign_external_model, &
initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
- accel_elastic,veloc_elastic,displ_elastic,density,elastcoef,xix,xiz,gammax,gammaz, &
- jacobian,vpext,vsext,rhoext,source_time_function,sourcearray, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,elastic, &
+ accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic,&
+ density,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,adj_sourcearrays, &
e1,e11,e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
nspec_inner, ispec_inner_to_glob,.false.,deltat,coord,add_Bielak_conditions, x0_source, z0_source, &
A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset, f0,&
- v0x_left(:,it),v0z_left(:,it),v0x_right(:,it),v0z_right(:,it),v0x_bot(:,it),v0z_bot(:,it), &
- t0x_left(:,it),t0z_left(:,it),t0x_right(:,it),t0z_right(:,it),t0x_bot(:,it),t0z_bot(:,it), &
- count_left,count_right,count_bot,over_critical_angle)
+ nrec,isolver,save_forward,b_absorb_elastic_left,&
+ b_absorb_elastic_right,b_absorb_elastic_bottom,b_absorb_elastic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,mu_k,kappa_k)
-
! assembling accel_elastic for elastic elements (receive)
#ifdef USE_MPI
- if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0) then
+ if ( nproc > 1 .and. any_elastic .and. ninterface_elastic > 0) then
call assemble_MPI_vector_el_wait(accel_elastic,npoin, &
- ninterface, ninterface_elastic,inum_interfaces_elastic, &
- max_interface_size, max_ibool_interfaces_size_el,&
- ibool_interfaces_elastic, nibool_interfaces_elastic, &
- tab_requests_send_recv_elastic,buffer_recv_faces_vector_el)
- endif
+ ninterface, ninterface_elastic, &
+ inum_interfaces_elastic, &
+ max_interface_size, max_ibool_interfaces_size_el,&
+ ibool_interfaces_elastic, nibool_interfaces_elastic, &
+ tab_requests_send_recv_elastic, &
+ buffer_recv_faces_vector_el &
+ )
+ end if
#endif
@@ -2495,43 +4188,478 @@
! ************************************************************************************
if(any_elastic) then
+ accel_elastic(1,:) = accel_elastic(1,:) * rmass_inverse_elastic
+ accel_elastic(2,:) = accel_elastic(2,:) * rmass_inverse_elastic
+ veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+ if(isolver == 2) then
+ b_accel_elastic(1,:) = b_accel_elastic(1,:) * rmass_inverse_elastic(:)
+ b_accel_elastic(2,:) = b_accel_elastic(2,:) * rmass_inverse_elastic(:)
+ b_veloc_elastic = b_veloc_elastic + b_deltatover2*b_accel_elastic
+ endif
+ endif
-! --- add the source if it is a collocated force
- if(.not. initialfield) then
+ if(any_elastic .and. isolver == 2) then ! kernels calculation
+ do iglob = 1,npoin
+ rho_k(iglob) = accel_elastic(1,iglob)*b_displ_elastic(1,iglob) +&
+ accel_elastic(2,iglob)*b_displ_elastic(2,iglob)
+ enddo
+ endif
-! if this processor carries the source and the source element is elastic
- if (is_proc_source == 1 .and. elastic(ispec_selected_source)) then
+! ******************************************************************************************************************
+! ******************************************************************************************************************
+! ************* main solver for the poroelastic elements: first the solid (u_s) than the fluid (w)
+! ******************************************************************************************************************
+! ******************************************************************************************************************
-! collocated force
- if(source_type == 1) then
- accel_elastic(1,iglob_source) = accel_elastic(1,iglob_source) - sin(angleforce)*source_time_function(it)
- accel_elastic(2,iglob_source) = accel_elastic(2,iglob_source) + cos(angleforce)*source_time_function(it)
- endif
+! first call, computation on outer elements, absorbing conditions and source
+ if(any_poroelastic) then
+ call compute_forces_solid(npoin,nspec,myrank,numat,iglob_source, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs,assign_external_model, &
+ initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,poroelastic, &
+ accels_poroelastic,velocs_poroelastic,velocw_poroelastic,displs_poroelastic,displw_poroelastic,&
+ b_accels_poroelastic,b_displs_poroelastic,b_displw_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,adj_sourcearrays,e1,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
+ jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ nspec_outer, ispec_outer_to_glob,.true.,nrec,isolver,save_forward,&
+ b_absorb_poro_s_left,b_absorb_poro_s_right,b_absorb_poro_s_bottom,b_absorb_poro_s_top,&
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,&
+ mufr_k,B_k)
+
- endif ! if this processor carries the source and the source element is elastic
- endif ! if not using an initial field
+ call compute_forces_fluid(npoin,nspec,myrank,numat,iglob_source, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs,assign_external_model, &
+ initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,poroelastic, &
+ accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
+ b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,adj_sourcearrays,e1,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
+ jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ nspec_outer, ispec_outer_to_glob,.true.,nrec,isolver,save_forward,&
+ b_absorb_poro_w_left,b_absorb_poro_w_right,b_absorb_poro_w_bottom,b_absorb_poro_w_top,&
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,&
+ C_k,M_k)
- accel_elastic(1,:) = accel_elastic(1,:) * rmass_inverse_elastic
- accel_elastic(2,:) = accel_elastic(2,:) * rmass_inverse_elastic
- veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+ if(anyabs .and. save_forward .and. isolver == 1) then
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ write(45) b_absorb_poro_s_left(id,i,ispec,it)
+ write(25) b_absorb_poro_w_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ write(46) b_absorb_poro_s_right(id,i,ispec,it)
+ write(26) b_absorb_poro_w_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ write(47) b_absorb_poro_s_bottom(id,i,ispec,it)
+ write(29) b_absorb_poro_w_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ write(48) b_absorb_poro_s_top(id,i,ispec,it)
+ write(28) b_absorb_poro_w_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ endif ! if(anyabs .and. save_forward .and. isolver == 1)
+
+ endif ! if(any_poroelastic)
+
+! ****************************************************************************
+! ************* add coupling with the elastic side
+! ****************************************************************************
+ if(coupled_elastic_poroelastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the elastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! get poroelastic medium properties
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+!
+ rhol_s = density(1,kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+
+! get elastic properties
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec_elastic))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec_elastic))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec_elastic))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(2,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displ_elastic(2,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec_elastic)
+ xizl = xiz(i,j,ispec_elastic)
+ gammaxl = gammax(i,j,ispec_elastic)
+ gammazl = gammaz(i,j,ispec_elastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+! compute stress tensor
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
+ sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+
+ sigmap = kappal*(dux_dxl + duz_dzl)
+
+! get point values for the poroelastic side
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+! normal is oriented from bottom to top layer
+! we notted that n.delta u_bottom = n.delta u_top
+ if(iedge_poroelastic == ITOP)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_poroelastic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+! contribution to the solid phase
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + &
+ weight*(sigma_xx*nx + sigma_xz*nz)*(1._CUSTOM_REAL - phil/tortl)
+
+
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + &
+ weight*(sigma_xz*nx + sigma_zz*nz)*(1._CUSTOM_REAL - phil/tortl)
+
+! contribution to the fluid phase
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - &
+ weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(sigma_xx*nx + sigma_xz*nz)
+
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - &
+ weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(sigma_xz*nx + sigma_zz*nz)
+
+
+ enddo
+
+ enddo
+
+ endif
+
+! *********************************************************
+! ************* add coupling with the acoustic side
+! *********************************************************
+
+ if(coupled_acoustic_poroelastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the acoustic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_acoustic)
+ j = jvalue_inverse(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! get density of the acoustic fluid and poroelastic parameters, depending if external density model
+ if(assign_external_model) then
+ rhol = rhoext(i,j,ispec_acoustic)
+ else
+ rhol = density(2,kmato(ispec_acoustic))
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+ rhol_s = density(1,kmato(ispec_poroelastic))
+ rhol_bar = (1._CUSTOM_REAL-phil)*rhol_s + phil*rhol_f
+ endif
+
+! compute pressure on the fluid/porous medium edge
+ pressure = - rhol * potential_dot_dot_acoustic(iglob)
+ if(isolver == 2) then
+ b_pressure = - rhol * b_potential_dot_dot_acoustic(iglob)
+ endif
+
+! get point values for the poroelastic side
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == IBOTTOM .or. iedge_acoustic == ITOP) then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ else
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ endif
+
+! formulation with generalized potential
+ weight = jacobian1D * wxgll(i)
+
+! contribution to the solid phase
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + weight*nx*pressure*(1._CUSTOM_REAL-phil/tortl)
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + weight*nz*pressure*(1._CUSTOM_REAL-phil/tortl)
+
+! contribution to the fluid phase
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) + weight*nx*pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + weight*nz*pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+
+ enddo
+
+ enddo
+
+ endif
+
+! assembling accel_poroelastic for poroelastic elements (send)
+#ifdef USE_MPI
+ if ( nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0) then
+ call assemble_MPI_vector_po_start(accels_poroelastic,accelw_poroelastic,npoin, &
+ ninterface, ninterface_poroelastic, &
+ inum_interfaces_poroelastic, &
+ max_interface_size, max_ibool_interfaces_size_po,&
+ ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
+ tab_requests_send_recv_poroelastic, &
+ buffer_send_faces_vector_pos, buffer_send_faces_vector_pow)
+
endif
+#endif
+! second call, computation on inner elements and update of
+ if(any_poroelastic) then
+ call compute_forces_solid(npoin,nspec,myrank,numat,iglob_source, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs,assign_external_model, &
+ initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,poroelastic, &
+ accels_poroelastic,velocs_poroelastic,velocw_poroelastic,displs_poroelastic,displw_poroelastic,&
+ b_accels_poroelastic,b_displs_poroelastic,b_displw_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,adj_sourcearrays,e1,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
+ jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ nspec_inner, ispec_inner_to_glob,.false.,nrec,isolver,save_forward,&
+ b_absorb_poro_s_left,b_absorb_poro_s_right,b_absorb_poro_s_bottom,b_absorb_poro_s_top,&
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,&
+ mufr_k,B_k)
+
+ call compute_forces_fluid(npoin,nspec,myrank,numat,iglob_source, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs,assign_external_model, &
+ initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,poroelastic, &
+ accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
+ b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,adj_sourcearrays,e1,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
+ jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ nspec_inner, ispec_inner_to_glob,.false.,nrec,isolver,save_forward,&
+ b_absorb_poro_w_left,b_absorb_poro_w_right,b_absorb_poro_w_bottom,b_absorb_poro_w_top,&
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,&
+ C_k,M_k)
+
+ endif ! if(any_poroelastic)
+
+! assembling accel_poroelastic for poroelastic elements (receive)
+#ifdef USE_MPI
+ if ( nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0) then
+ call assemble_MPI_vector_po_wait(accels_poroelastic,accelw_poroelastic,npoin, &
+ ninterface, ninterface_poroelastic, &
+ inum_interfaces_poroelastic, &
+ max_interface_size, max_ibool_interfaces_size_po,&
+ ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
+ tab_requests_send_recv_poroelastic, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow)
+ end if
+#endif
+
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
+
+ if(any_poroelastic) then
+ accels_poroelastic(1,:) = accels_poroelastic(1,:) * rmass_s_inverse_poroelastic(:)
+ accels_poroelastic(2,:) = accels_poroelastic(2,:) * rmass_s_inverse_poroelastic(:)
+ velocs_poroelastic = velocs_poroelastic + deltatover2*accels_poroelastic
+ accelw_poroelastic(1,:) = accelw_poroelastic(1,:) * rmass_w_inverse_poroelastic(:)
+ accelw_poroelastic(2,:) = accelw_poroelastic(2,:) * rmass_w_inverse_poroelastic(:)
+ velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
+ if(isolver == 2) then
+ b_accels_poroelastic(1,:) = b_accels_poroelastic(1,:) * rmass_s_inverse_poroelastic(:)
+ b_accels_poroelastic(2,:) = b_accels_poroelastic(2,:) * rmass_s_inverse_poroelastic(:)
+ b_velocs_poroelastic = b_velocs_poroelastic + b_deltatover2*b_accels_poroelastic
+ b_accelw_poroelastic(1,:) = b_accelw_poroelastic(1,:) * rmass_w_inverse_poroelastic(:)
+ b_accelw_poroelastic(2,:) = b_accelw_poroelastic(2,:) * rmass_w_inverse_poroelastic(:)
+ b_velocw_poroelastic = b_velocw_poroelastic + b_deltatover2*b_accelw_poroelastic
+ endif
+ endif
+
+
+ if(any_poroelastic .and. isolver ==2) then
+ do iglob =1,npoin
+ rhot_k(iglob) = accels_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
+ accels_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob)
+ rhof_k(iglob) = accelw_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
+ accelw_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob) + &
+ accels_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ accels_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ sm_k(iglob) = accelw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ accelw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ eta_k(iglob) = velocw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ velocw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ enddo
+ endif
+
!---- compute kinetic and potential energy
+!
if(OUTPUT_ENERGY) &
call compute_energy(displ_elastic,veloc_elastic, &
+ displs_poroelastic,velocs_poroelastic,displw_poroelastic,velocw_poroelastic, &
xix,xiz,gammax,gammaz,jacobian,ibool,elastic,hprime_xx,hprime_zz, &
- nspec,npoin,assign_external_model,it,deltat,t0,kmato,elastcoef,density, &
+ nspec,npoin,assign_external_model,it,deltat,t0,kmato,poroelastcoef,density, &
+ porosity,tortuosity,&
vpext,vsext,rhoext,wxgll,wzgll,numat, &
pressure_element,vector_field_element,e1,e11, &
- potential_dot_acoustic,potential_dot_dot_acoustic,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
+ potential_dot_acoustic,potential_dot_dot_acoustic,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,&
+ Mu_nu1,Mu_nu2,N_SLS)
!---- display time step and max of norm of displacement
if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
- if (myrank == 0) then
+ if ( myrank == 0 ) then
write(IOUT,*)
if(time >= 1.d-3 .and. time < 1000.d0) then
write(IOUT,"('Time step number ',i7,' t = ',f9.4,' s')") it,time
@@ -2550,14 +4678,36 @@
#ifdef USE_MPI
call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
#endif
- if (myrank == 0) write(IOUT,*) 'Max norm of vector field in solid = ',displnorm_all_glob
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Max norm of vector field in solid = ',displnorm_all_glob
+ endif
! check stability of the code in solid, exit if unstable
-! negative values can occur with some compilers when the unstable value is greater
-! than the greatest possible floating-point number of the machine
- if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
- call exit_MPI('code became unstable and blew up in solid')
+ if(displnorm_all_glob > STABILITY_THRESHOLD) call exit_MPI('code became unstable and blew up in solid')
endif
+ if(any_poroelastic_glob) then
+ if(any_poroelastic) then
+ displnorm_all = maxval(sqrt(displs_poroelastic(1,:)**2 + displs_poroelastic(2,:)**2))
+ displnormw_all = maxval(sqrt(displw_poroelastic(1,:)**2 + displw_poroelastic(2,:)**2))
+ else
+ displnorm_all = 0.d0
+ displnormw_all = 0.d0
+ endif
+ displnorm_all_glob = displnorm_all
+ displnormw_all_glob = displnormw_all
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (displnormw_all, displnormw_all_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+#endif
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Max norm of vector field in solid (poro) = ',displnorm_all_glob
+ write(IOUT,*) 'Max norm of vector field in fluid (poro) = ',displnormw_all_glob
+ endif
+! check stability of the code in solid, exit if unstable
+ if(displnorm_all_glob > STABILITY_THRESHOLD) call exit_MPI('code became unstable and blew up in solid (poro)')
+ if(displnormw_all_glob > STABILITY_THRESHOLD) call exit_MPI('code became unstable and blew up in fluid (poro)')
+ endif
+
if(any_acoustic_glob) then
if(any_acoustic) then
displnorm_all = maxval(abs(potential_acoustic(:)))
@@ -2568,54 +4718,55 @@
#ifdef USE_MPI
call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
#endif
- if (myrank == 0) write(IOUT,*) 'Max absolute value of scalar field in fluid = ',displnorm_all_glob
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Max absolute value of scalar field in fluid = ',displnorm_all_glob
+ endif
! check stability of the code in fluid, exit if unstable
-! negative values can occur with some compilers when the unstable value is greater
-! than the greatest possible floating-point number of the machine
- if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
- call exit_MPI('code became unstable and blew up in fluid')
+ if(displnorm_all_glob > STABILITY_THRESHOLD) call exit_MPI('code became unstable and blew up in fluid')
endif
- if (myrank == 0) write(IOUT,*)
- endif
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ endif
+ endif !if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5)
! loop on all the receivers to compute and store the seismograms
do irecloc = 1,nrecloc
- irec = recloc(irecloc)
+ irec = recloc(irecloc)
ispec = ispec_selected_rec(irec)
! compute pressure in this element if needed
if(seismotype == 4) then
- call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
- TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
+ call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
+ TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
- else if(.not. elastic(ispec)) then
+ else if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
! for acoustic medium, compute vector field from gradient of potential for seismograms
- if(seismotype == 1) then
- call compute_vector_one_element(vector_field_element,potential_acoustic,displ_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
- else if(seismotype == 2) then
- call compute_vector_one_element(vector_field_element,potential_dot_acoustic,veloc_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
- else if(seismotype == 3) then
- call compute_vector_one_element(vector_field_element,potential_dot_dot_acoustic,accel_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
- endif
+ if(seismotype == 1) then
+ call compute_vector_one_element(vector_field_element,potential_acoustic,displ_elastic,&
+ displs_poroelastic,elastic,poroelastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
+ else if(seismotype == 2) then
+ call compute_vector_one_element(vector_field_element,potential_dot_acoustic,veloc_elastic,&
+ velocs_poroelastic,elastic,poroelastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
+ else if(seismotype == 3) then
+ call compute_vector_one_element(vector_field_element,potential_dot_dot_acoustic,accel_elastic,&
+ accels_poroelastic,elastic,poroelastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
+ endif
- else if(seismotype == 5) then
- call compute_curl_one_element(curl_element,displ_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin, ispec)
endif
! perform the general interpolation using Lagrange polynomials
valux = ZERO
valuz = ZERO
- valcurl = ZERO
do j = 1,NGLLZ
do i = 1,NGLLX
@@ -2624,45 +4775,51 @@
hlagrange = hxir_store(irec,i)*hgammar_store(irec,j)
- dcurld=ZERO
-
if(seismotype == 4) then
dxd = pressure_element(i,j)
dzd = ZERO
- else if(.not. elastic(ispec)) then
+ else if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
dxd = vector_field_element(1,i,j)
dzd = vector_field_element(2,i,j)
else if(seismotype == 1) then
+ if(poroelastic(ispec)) then
+ dxd = displs_poroelastic(1,iglob)
+ dzd = displs_poroelastic(2,iglob)
+ else
dxd = displ_elastic(1,iglob)
dzd = displ_elastic(2,iglob)
+ endif
else if(seismotype == 2) then
+ if(poroelastic(ispec)) then
+ dxd = velocs_poroelastic(1,iglob)
+ dzd = velocs_poroelastic(2,iglob)
+ else
dxd = veloc_elastic(1,iglob)
dzd = veloc_elastic(2,iglob)
+ endif
else if(seismotype == 3) then
+ if(poroelastic(ispec)) then
+ dxd = accels_poroelastic(1,iglob)
+ dzd = accels_poroelastic(2,iglob)
+ else
dxd = accel_elastic(1,iglob)
dzd = accel_elastic(2,iglob)
+ endif
- else if(seismotype == 5) then
-
- dxd = displ_elastic(1,iglob)
- dzd = displ_elastic(2,iglob)
- dcurld = curl_element(i,j)
-
endif
! compute interpolated field
valux = valux + dxd*hlagrange
valuz = valuz + dzd*hlagrange
- valcurl = valcurl + dcurld*hlagrange
enddo
enddo
@@ -2675,123 +4832,395 @@
sisux(seismo_current,irecloc) = valux
sisuz(seismo_current,irecloc) = ZERO
endif
- siscurl(seismo_current,irecloc) = valcurl
- enddo
+ enddo
!
+!----- ecriture des kernels
+!
+! kernels output
+ if(isolver == 2) then
+
+ if(any_elastic) then
+ rhopmin = 99999
+ rhopmax = -99999
+ alphamin = 99999
+ alphamax = -99999
+ betamin = 99999
+ betamax = -99999
+
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,k,ispec)
+ mul_global(iglob) = poroelastcoef(2,1,kmato(ispec))
+ kappal_global(iglob) = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_global(iglob)/3._CUSTOM_REAL
+ rhol_global(iglob) = density(1,kmato(ispec))
+ enddo
+ enddo
+ enddo
+
+! do k = 1, NGLLZ
+! do i = 1, NGLLX
+! iglob = ibool(i,k,ispec)
+ do iglob =1,npoin
+ rho_kl(iglob) = rho_kl(iglob) - rhol_global(iglob) * rho_k(iglob) * deltat
+ mu_kl(iglob) = mu_kl(iglob) - TWO * mul_global(iglob) * mu_k(iglob) * deltat
+ kappa_kl(iglob) = kappa_kl(iglob) - kappal_global(iglob) * kappa_k(iglob) * deltat
+!
+ rhop_kl(iglob) = rho_kl(iglob) + kappa_kl(iglob) + mu_kl(iglob)
+ beta_kl(iglob) = TWO * (mu_kl(iglob) - 4._CUSTOM_REAL * mul_global(iglob) &
+ / (3._CUSTOM_REAL * kappal_global(iglob)) * kappa_kl(iglob))
+ alpha_kl(iglob) = TWO * (1._CUSTOM_REAL + 4._CUSTOM_REAL * mul_global(iglob)/&
+ (3._CUSTOM_REAL * kappal_global(iglob))) * kappa_kl(iglob)
+ if(rhop_kl(iglob) > rhopmax) rhopmax = rhop_kl(iglob)
+ if(rhop_kl(iglob) < rhopmin) rhopmin = rhop_kl(iglob)
+ if(alpha_kl(iglob) > alphamax) alphamax = alpha_kl(iglob)
+ if(alpha_kl(iglob) < alphamin) alphamin = alpha_kl(iglob)
+ if(beta_kl(iglob) > betamax) betamax = beta_kl(iglob)
+ if(beta_kl(iglob) < betamin) betamin = beta_kl(iglob)
+ enddo
+! enddo
+! enddo
+! print*,'rho max min =',rhopmax,rhopmin
+! print*,'aplha max min =',alphamax,alphamin
+! print*,'beta max min =',betamax,betamin
+
+ endif !if(any_elastic)
+
+ if(any_poroelastic) then
+
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,k,ispec)
+ phil_global(iglob) = porosity(kmato(ispec))
+ tortl_global(iglob) = tortuosity(kmato(ispec))
+ rhol_s_global(iglob) = density(1,kmato(ispec))
+ rhol_f_global(iglob) = density(2,kmato(ispec))
+ rhol_bar_global(iglob) = (1._CUSTOM_REAL - phil_global(iglob))*rhol_s_global(iglob) &
+ + phil_global(iglob)*rhol_f_global(iglob)
+ etal_f_global(iglob) = poroelastcoef(2,2,kmato(ispec))
+ permlxx_global(iglob) = permeability(1,kmato(ispec))
+ permlxz_global(iglob) = permeability(2,kmato(ispec))
+ permlzz_global(iglob) = permeability(3,kmato(ispec))
+ enddo
+ enddo
+ enddo
+
+! do k = 1, NGLLZ
+! do i = 1, NGLLX
+! iglob = ibool(i,k,ispec)
+ do iglob =1,npoin
+ rhot_kl(iglob) = rhot_kl(iglob) - deltat * rhol_bar_global(iglob) * rhot_k(iglob)
+ rhof_kl(iglob) = rhof_kl(iglob) - deltat * rhol_f_global(iglob) * rhof_k(iglob)
+ sm_kl(iglob) = sm_kl(iglob) - deltat * rhol_f_global(iglob)*tortl_global(iglob)/phil_global(iglob) * sm_k(iglob)
+!at the moment works with constant permeability
+ eta_kl(iglob) = eta_kl(iglob) - deltat * etal_f_global(iglob)/permlxx_global(iglob) * eta_k(iglob)
+ B_kl(iglob) = B_kl(iglob) - deltat * B_k(iglob)
+ C_kl(iglob) = C_kl(iglob) - deltat * C_k(iglob)
+ M_kl(iglob) = M_kl(iglob) - deltat * M_k(iglob)
+ mufr_kl(iglob) = mufr_kl(iglob) - TWO * deltat * mufr_k(iglob)
+! density kernels
+ rholb = rhol_bar_global(iglob) - phil_global(iglob)*rhol_f_global(iglob)/tortl_global(iglob)
+ rhob_kl(iglob) = rholb/rhol_bar_global(iglob)*rhot_kl(iglob) + B_kl(iglob) + C_kl(iglob) +&
+ M_kl(iglob) + mufr_kl(iglob)
+ rhofb_kl(iglob) = rhof_kl(iglob) + phil_global(iglob)/tortl_global(iglob)*rhol_f_global(iglob)/&
+ rhol_bar_global(iglob)*rhot_kl(iglob) + sm_kl(iglob)
+ Bb_kl(iglob) = B_kl(iglob)
+ Cb_kl(iglob) = C_kl(iglob)
+ Mb_kl(iglob) = M_kl(iglob)
+ mufrb_kl(iglob) = mufr_kl(iglob)
+ phi_kl(iglob) = phil_global(iglob)/tortl_global(iglob)*rhol_f_global(iglob)/&
+ rhol_bar_global(iglob)*rhot_kl(iglob) - sm_kl(iglob)
+! wave speed kernels
+ dd1 = (1._CUSTOM_REAL+rholb/rhol_f_global(iglob))*ratio**2 + 2._CUSTOM_REAL*ratio +&
+ tortl_global(iglob)/phil_global(iglob)
+ rhobb_kl(iglob) = rhob_kl(iglob) - &
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIsquare + (cpIsquare - cpIIsquare)*ratio**2*( (phil_global(iglob)/&
+ tortl_global(iglob)-1._CUSTOM_REAL)/dd1 + rholb/rhol_f_global(iglob)*( (phil_global(iglob)/tortl_global(iglob) -&
+ 1._CUSTOM_REAL)*ratio**2 -rholb*tortl_global(iglob)**2/(rhol_f_global(iglob)*phil_global(iglob)**2) )/dd1**2 ))*&
+ Bb_kl(iglob) - &
+ rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) * (cpIsquare + &
+ (cpIsquare - cpIIsquare)*ratio**2*( (phil_global(iglob)/tortl_global(iglob) - rholb/rhol_f_global(iglob)-&
+ 1._CUSTOM_REAL)/dd1 + rholb/rhol_f_global(iglob)*(phil_global(iglob)/&
+ tortl_global(iglob)*ratio**2 + 2._CUSTOM_REAL*ratio +&
+ tortl_global(iglob)/phil_global(iglob))/dd1**2))*Mb_kl(iglob) - &
+ rhol_f_global(iglob)/C_biot * (cpIsquare +&
+ (cpIsquare - cpIIsquare)*ratio**2*( (phil_global(iglob)/tortl_global(iglob)-1._CUSTOM_REAL)/dd1 + rholb/&
+ rhol_f_global(iglob)*((phil_global(iglob)/tortl_global(iglob)-1._CUSTOM_REAL)*&
+ ratio**2 + rholb*tortl_global(iglob)/&
+ (rhol_f_global(iglob)*phil_global(iglob))*ratio) ))*Cb_kl(iglob)
+ rhofbb_kl(iglob) = rhofb_kl(iglob) + &
+ rhol_f_global(iglob)*phil_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIsquare + (cpIsquare - cpIIsquare)*ratio**2*( (phil_global(iglob)/&
+ tortl_global(iglob)-1._CUSTOM_REAL)/dd1 + rholb/rhol_f_global(iglob)*&
+ ( (phil_global(iglob)/tortl_global(iglob) -&
+ 1._CUSTOM_REAL)*ratio**2 -rholb*tortl_global(iglob)**2/(rhol_f_global(iglob)*phil_global(iglob)**2) )/dd1**2 ))*&
+ Bb_kl(iglob) + &
+ rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) * (cpIsquare + &
+ (cpIsquare - cpIIsquare)*ratio**2*( (phil_global(iglob)/tortl_global(iglob) - rholb/rhol_f_global(iglob)-&
+ 1._CUSTOM_REAL)/dd1 + rholb/rhol_f_global(iglob)*(phil_global(iglob)/&
+ tortl_global(iglob)*ratio**2 + 2._CUSTOM_REAL*ratio +&
+ tortl_global(iglob)/phil_global(iglob))/dd1**2))*Mb_kl(iglob) + &
+ rhol_f_global(iglob)/C_biot * (cpIsquare +&
+ (cpIsquare - cpIIsquare)*ratio**2*( (phil_global(iglob)/tortl_global(iglob)-1._CUSTOM_REAL)/dd1 + rholb/&
+ rhol_f_global(iglob)*((phil_global(iglob)/tortl_global(iglob)-1._CUSTOM_REAL)*ratio**2 + &
+ rholb*tortl_global(iglob)/&
+ (rhol_f_global(iglob)*phil_global(iglob))*ratio) ))*Cb_kl(iglob)
+ cpI_kl(iglob) = 2._CUSTOM_REAL*cpIsquare/B_biot * (rhol_bar_global(iglob) + (phil_global(iglob)*rhol_f_global(iglob)/&
+ (rholb*tortl_global(iglob))*(phil_global(iglob)/tortl_global(iglob)-1._CUSTOM_REAL)*ratio**2 -&
+ tortl_global(iglob)/phil_global(iglob))/dd1) * Bb_kl(iglob) +&
+ 2._CUSTOM_REAL*cpIsquare/M_biot * rhol_f_global(iglob)*tortl_global(iglob)/phil_global(iglob) * &
+ (1._CUSTOM_REAL + (phil_global(iglob)/tortl_global(iglob)-&
+ rholb/rhol_f_global(iglob)-1._CUSTOM_REAL)*ratio**2/dd1)*Mb_kl(iglob)+&
+ 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)/C_biot * &
+ (1._CUSTOM_REAL + ((phil_global(iglob)/tortl_global(iglob)-1._CUSTOM_REAL)*ratio**2+&
+ rholb*tortl_global(iglob)/(rhol_f_global(iglob)*phil_global(iglob))*ratio)/dd1)*Cb_kl(iglob)
+ cpII_kl(iglob) = -2._CUSTOM_REAL*cpIIsquare*rholb/B_biot * (phil_global(iglob)*rhol_f_global(iglob)/&
+ (rholb*tortl_global(iglob))*(phil_global(iglob)/tortl_global(iglob)-1._CUSTOM_REAL)*ratio**2 -&
+ tortl_global(iglob)/phil_global(iglob))/dd1 * Bb_kl(iglob) -&
+ 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) * &
+ (phil_global(iglob)/tortl_global(iglob)-rholb/rhol_f_global(iglob)-1._CUSTOM_REAL)*ratio**2/dd1*Mb_kl(iglob) - &
+ 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)/C_biot * &
+ ((phil_global(iglob)/tortl_global(iglob)-1._CUSTOM_REAL)*ratio**2+&
+ rholb*tortl_global(iglob)/(rhol_f_global(iglob)*phil_global(iglob))*ratio)/dd1*Cb_kl(iglob)
+ cs_kl(iglob) = 2._CUSTOM_REAL*mufrb_kl(iglob)
+
+ enddo
+
+! enddo
+! enddo
+
+ endif ! if(any_poroelastic)
+
+ endif ! if(isolver == 2)
+
+!
!---- display results at given time steps
!
if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
!
+! kernels output files
+!
+
+ if(isolver == 2 .and. it == NSTEP) then
+
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Writing Kernels file'
+ endif
+
+ if(any_elastic) then
+ write(filename,'(a,i7.7)') 'OUTPUT_FILES/snapshot_rho_kappa_mu',it
+ write(filename2,'(a,i7.7)') 'OUTPUT_FILES/snapshot_rhop_alpha_beta',it
+
+ open(unit = 97, file = trim(filename),status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ open(unit = 98, file = trim(filename2),status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ do iglob =1,npoin
+ xx = coord(1,iglob)/maxval(coord(1,:))
+ zz = coord(2,iglob)/maxval(coord(1,:))
+ write(97,'(5e12.3)')xx,zz,rho_kl(iglob),kappa_kl(iglob),mu_kl(iglob)
+ write(98,'(5e12.3)')xx,zz,rhop_kl(iglob),alpha_kl(iglob),beta_kl(iglob)
+ enddo
+ close(97)
+ close(98)
+ endif
+
+ if(any_poroelastic) then
+ write(filename,'(a,i7.7)') 'OUTPUT_FILES/snapshot_mu_B_C_',it
+
+ write(filename2,'(a,i7.7)') 'OUTPUT_FILES/snapshot_M_rho_rhof_',it
+
+ write(filename3,'(a,i7.7)') 'OUTPUT_FILES/snapshot_m_eta_',it
+
+ open(unit = 97, file = trim(filename),status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ open(unit = 98, file = trim(filename2),status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ open(unit = 99, file = trim(filename3),status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+!
+ write(filename,'(a,i7.7)') 'OUTPUT_FILES/snapshot_cpI_cpII_cs_',it
+
+ write(filename2,'(a,i7.7)') 'OUTPUT_FILES/snapshot_rhobb_rhofbb_',it
+
+! write(filename3,'(a,i7.7)') 'OUTPUT_FILES/snapshot_phi_eta_',it
+
+ open(unit = 17, file = trim(filename),status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ open(unit = 18, file = trim(filename2),status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ do iglob =1,npoin
+ xx = coord(1,iglob)/maxval(coord(1,:))
+ zz = coord(2,iglob)/maxval(coord(1,:))
+ write(97,'(5e12.3)')xx,zz,mufr_kl(iglob),B_kl(iglob),C_kl(iglob)
+ write(98,'(5e12.3)')xx,zz,M_kl(iglob),rhot_kl(iglob),rhof_kl(iglob)
+ write(99,'(5e12.3)')xx,zz,sm_kl(iglob),eta_kl(iglob)
+! write(17,'(5e12.3)')xx,zz,mufrb_kl(iglob),Bb_kl(iglob),Cb_kl(iglob)
+! write(18,'(5e12.3)')xx,zz,Mb_kl(iglob),rhob_kl(iglob),rhofb_kl(iglob)
+! write(19,'(5e12.3)')xx,zz,phi_kl(iglob),eta_kl(iglob)
+ write(17,'(5e12.3)')xx,zz,cpI_kl(iglob),cpII_kl(iglob),cs_kl(iglob)
+ write(18,'(5e12.3)')xx,zz,rhobb_kl(iglob),rhofbb_kl(iglob)
+ enddo
+ close(97)
+ close(98)
+ close(99)
+ close(17)
+ close(18)
+! close(19)
+ endif
+
+ endif
+
+!
!---- PostScript display
!
if(output_postscript_snapshot) then
- if (myrank == 0) write(IOUT,*) 'Writing PostScript file'
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Writing PostScript file'
+ endif
if(imagetype == 1) then
- if (myrank == 0) write(IOUT,*) 'drawing displacement vector as small arrows...'
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'drawing displacement vector as small arrows...'
+ endif
- call compute_vector_whole_medium(potential_acoustic,displ_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_whole_medium(potential_acoustic,displ_elastic,displs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,poroelastcoef,knods,kmato,ibool, &
numabs,codeabs,anyabs, &
nelem_acoustic_surface, acoustic_edges, &
- simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec, &
colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,myrank,nproc)
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
+ myrank, nproc)
else if(imagetype == 2) then
- if (myrank == 0) write(IOUT,*) 'drawing velocity vector as small arrows...'
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'drawing velocity vector as small arrows...'
+ endif
- call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,poroelastcoef,knods,kmato,ibool, &
numabs,codeabs,anyabs, &
nelem_acoustic_surface, acoustic_edges, &
- simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec, &
colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,myrank,nproc)
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
+ myrank, nproc)
else if(imagetype == 3) then
- if (myrank == 0) write(IOUT,*) 'drawing acceleration vector as small arrows...'
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'drawing acceleration vector as small arrows...'
+ endif
- call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,accels_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,poroelastcoef,knods,kmato,ibool, &
numabs,codeabs,anyabs, &
nelem_acoustic_surface, acoustic_edges, &
- simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec, &
colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,myrank,nproc)
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
+ myrank, nproc)
else if(imagetype == 4) then
- if (myrank == 0) write(IOUT,*) 'cannot draw scalar pressure field as a vector plot, skipping...'
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'cannot draw scalar pressure field as a vector plot, skipping...'
+ endif
else
call exit_MPI('wrong type for snapshots')
endif
- if (myrank == 0 .and. imagetype /= 4) write(IOUT,*) 'PostScript file written'
-
+ if ( myrank == 0 ) then
+ if(imagetype /= 4) write(IOUT,*) 'PostScript file written'
endif
+ endif ! if(output_postscript_snapshot)
+
!
!---- display color image
!
if(output_color_image) then
- if (myrank == 0) write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color
+ endif
if(imagetype == 1) then
- if (myrank == 0) write(IOUT,*) 'drawing image of vertical component of displacement vector...'
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'drawing image of vertical component of displacement vector...'
+ endif
- call compute_vector_whole_medium(potential_acoustic,displ_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_whole_medium(potential_acoustic,displ_elastic,displs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
else if(imagetype == 2) then
- if (myrank == 0) write(IOUT,*) 'drawing image of vertical component of velocity vector...'
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'drawing image of vertical component of velocity vector...'
+ endif
- call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
else if(imagetype == 3) then
- if (myrank == 0) write(IOUT,*) 'drawing image of vertical component of acceleration vector...'
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'drawing image of vertical component of acceleration vector...'
+ endif
- call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,accels_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
else if(imagetype == 4) then
- if (myrank == 0) write(IOUT,*) 'drawing image of pressure field...'
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'drawing image of pressure field...'
+ endif
- call compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,elastic,vector_field_display, &
+ call compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,e1,e11, &
TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
else
@@ -2804,14 +5233,16 @@
j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
image_color_data(i,j) = vector_field_display(2,iglob_image_color(i,j))
- enddo
+ end do
+
! assembling array image_color_data on process zero for color output
#ifdef USE_MPI
- if (nproc > 1) then
- if (myrank == 0) then
+ if ( nproc > 1 ) then
+ if ( myrank == 0 ) then
do iproc = 1, nproc-1
+
call MPI_RECV(data_pixel_recv(1),nb_pixel_per_proc(iproc+1), MPI_DOUBLE_PRECISION, &
iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
@@ -2819,35 +5250,38 @@
j = ceiling(real(num_pixel_recv(k,iproc+1)) / real(NX_IMAGE_color))
i = num_pixel_recv(k,iproc+1) - (j-1)*NX_IMAGE_color
image_color_data(i,j) = data_pixel_recv(k)
- enddo
- enddo
+ end do
+ end do
+
else
do k = 1, nb_pixel_loc
j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
data_pixel_send(k) = vector_field_display(2,iglob_image_color(i,j))
- enddo
+ end do
+
call MPI_SEND(data_pixel_send(1),nb_pixel_loc,MPI_DOUBLE_PRECISION, 0, 43, MPI_COMM_WORLD, ier)
- endif
- endif
+ end if
+ end if
#endif
- if (myrank == 0) then
+
+ if ( myrank == 0 ) then
call create_color_image(image_color_data,iglob_image_color,NX_IMAGE_color,NZ_IMAGE_color,it,cutsnaps,image_color_vp_display)
write(IOUT,*) 'Color image created'
endif
- endif
+ endif ! if(output_color_image)
!---- save temporary or final seismograms
- call write_seismograms(sisux,sisuz,siscurl,station_name,network_name,NSTEP, &
+ call write_seismograms(sisux,sisuz,station_name,network_name,NSTEP, &
nrecloc,which_proc_receiver,nrec,myrank,deltat,seismotype,st_xval,t0, &
- NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current)
-
+ NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current &
+ )
seismo_offset = seismo_offset + seismo_current
seismo_current = 0
@@ -2875,24 +5309,66 @@
write(*,*)
endif
- endif
+ endif ! if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP)
enddo ! end of the main time loop
- deallocate(v0x_left)
- deallocate(v0z_left)
- deallocate(t0x_left)
- deallocate(t0z_left)
+ if((save_forward .and. isolver==1) .or. isolver ==2) then
+ if(any_elastic) then
+ close(35)
+ close(36)
+ close(37)
+ close(38)
+ endif
+ if(any_poroelastic) then
+ close(25)
+ close(45)
+ close(26)
+ close(46)
+ close(29)
+ close(47)
+ close(28)
+ close(48)
+ endif
+ endif
- deallocate(v0x_right)
- deallocate(v0z_right)
- deallocate(t0x_right)
- deallocate(t0z_right)
+!
+!--- save last frame
+!
+ if(save_forward .and. isolver ==1 .and. any_elastic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving elastic last frame...'
+ write(IOUT,*)
+ endif
+ open(unit=55,file='OUTPUT_FILES/lastframe_elastic.bin',status='unknown',form='unformatted')
+ do j=1,npoin
+ write(55) (displ_elastic(i,j), i=1,NDIM), &
+ (veloc_elastic(i,j), i=1,NDIM), &
+ (accel_elastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+ endif
- deallocate(v0x_bot)
- deallocate(v0z_bot)
- deallocate(t0x_bot)
- deallocate(t0z_bot)
+ if(save_forward .and. isolver ==1 .and. any_poroelastic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving poroelastic last frame...'
+ write(IOUT,*)
+ endif
+ open(unit=55,file='OUTPUT_FILES/lastframe_poroelastic_s.bin',status='unknown',form='unformatted')
+ open(unit=56,file='OUTPUT_FILES/lastframe_poroelastic_w.bin',status='unknown',form='unformatted')
+ do j=1,npoin
+ write(55) (displs_poroelastic(i,j), i=1,NDIM), &
+ (velocs_poroelastic(i,j), i=1,NDIM), &
+ (accels_poroelastic(i,j), i=1,NDIM)
+ write(56) (displw_poroelastic(i,j), i=1,NDIM), &
+ (velocw_poroelastic(i,j), i=1,NDIM), &
+ (accelw_poroelastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+ close(56)
+ endif
!---- close energy file and create a gnuplot script to display it
if(OUTPUT_ENERGY) then
@@ -2907,7 +5383,9 @@
endif
! print exit banner
- if (myrank == 0) call datim(simulation_title)
+ if ( myrank == 0 ) then
+ call datim(simulation_title)
+ endif
!
!---- close output file
@@ -2993,3 +5471,40 @@
end program specfem2D
+
+
+subroutine is_in_convex_quadrilateral ( elmnt_coords, x_coord, z_coord, is_in)
+
+ implicit none
+
+ double precision, dimension(2,4) :: elmnt_coords
+ double precision, intent(in) :: x_coord, z_coord
+ logical, intent(out) :: is_in
+
+ real :: x1, x2, x3, x4, z1, z2, z3, z4
+ real :: normal1, normal2, normal3, normal4
+
+
+ x1 = elmnt_coords(1,1)
+ x2 = elmnt_coords(1,2)
+ x3 = elmnt_coords(1,3)
+ x4 = elmnt_coords(1,4)
+ z1 = elmnt_coords(2,1)
+ z2 = elmnt_coords(2,2)
+ z3 = elmnt_coords(2,3)
+ z4 = elmnt_coords(2,4)
+
+ normal1 = (z_coord-z1) * (x2-x1) - (x_coord-x1) * (z2-z1)
+ normal2 = (z_coord-z2) * (x3-x2) - (x_coord-x2) * (z3-z2)
+ normal3 = (z_coord-z3) * (x4-x3) - (x_coord-x3) * (z4-z3)
+ normal4 = (z_coord-z4) * (x1-x4) - (x_coord-x4) * (z1-z4)
+
+ if ( (normal1 < 0) .or. (normal2 < 0) .or. (normal3 < 0) .or. (normal4 < 0) ) then
+ is_in = .false.
+ else
+ is_in = .true.
+ end if
+
+
+
+end subroutine is_in_convex_quadrilateral
Modified: seismo/2D/SPECFEM2D/branches/BIOT/spline_routines.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/spline_routines.f90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/spline_routines.f90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
Modified: seismo/2D/SPECFEM2D/branches/BIOT/write_seismograms.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/write_seismograms.F90 2008-09-11 15:03:34 UTC (rev 12863)
+++ seismo/2D/SPECFEM2D/branches/BIOT/write_seismograms.F90 2008-09-11 18:24:41 UTC (rev 12864)
@@ -4,7 +4,7 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, France.
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
! Roland Martin, roland DOT martin aT univ-pau DOT fr
@@ -42,7 +42,7 @@
! write seismograms to text files
- subroutine write_seismograms(sisux,sisuz,siscurl,station_name,network_name, &
+ subroutine write_seismograms(sisux,sisuz,station_name,network_name, &
NSTEP,nrecloc,which_proc_receiver,nrec,myrank,deltat,seismotype,st_xval,t0, &
NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current &
)
@@ -58,10 +58,11 @@
integer :: NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current
double precision :: t0,deltat
+
integer, intent(in) :: nrecloc,myrank
integer, dimension(nrec),intent(in) :: which_proc_receiver
- double precision, dimension(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc), intent(in) :: sisux,sisuz,siscurl
+ double precision, dimension(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc), intent(in) :: sisux,sisuz
double precision st_xval(nrec)
@@ -101,8 +102,6 @@
component = 'a'
else if(seismotype == 4) then
component = 'p'
- else if(seismotype == 5) then
- component = 'c'
else
call exit_MPI('wrong component to save for seismograms')
endif
@@ -111,8 +110,6 @@
! only one seismogram if pressurs
if(seismotype == 4) then
number_of_components = 1
- else if(seismotype == 5) then
- number_of_components = NDIM+1
else
number_of_components = NDIM
endif
@@ -141,12 +138,6 @@
open(unit=11,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown')
close(11,status='delete')
- open(unit=11,file='OUTPUT_FILES/Curl_file_single.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/Curl_file_double.bin',status='unknown')
- close(11,status='delete')
-
endif
if ( myrank == 0 ) then
@@ -164,20 +155,13 @@
open(unit=13,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown',access='direct',recl=8)
endif
-! no Z component seismogram if pressure
+! no Z component seismogram if pressurs
if(seismotype /= 4) then
open(unit=14,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown',access='direct',recl=4)
open(unit=15,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown',access='direct',recl=8)
end if
-! curl output
- if(seismotype == 5) then
- open(unit=16,file='OUTPUT_FILES/Curl_file_single.bin',status='unknown',access='direct',recl=4)
- open(unit=17,file='OUTPUT_FILES/Curl_file_double.bin',status='unknown',access='direct',recl=8)
-
- end if
-
end if
@@ -191,9 +175,6 @@
buffer_binary(:,1) = sisux(:,irecloc)
if ( number_of_components == 2 ) then
buffer_binary(:,2) = sisuz(:,irecloc)
- else if ( number_of_components == 3 ) then
- buffer_binary(:,2) = sisuz(:,irecloc)
- buffer_binary(:,3) = siscurl(:,irecloc)
end if
#ifdef USE_MPI
@@ -204,12 +185,6 @@
call MPI_RECV(buffer_binary(1,2),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
end if
- if ( number_of_components == 3 ) then
- call MPI_RECV(buffer_binary(1,2),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
- which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
- call MPI_RECV(buffer_binary(1,3),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
- which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
- end if
#endif
@@ -222,8 +197,6 @@
chn = 'BHX'
else if(iorientation == 2) then
chn = 'BHZ'
- else if(iorientation == 3) then
- chn = 'cur'
else
call exit_MPI('incorrect channel value')
endif
@@ -279,10 +252,6 @@
write(14,rec=(irec-1)*NSTEP+seismo_offset+isample) sngl(buffer_binary(isample,2))
write(15,rec=(irec-1)*NSTEP+seismo_offset+isample) buffer_binary(isample,2)
end if
- if ( seismotype == 5 ) then
- write(16,rec=(irec-1)*NSTEP+seismo_offset+isample) sngl(buffer_binary(isample,3))
- write(17,rec=(irec-1)*NSTEP+seismo_offset+isample) buffer_binary(isample,3)
- end if
enddo
#ifdef USE_MPI
@@ -290,12 +259,9 @@
if ( which_proc_receiver(irec) == myrank ) then
irecloc = irecloc + 1
call MPI_SEND(sisux(1,irecloc),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ierror)
- if ( number_of_components >= 2 ) then
+ if ( number_of_components == 2 ) then
call MPI_SEND(sisuz(1,irecloc),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ierror)
end if
- if ( number_of_components == 3 ) then
- call MPI_SEND(siscurl(1,irecloc),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ierror)
- end if
end if
#endif
@@ -310,10 +276,6 @@
close(14)
close(15)
end if
- if ( seismotype == 5 ) then
- close(16)
- close(17)
- end if
!----
More information about the cig-commits
mailing list