[cig-commits] r15488 - in seismo/2D/SPECFEM2D/branches/BIOT: . DATA UTILS/adjoint
cmorency at geodynamics.org
cmorency at geodynamics.org
Thu Jul 30 14:33:27 PDT 2009
Author: cmorency
Date: 2009-07-30 14:33:24 -0700 (Thu, 30 Jul 2009)
New Revision: 15488
Modified:
seismo/2D/SPECFEM2D/branches/BIOT/DATA/CMTSOLUTION
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/README_POROELASTIC.txt
seismo/2D/SPECFEM2D/branches/BIOT/UTILS/adjoint/adj_seismogram.f90
seismo/2D/SPECFEM2D/branches/BIOT/UTILS/adjoint/plot_snapshot.csh
seismo/2D/SPECFEM2D/branches/BIOT/assemble_MPI.F90
seismo/2D/SPECFEM2D/branches/BIOT/attenuation_compute_param.c
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_curl_one_element.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_forces_fluid.f90
seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_solid.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/todo_list_please_dont_remove.txt
seismo/2D/SPECFEM2D/branches/BIOT/write_seismograms.F90
Log:
version SPECFEM2D + BIOT, waiting for merging
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/CMTSOLUTION
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/CMTSOLUTION 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/CMTSOLUTION 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,13 +1,13 @@
-#source 1
+# source 1
source_surf = .false. # source inside the medium or at the surface
-xs = 1600. # source location x in meters
-zs = 2900. # source location z in meters
+xs = 2500. # source location x in meters
+zs = 2500. # source location z in meters
source_type = 1 # elastic force or acoustic pressure = 1 or moment tensor = 2
-time_function_type = 5 # Ricker = 1, first derivative = 2, Gaussian = 3, Dirac = 4, Heaviside = 5
-f0 = 15.0 # dominant source frequency (Hz) if not Dirac or Heaviside
-t0 = 0.0 # time shift when multi sources (if one source, must be zero)
-angleforce = 0. # angle of the source (for a force only)
+time_function_type = 1 # Ricker = 1, first derivative = 2, Gaussian = 3, Dirac = 4, Heaviside = 5
+f0 = 3 # dominant source frequency (Hz) if not Dirac or Heaviside
+t0 = 0. # offset of the source, irrelevant if NSOURCE=1
+angleforce = 00. # 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)
-factor = 1.d10 # amplification factor
+factor = 1.d10 # amplification factor
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,26 +1,26 @@
# title of job, and file that contains interface data
-title = Test for 2 layers: acoustic/poroelastic
-interfacesfile = interfaces_poro_flat.dat
+title = Test for M2 UPPA
+interfacesfile = interfaces_1layer.dat
# data concerning mesh, when generated using third-party app (more info in README)
read_external_mesh = .false.
-mesh_file = ./DATA/yangluo_mesh_overthrust/mesh_file # file containing the mesh
-nodes_coords_file = ./DATA/yangluo_mesh_overthrust/nodes_coords_file # file containing the nodes coordinates
-materials_file = ./DATA/yangluo_mesh_overthrust/materials_file # file containing the material number for each element
-free_surface_file = ./DATA/yangluo_mesh_overthrust/free_surface_file # file containing the free surface
-absorbing_surface_file = ./DATA/yangluo_mesh_overthrust/absorbing_surface_file # file containing the absorbing surface
-receivers_file = ./DATA/yangluo_mesh_overthrust/receivers_file # file containing the receivers coordinates
+mesh_file = ./DATA/Mesh_canyon/canyon_mesh_file # file containing the mesh
+nodes_coords_file = ./DATA/Mesh_canyon/canyon_nodes_coords_file # file containing the nodes coordinates
+materials_file = ./DATA/Mesh_canyon/canyon_materials_file # file containing the material number for each element
+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
+tangential_detection_curve_file = ./DATA/courbe_eros_nodes # file containing the curve delimiting the velocity model
-# parameters concerning partitionning
+# parameters concerning partitioning
nproc = 1 # number of processes
-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.
-
+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.
+
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
-xmax = 4800.d0 # abscissa of right side of the model
-nx = 260 # number of elements along X
+xmax = 10.d3 # 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
@@ -28,57 +28,53 @@
TURN_ANISOTROPY_ON = .false. # turn anisotropy on or off for solid medium
TURN_ATTENUATION_ON = .false. # turn attenuation on or off for solid medium
TURN_VISCATTENUATION_ON = .false. # turn viscous attenuation on or off
-Q0 = 1 # quality factor for viscous attenuation
-freq0 = 10 # frequency for viscous attenuation
+Q0 = 1 # quality factor for viscous attenuation
+freq0 = 10 # frequency for viscous attenuation
# absorbing boundaries parameters
-absorbing_conditions = .true. # absorbing boundary active or not
+absorbing_conditions = .true. # absorbing boundary active or not
absorbbottom = .true.
absorbright = .true.
absorbtop = .false.
absorbleft = .true.
# time step parameters
-nt = 5000 # total number of time steps
-deltat = 3d-4 # duration of a time step
-isolver = 1 # type of simulation 1=forward 2=adjoint + kernels
+nt = 6000 # total number of time steps
+deltat = 1d-3 # duration of a time step
+isolver = 2 # type of simulation 1=forward 2=adjoint + kernels
-#source parameters
-NSOURCE = 1 # number of sources
+# source parameters
+NSOURCE = 1 # number of sources [source info read in CMTSOLUTION file]
+force_normal_to_surface = .false. # angleforce normal to surface (external mesh and curve file needed)
# constants for attenuation
-N_SLS = 2 # number of standard linear solids for attenuation
-Qp_attenuation = 136.4376068115 # quality factor P for attenuation
-Qs_attenuation = 136.4376068115 # quality factor S for attenuation
+N_SLS = 2 # number of standard linear solids for attenuation
+## DK DK Qp and Qs can now vary in each spectral element and are therefore given in the same list
+## DK DK list as rho, Vp and Vs at the end of this file
+#Qp_attenuation = 136.4376068115 # quality factor P for attenuation
+#Qs_attenuation = 136.4376068115 # quality factor S for attenuation
f0_attenuation = 5.196152422706633 # (Hz) relevant only if source is a Dirac or a Heaviside, else it is f0
# receiver line parameters for seismograms
-seismotype = 4 # record 1=displ 2=veloc 3=accel 4=pressure 5=potential
-save_forward = .false. # save the last frame
+seismotype = 1 # record 1=displ 2=veloc 3=accel 4=pressure 5=curl 6=potential
+save_forward = .false. # save the last frame, needed for adjoint simulation
generate_STATIONS = .true. # creates a STATION file in ./DATA
-nreceiverlines = 2 # number of receiver lines
+nreceiverlines = 1 # number of receiver lines
anglerec = 0.d0 # angle to rotate components at receivers
+rec_normal_to_surface = .false. # base anglerec normal to surface (external mesh and curve file needed)
# first receiver line
nrec = 1 # number of receivers
-xdeb = 2000. # first receiver x in meters
-zdeb = 2933.33 # 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 = .false. # receivers inside the medium or at the surface
-
-# second receiver line
-nrec = 1 # number of receivers
-xdeb = 2000. # first receiver x in meters
-zdeb = 1866.67 # first receiver z in meters
+xdeb = 7500. # first receiver x in meters
+zdeb = 2500. # first receiver z in meters
xfin = 3777. # last receiver x in meters (ignored if onlyone receiver)
zfin = 1866.67 # last receiver z in meters (ignored if onlyone receiver)
enreg_surf = .false. # receivers inside the medium or at the surface
# display parameters
NTSTEP_BETWEEN_OUTPUT_INFO = 200 # display frequency in time steps
-output_postscript_snapshot = .true. # output Postscript snapshot of the results
-output_color_image = .false. # output color image of the results
+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
meshvect = .true. # display mesh on vector plots or not
@@ -93,10 +89,10 @@
# velocity and density models
nbmodels = 1 # nb of different models
-# define models as (model_number,1,rho_s,rho_f,phi,tort,permx,permz,kappa_s,kappa_f,kappa_fr,mu_s,eta_f,mu_fr) or (Anisotropic: to be defined)
-# 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 2500.d0 1020.d0 0.0d0 2.0 1d-11 0.d0 1d-11 1.60554d10 2.295d9 1.0d10 9.63342d9 0.0d-4 9.63342d9
+# define models as I: (model_number,1,rho,Vp,Vs,0,0,Qp,Qs) or II: (model_number,2,rho,c11,c13,c33,c44,Qp,Qs) or III: (model_number,3,rhos,rhof,phi,c,kxx,kxz,kzz,Ks,Kf,Kfr,etaf,mufr,Qs).
+# For istropic elastic/acoustic material use I and set Vs to zero to make a given model acoustic, for anisotropic elastic use II,
+# and for isotropic poroelastic material use III. The mesh can contain acoustic, elastic, & poroelastic models simultaneously
+1 1 2500.d0 3000.d0 1800.d0 0 0 10.d0 10.d0 0 0 0 0 0 0 #1558.89d0 0 0 136.d0 136.d0 0 0 0 0 0 0
# define the different regions of the model in the (nx,nz) spectral element mesh
nbregions = 1 # nb of regions and model number for each
-1 260 1 160 1
+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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Abel_Balanche_bathy_source_solid 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 partitionning
+# parameters concerning partitioning
nproc = 1 # number of processes
-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.
+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.
# 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_M2_UPPA 2009-07-30 21:33:24 UTC (rev 15488)
@@ -10,11 +10,12 @@
materials_file = ./DATA/Mesh_canyon/canyon_materials_file # file containing the material number for each element
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
+tangential_detection_curve_file = ./DATA/courbe_eros_nodes # file containing the curve delimiting the velocity model
-# parameters concerning partitionning
+# parameters concerning partitioning
nproc = 1 # number of processes
-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.
+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.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
@@ -51,6 +52,7 @@
Mzz = 1. # Mzz component (for a moment tensor source only)
Mxz = 0. # Mxz component (for a moment tensor source only)
factor = 1.d10 # amplification factor
+force_normal_to_surface = .false. # angleforce normal to surface (external mesh and curve file needed)
# constants for attenuation
N_SLS = 2 # number of standard linear solids for attenuation
@@ -63,6 +65,7 @@
generate_STATIONS = .true. # creates a STATION file in ./DATA
nreceiverlines = 1 # number of receiver lines
anglerec = 0.d0 # angle to rotate components at receivers
+rec_normal_to_surface = .false. # base anglerec normal to surface (external mesh and curve file needed)
# first receiver line
nrec = 11 # number of receivers
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Ronan_SV_30
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Ronan_SV_30 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_Ronan_SV_30 2009-07-30 21:33:24 UTC (rev 15488)
@@ -10,11 +10,12 @@
materials_file = ./DATA/unstructured_fluide_solide_test/mat # file containing the material number for each element
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
+tangential_detection_curve_file = ./DATA/courbe_eros_nodes # file containing the curve delimiting the velocity model
-# parameters concerning partitionning
+# parameters concerning partitioning
nproc = 1 # number of processes
-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.
+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.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
@@ -50,6 +51,7 @@
Mzz = 1. # Mzz component (for a moment tensor source only)
Mxz = 0. # Mxz component (for a moment tensor source only)
factor = 1.d10 # amplification factor
+force_normal_to_surface = .false. # angleforce normal to surface (external mesh and curve file needed)
# constants for attenuation
N_SLS = 2 # number of standard linear solids for attenuation
@@ -62,6 +64,7 @@
generate_STATIONS = .true. # creates a STATION file in ./DATA
nreceiverlines = 1 # number of receiver lines
anglerec = 0.d0 # angle to rotate components at receivers
+rec_normal_to_surface = .false. # base anglerec normal to surface (external mesh and curve file needed)
# first receiver line
nrec = 11 # number of receivers
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_canyon
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_canyon 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_canyon 2009-07-30 21:33:24 UTC (rev 15488)
@@ -10,11 +10,12 @@
materials_file = ./DATA/Mesh_canyon/canyon_materials_file # file containing the material number for each element
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
+tangential_detection_curve_file = ./DATA/courbe_eros_nodes # file containing the curve delimiting the velocity model
-# parameters concerning partitionning
+# parameters concerning partitioning
nproc = 1 # number of processes
-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.
+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.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
@@ -50,6 +51,7 @@
Mzz = 1. # Mzz component (for a moment tensor source only)
Mxz = 0. # Mxz component (for a moment tensor source only)
factor = 1.d10 # amplification factor
+force_normal_to_surface = .false. # angleforce normal to surface (external mesh and curve file needed)
# constants for attenuation
N_SLS = 2 # number of standard linear solids for attenuation
@@ -62,6 +64,7 @@
generate_STATIONS = .true. # creates a STATION file in ./DATA
nreceiverlines = 1 # number of receiver lines
anglerec = 0.d0 # angle to rotate components at receivers
+rec_normal_to_surface = .false. # base anglerec normal to surface (external mesh and curve file needed)
# first receiver line
nrec = 60 # number of receivers
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_no_canyon
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_no_canyon 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_no_canyon 2009-07-30 21:33:24 UTC (rev 15488)
@@ -10,11 +10,12 @@
materials_file = ./DATA/Mesh_canyon/canyon_materials_file # file containing the material number for each element
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
+tangential_detection_curve_file = ./DATA/courbe_eros_nodes # file containing the curve delimiting the velocity model
-# parameters concerning partitionning
+# parameters concerning partitioning
nproc = 1 # number of processes
-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.
+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.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
@@ -50,6 +51,7 @@
Mzz = 1. # Mzz component (for a moment tensor source only)
Mxz = 0. # Mxz component (for a moment tensor source only)
factor = 1.d10 # amplification factor
+force_normal_to_surface = .false. # angleforce normal to surface (external mesh and curve file needed)
# constants for attenuation
N_SLS = 2 # number of standard linear solids for attenuation
@@ -62,6 +64,7 @@
generate_STATIONS = .false. # creates a STATION file in ./DATA
nreceiverlines = 1 # number of receiver lines
anglerec = 0.d0 # angle to rotate components at receivers
+rec_normal_to_surface = .false. # base anglerec normal to surface (external mesh and curve file needed)
# first receiver line
nrec = 60 # number of receivers
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_unstruct
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_unstruct 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/Par_file_unstruct 2009-07-30 21:33:24 UTC (rev 15488)
@@ -10,11 +10,12 @@
materials_file = ./DATA/unstructured_fluide_solide_test/mat # file containing the material number for each element
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
+tangential_detection_curve_file = ./DATA/courbe_eros_nodes # file containing the curve delimiting the velocity model
-# parameters concerning partitionning
+# parameters concerning partitioning
nproc = 8 # number of processes
-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.
+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.
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
@@ -50,6 +51,7 @@
Mzz = 1. # Mzz component (for a moment tensor source only)
Mxz = 0. # Mxz component (for a moment tensor source only)
factor = 1.d10 # amplification factor
+force_normal_to_surface = .false. # angleforce normal to surface (external mesh and curve file needed)
# constants for attenuation
N_SLS = 2 # number of standard linear solids for attenuation
@@ -62,6 +64,7 @@
generate_STATIONS = .true. # creates a STATION file in ./DATA
nreceiverlines = 1 # number of receiver lines
anglerec = 0.d0 # angle to rotate components at receivers
+rec_normal_to_surface = .false. # base anglerec normal to surface (external mesh and curve file needed)
# first receiver line
nrec = 100 # number of receivers
Modified: seismo/2D/SPECFEM2D/branches/BIOT/DATA/STATIONS
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/DATA/STATIONS 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/DATA/STATIONS 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,2 +1 @@
-S0001 AA 2000.0000000 2933.3300000 0.0 0.0
-S0002 AA 2000.0000000 1866.6700000 0.0 0.0
+S0001 AA 7500.0000000 2500.0000000 0.0 0.0
Modified: seismo/2D/SPECFEM2D/branches/BIOT/Makefile
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/Makefile 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/Makefile 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,15 +1,13 @@
#========================================================================
#
-# S P E C F E M 2 D Version 6.3
+# S P E C F E M 2 D Version 5.2
# ------------------------------
#
-# Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+# Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -44,51 +42,76 @@
SHELL=/bin/sh
+# uncomment this to generate ParaVer traces on MareNostrum in Barcelona
+#MPITRACE_HOME = /gpfs/apps/CEPBATOOLS/mpitrace-devel/64
+#PAPI_HOME = /gpfs/apps/PAPI/3.2.1-970mp/64
+#PERFCTR_HOME = /gpfs/apps/PAPI/papi-3.2.1-970mp/64
+
O = obj
# Portland
+#F90 = pgf90
#F90 = /opt/openmpi-1.2.2/pgi64/bin/mpif90 -DUSE_MPI -DUSE_METIS -DUSE_SCOTCH
-#F90 = pgf90
#CC = pgcc
#FLAGS_NOCHECK=-fast -Mnobounds -Minline -Mneginfo -Mdclchk -Knoieee -Minform=warn -fastsse -tp amd64e -Msmart
#FLAGS_CHECK=-fast -Mbounds -Mneginfo -Mdclchk -Minform=warn
-# Intel
+# Intel (leave option -ftz, which is *critical* for performance)
+# 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
+#F90 = mpif90 -DUSE_MPI -DUSE_METIS -DUSE_SCOTCH
#CC = gcc
-#FLAGS_NOCHECK=-O0 -implicitnone -warn stderrors -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -assume byterecl -check nobounds
+#FLAGS_NOCHECK=-O3 -xP -vec-report0 -e95 -std95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check nobounds -align sequence -assume byterecl -fpe3 -ftz
#FLAGS_CHECK = $(FLAGS_NOCHECK)
# GNU gfortran
+#F90 = gfortran
+#F90 = mpif90 -DUSE_MPI -DUSE_METIS -DUSE_SCOTCH
#F90 = /opt/openmpi-1.2.1/gfortran64/bin/mpif90 -DUSE_MPI -DUSE_METIS -DUSE_SCOTCH
+#CC = gcc
+##FLAGS_NOCHECK = -O3 -march=opteron -m64 -mfpmath=sse,387
+#FLAGS_NOCHECK = -std=f95 -fimplicit-none -frange-check -O3 -fmax-errors=10 -pedantic -pedantic-errors -Waliasing -Wampersand -Wcharacter-truncation -Wline-truncation -Wsurprising -Wno-tabs -Wunderflow -fno-trapping-math # -mcmodel=medium
+#FLAGS_CHECK = $(FLAGS_NOCHECK) -fbounds-check
+
+# GNU gfortran (yucca)
+#F90 = /opt/openmpi-1.2.1/gfortran64/bin/mpif90 -DUSE_MPI -DUSE_METIS -DUSE_SCOTCH
F90 = gfortran
CC = gcc
-#FLAGS_NOCHECK = -O3 -march=opteron -m64 -mfpmath=sse,387
FLAGS_NOCHECK = -std=gnu -fimplicit-none -frange-check -O2 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow
FLAGS_CHECK = $(FLAGS_NOCHECK) -fbounds-check
# IBM
-#F90 = xlf_r
-#CC = xlc -q64
-#FLAGS_NOCHECK = -qextname=attenuation_compute_param -O3 -qsave -qstrict -q64 -qtune=ppc970 -qarch=ppc64v -qcache=auto -qfree=f90 -Q -qsuffix=f=f90 -qhalt=w -qflttrap=en:ov:zero:inv -qfullpath -qsigtrap
-#FLAGS_CHECK = $(FLAGS_NOCHECK) -qddim
+#####F90 = xlf_r
+#F90 = mpif90 -WF,-DUSE_MPI,-DUSE_METIS
+#CC = xlc -g -q64
+# uncomment this to generate ParaVer traces on MareNostrum in Barcelona
+#FLAGS_NOCHECK_ADD = -L$(MPITRACE_HOME)/lib -lmpitracef -lxml2 -L${PAPI_HOME}/lib -lpapi -lperfctr
+#FLAGS_NOCHECK = $(FLAGS_NOCHECK_ADD) -qextname=attenuation_compute_param -O3 -qstrict -q64 -qtune=ppc970 -qarch=ppc970 -qcache=auto -qfree=f90 -Q -qsuffix=f=f90 -qhalt=w -qflttrap=overflow:zerodivide:invalid:enable -qfullpath
+#####FLAGS_NOCHECK = $(FLAGS_NOCHECK_ADD) -qextname=attenuation_compute_param -O3 -qstrict -q64 -qtune=ppc970 -qarch=ppc970 -qcache=auto -qfree=f90 -qsuffix=f=f90 -qhalt=w -qflttrap=overflow:zerodivide:invalid:enable -qinitauto=7FBFFFFF -C # -qlanglvl=2003pure
+#####FLAGS_NOCHECK = $(FLAGS_NOCHECK_ADD) -qextname=attenuation_compute_param -O0 -q64 -qtune=ppc970 -qarch=ppc970 -qcache=auto -qfree=f90 -qsuffix=f=f90 -qhalt=w -qflttrap=overflow:zerodivide:invalid:enable -qinitauto=7FBFFFFF -C -g -qfullpath -qlinedebug
+#FLAGS_CHECK = $(FLAGS_NOCHECK)
+#LIB = /opt/metis-4.0/gcc64/lib/libmetis.a /opt/scotch-4.0/gcc64/lib/libscotch.a /opt/scotch-4.0/gcc64/lib/libscotcherr.a
+# uncomment this to use Metis on MareNostrum in Barcelona
+#LIB = /home/hpce08/hpce08548/utils/metis-4.0/libmetis.a
+
LINK = $(F90)
-#LIB = /opt/metis-4.0/gcc64/lib/libmetis.a /opt/scotch-4.0/gcc64/lib/libscotch.a /opt/scotch-4.0/gcc64/lib/libscotcherr.a
-LIB =
-
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_solid.o $O/compute_forces_fluid.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/attenuation_compute_param.o $O/compute_Bielak_conditions.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/get_perm_cuthill_mckee.o
default: clean meshfem2D specfem2D convolve_source_timefunction
@@ -179,7 +202,7 @@
### 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
@@ -187,7 +210,7 @@
### 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
${F90} $(FLAGS_NOCHECK) -c -o $O/compute_gradient_attenuation.o compute_gradient_attenuation.f90
@@ -201,6 +224,9 @@
$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
@@ -209,7 +235,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
@@ -222,7 +248,7 @@
$O/write_seismograms.o: write_seismograms.F90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/write_seismograms.o write_seismograms.F90
-$O/part_unstruct.o: part_unstruct.F90 constants_unstruct.h
+$O/part_unstruct.o: part_unstruct.F90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/part_unstruct.o part_unstruct.F90
$O/construct_acoustic_surface.o: construct_acoustic_surface.f90 constants.h
@@ -233,3 +259,16 @@
$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 constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/is_in_convex_quadrilateral.o is_in_convex_quadrilateral.f90
+
+$O/get_perm_cuthill_mckee.o: get_perm_cuthill_mckee.f90 constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/get_perm_cuthill_mckee.o get_perm_cuthill_mckee.f90
+
Modified: seismo/2D/SPECFEM2D/branches/BIOT/README_MANUAL.txt
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/README_MANUAL.txt 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/README_MANUAL.txt 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,18 +1,24 @@
+How to use SPECFEM2D:
+---------------------
+
+See file "todo_list_please_dont_remove.txt" for a list of known bugs, problems, or missing options.
+
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://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
+- 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
-- if you are using an external mesher (like GID or CUBIT), you should set "read_external_mesh" to true.
+- 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.
"nodes_coords_file" is the file containing the coordinates (x and z) of each nodes : number of nodes on the first line, then coordinates x and z on each line.
"materials_file" is the number of the material for every elements : an integer ranging from 1 to nbmodels on each line.
"free_surface_file" is the file describing the edges forming the acoustic free surface : number of edges on the first line, then on each line number of the element, number of nodes forming the free surface (1 for a point, 2 for an edge), the nodes forming the free surface for this element. If you do not want free surface, jusr put 0 on the first line.
"absorbing_surface_file" is the file describing the edges forming the absorbing boundaries : the format is the same as the "free_surface_file".
+ "tangential_detection_curve_file" contains points describing the envelope, used for source_normal_to_surface and rec_normal_to_surface. Should be fine grained, and ordained clockwise. Number of points on the first line, then (x,z) coordinates on each line.
- if you have compiled with MPI, you can specify the number of processes, and the partitioning method used to dispatch the elements on the processes. See the manual of METIS and SCOTCH for more informations on the partitioning strategies.
@@ -26,11 +32,51 @@
- if you set flag "assign_external_model" to .true. in DATA/Par_file, the velocity and density model that is given at the end of DATA/Par_file is then ignored and overwritten by the external velocity and density model that you define yourself in define_external_model.f90
+- when compiling with Intel ifort, use " -assume byterecl " option to create binary PNM images displaying the wave field
+
- 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, 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
+- 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
- there are a few useful scripts and Fortran routines in directory UTILS
- if you find bugs (or if you have comments or suggestions) please send an email to cig-seismo AT geodynamics.org and the developers will try to fix them and send you an updated version
+--------------------------
+
+Regarding the structure of some of the database files:
+
+Question: Can anyone tell me what the columns of the SPECFEM2D-5.2.2 boundary
+condition files in SPECFEM2D-5.2.2/DATA/Mesh_canyon are?
+
+SPECFEM2D-5.2.2/DATA/Mesh_canyoncanyon_absorbing_surface_file
+SPECFEM2D-5.2.2/DATA/Mesh_canyoncanyon_free_surface_file
+
+Answer: "canyon_absorbing_surface_file" refers to parameters related to the
+absorbing conditions:
+The first number (180) is the number of absorbing elements (nelemabs in the
+code).
+Then the columns are:
+column 1 = the element number
+column 2 = the number of nodes of this element that form the absorbing surface
+column 3 = the first node
+column 4 = the second node
+
+"canyon_free_surface_file" refers to the elements of the free surface
+(relevant for enforcing free surface condition for acoustic media):
+The first number (160) is the number of elements of the free surface.
+Then the columns are (similar to the absorbing case):
+column 1 = the element number
+column 2 = the number of nodes of this element that form the absorbing surface
+column 3 = the first node
+column 4 = the second node
+
+Concerning the free surface description file, nodes/edges pertaining to
+elastic elements are discarded when the file is read (if for whatever
+reason it was simpler to include all the nodes/edges on one side of a
+studied area and that there are among them some elements that are
+elastic elements, only the nodes/edges of acoustic elements are kept).
+
+These files are opened and read in meshfem2D.F90 using subroutines
+read_abs_surface and read_acoustic_surface, which are in part_unstruct.F90
+
Modified: seismo/2D/SPECFEM2D/branches/BIOT/README_POROELASTIC.txt
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/README_POROELASTIC.txt 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/README_POROELASTIC.txt 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,19 +1,37 @@
Extra README:
addresses the modifications to the code to run adjoint and poroelastic simulations. [09/10/08]
+updated [07/30/09]
---------------------------------
NEW INPUTS IN Par_file
---------------------------------
+In section "# geometry of model and mesh description":
+TURN_VISCATTENUATION_ON, Q0, and FREQ0 deal with viscous damping in a poroelastic medium.
+Q0 is the quality factor set at the central frequency FREQ0. For more details
+see Morency & Tromp, GJI 2008.
+
In section "# time step parameters":
ISOLVER defines the type of simulations
(1) forward simulation
(2) adjoint method and kernels calculation
+In section "# source parameters":
+The code now support multi sources.
+NSOURCE is the number of source.
+Parameters of the sources are displayed in the file CMTSOLUTION, which must be
+in the directory DATA.
+
In section "# receiver line parameters for seismograms":
SAVE_FORWARD determines if the last frame of a forward simulation is saved (.true.) or not (.false)
In section "# define models....":
-Contrary to the previous version, we don't define density and velocity, but:
+Three types of models:
+I: (model_number,1,rho,Vp,Vs,0,0,Qp,Qs,0,0,0,0,0,0), for isotropic elastic/acoustic
+material
+or II: (model_number,2,rho,c11,c13,c33,c44,Qp,Qs,0,0,0,0,0,0), for anisotropic material
+or III: (model_number,3,rhos,rhof,phi,c,kxx,kxz,kzz,Ks,Kf,Kfr,etaf,mufr,Qs),
+for isotropic poroelastic material
+
rho_s = solid density
rho_f = fluid density
phi = porosity
@@ -24,12 +42,10 @@
kappa_s = solid bulk modulus
kappa_f= fluid bulk modulus
kappa_fr= frame bulk modulus
-mu_s = solid shear modulus
eta_f = fluid viscosity
mu_fr = frame shear modulus
+Qs = shear quality factor
-Set the porosity phi to 1 to make a given model acoustic [then edit rho_f,
-kappa_f], and to 0 to make it elastic [then edit rho_s, kappa_s, mu_s]
Note: for the poroelastic case, mu_s is irrelevant.
For details on the poroelastic theory see Morency and Tromp, GJI 2008.
@@ -59,13 +75,12 @@
Edit to update NSTEP, nrec, t0, deltat, and the position of the cut to pic
any given phase if needed (tstart,tend), add the right number of stations, and
put one component of the source to zero if needed.
-
-The ouput files are S****.AA.BHX.adj and S****.AA.BHZ.adj. They need to be
+The ouput files of adj_seismogram.f90 are S****.AA.BHX.adj and S****.AA.BHZ.adj. They need to be
kept in the OUTPUT_FILES directory together with the absorb_elastic_****.bin
-files to be read when running the "adjoint" simulation.
+and lastframe_elastic.bin files to be read when running the adjoint simulation.
-Third: run the "adjoint" simulation
-Make sure that the adjoint source files and the absorbing boundaries files are
+Third: run the adjoint simulation
+Make sure that the adjoint source files absorbing boundaries and last frame files are
in the OUTPUT_FILES directory.
=> isolver = 2
=> save_forward = .false.
@@ -73,13 +88,22 @@
Output_files (for example for the elastic case)
snapshot_rho_kappa_mu*****
snapshot_rhop_alpha_beta*****
-which are the moduli kernels and the phase velocities kernels respectively.
+which are the primary moduli kernels and the phase velocities kernels respectively.
Edit and use plot_snapshot.csh located in UTILS/adjoint to generate kernels
plot.
+Note: At the moment, adjoint simulations do not support anisotropy, attenuation, and viscous damping.
+--------------------------------------------------
+ COUPLED SIMULATIONS
+--------------------------------------------------
+The code support acoustic/elastic, acoustic/poroelastic, elastic/poroelastic,
+and acoustic,elastic/poroelastic simulations.
+elastic/poroelastic coupling support anisotropy, but not attenuation for the
+elastic material.
+
Modified: seismo/2D/SPECFEM2D/branches/BIOT/UTILS/adjoint/adj_seismogram.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/UTILS/adjoint/adj_seismogram.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/UTILS/adjoint/adj_seismogram.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -4,12 +4,14 @@
! into the adjoint source for generating banana-dougnut kernels
implicit none
-
- integer, parameter :: NSTEP = 3000
+!
+! user edit
+ integer, parameter :: NSTEP = 6000
integer, parameter :: nrec = 1
- double precision, parameter :: t0 = 6d-2
- double precision, parameter :: deltat = 2d-4
+ double precision, parameter :: t0 = 0.4
+ double precision, parameter :: deltat = 1d-3
double precision, parameter :: EPS = 1.d-40
+!
integer :: itime,icomp,istart,iend,nlen,irec
double precision :: time,tstart(nrec),tend(nrec)
character(len=150), dimension(nrec) :: station_name
@@ -21,9 +23,11 @@
include 'constants.h'
+! user edit
station_name(1) = 'S0001'
- tstart(1) = 0.031d0 + t0
- tend(1) = 0.121d0 + t0
+ tstart(1) = 3.5d0 + t0
+ tend(1) = 4.3d0 + t0
+!
comp = (/"BHX","BHZ"/)
@@ -90,10 +94,10 @@
ft_bar(:) = 0.d0
endif
+! user edit: which component
do itime =1,NSTEP
if(icomp == 1) then
write(11,*) (itime-1)*deltat - t0, ft_bar(itime)
-! write(12,*) (itime-1)*deltat - t0, seism_veloc(itime)
else
write(11,*) (itime-1)*deltat - t0, 0.d0
endif
@@ -101,7 +105,6 @@
enddo
close(11)
-! close(12)
enddo
Modified: seismo/2D/SPECFEM2D/branches/BIOT/UTILS/adjoint/plot_snapshot.csh
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/UTILS/adjoint/plot_snapshot.csh 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/UTILS/adjoint/plot_snapshot.csh 2009-07-30 21:33:24 UTC (rev 15488)
@@ -2,15 +2,15 @@
makecpt -Cseis -T-1.110e-07/1.110e-07/2.018e-08 > color.cpt
sed 's/^N.*/N 255 255 255/' color.cpt > color1.cpt
sed 's/^B.*/B 255 255 255/' color1.cpt > color.cpt
-echo OUTPUT_FILES/snapshot_ho_rhof_0003600
+echo OUTPUT_FILES/snapshot_rho_kappa_mu_0003000
psxy -JX6i/2i -R0/1/0/1 -X3 -Y-3 -K -V -P <<EOF >plot_01.ps
EOF
-awk '{print $1,$2,$3 * 1}' OUTPUT_FILES/snapshot_rho_kappa_mu0003000 | pscontour -JX6i/2i -R0/1/0/1 -B0.5/0.1:."rho":WeSn -A- -Ccolor.cpt -I -K -O -V -Y8 -P>> plot_01.ps
+awk '{print $1,$2,$3 * 1}' OUTPUT_FILES/snapshot_rho_kappa_mu_0003000 | pscontour -JX6i/2i -R0/1/0/1 -B0.5/0.1:."rho":WeSn -A- -Ccolor.cpt -I -K -O -V -Y8 -P>> plot_01.ps
echo Fig ok
psscale -Ccolor.cpt -D3i/-0.5i/5c/0.1h -B9.99e-06 -K -O -P >> plot_01.ps
-awk '{print $1,$2,$4 * 1}' OUTPUT_FILES/snapshot_rho_kappa_mu0003000 | pscontour -JX6i/2i -R0/1/0/1 -B0.5/0.1:."kappa":WeSn -A- -Ccolor.cpt -I -K -O -V -Y8 -P>> plot_01.ps
+awk '{print $1,$2,$4 * 1}' OUTPUT_FILES/snapshot_rho_kappa_mu_0003000 | pscontour -JX6i/2i -R0/1/0/1 -B0.5/0.1:."kappa":WeSn -A- -Ccolor.cpt -I -K -O -V -Y8 -P>> plot_01.ps
echo Fig ok
-awk '{print $1,$2,$5 * 1}' OUTPUT_FILES/snapshot_rho_kappa_mu0003000 | pscontour -JX6i/2i -R0/1/0/1 -B0.5/0.1:."mu":WeSn -A- -Ccolor.cpt -I -K -O -V -Y8 -P>> plot_01.ps
+awk '{print $1,$2,$5 * 1}' OUTPUT_FILES/snapshot_rho_kappa_mu_0003000 | pscontour -JX6i/2i -R0/1/0/1 -B0.5/0.1:."mu":WeSn -A- -Ccolor.cpt -I -K -O -V -Y8 -P>> plot_01.ps
echo Fig ok
pstext -JX -R -K -O -P -N >>plot_01.ps<<EOF
0.6 0.45 20 0 4 RM time = ? s
Modified: seismo/2D/SPECFEM2D/branches/BIOT/assemble_MPI.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/assemble_MPI.F90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/assemble_MPI.F90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,15 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 6.3
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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,8 +41,8 @@
!========================================================================
!
-! This file contains subroutines related to assembling (of the mass matrix, potential_dot_dot,
-! accel_elastic, accels_poroelastic and accelw_poroelastic).
+! This file contains subroutines related to assembling (of the mass matrix, potential_dot_dot and
+! accel_elastic, accels_poroelastic, accelw_poroelastic).
! These subroutines are for the most part not used in the sequential version.
!
@@ -53,18 +51,18 @@
! build the communication buffers, and determines which elements are considered 'inner'
! (no points in common with other partitions) and 'outer' (at least one point in common
! with neighbouring partitions).
-! We have both acoustic and elastic buffers, for coupling between acoustic and elastic elements
+! We have both acoustic and (poro)elastic buffers, for coupling between acoustic and (poro)elastic elements
! led us to have two sets of communications.
!-----------------------------------------------
subroutine prepare_assemble_MPI (nspec,ibool, &
knods, ngnod, &
- npoin, elastic,poroelastic, &
+ npoin, elastic, poroelastic, &
ninterface, max_interface_size, &
my_nelmnts_neighbours, my_interfaces, &
- 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,&
+ 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 &
)
@@ -73,7 +71,7 @@
include 'constants.h'
integer, intent(in) :: nspec, npoin, ngnod
- logical, dimension(nspec), intent(in) :: elastic,poroelastic
+ logical, dimension(nspec), intent(in) :: elastic, poroelastic
integer, dimension(ngnod,nspec), intent(in) :: knods
integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
@@ -152,7 +150,7 @@
ibool_interfaces_elastic(npoin_interface_elastic,num_interface)=&
ibool(ix,iz,ispec)
end if
- elseif ( poroelastic(ispec) ) then
+ else if ( poroelastic(ispec) ) then
if(.not. mask_ibool_poroelastic(ibool(ix,iz,ispec))) then
mask_ibool_poroelastic(ibool(ix,iz,ispec)) = .true.
@@ -161,6 +159,7 @@
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.
npoin_interface_acoustic = npoin_interface_acoustic + 1
@@ -181,7 +180,7 @@
do ix = 1, NGLLX
if ( mask_ibool_acoustic(ibool(ix,iz,ispec)) &
.or. mask_ibool_elastic(ibool(ix,iz,ispec)) &
- .or. mask_ibool_poroelastic(ibool(ix,iz,ispec))) then
+ .or. mask_ibool_poroelastic(ibool(ix,iz,ispec)) ) then
mask_ispec_inner_outer(ispec) = .true.
endif
@@ -318,174 +317,14 @@
#ifdef USE_MPI
-
!-----------------------------------------------
-! Creation of persistent communication requests (send and recv) for acoustic elements.
-! Should be disposed of if using Paraver (with MPItrace), since it does not instrument persistent
-! communications yet.
-!-----------------------------------------------
-subroutine 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 &
- )
-
- implicit none
-
- include 'constants.h'
- include 'mpif.h'
- include 'precision_mpi.h'
-
- integer, intent(in) :: ninterface, ninterface_acoustic
- integer, dimension(ninterface), intent(in) :: inum_interfaces_acoustic
- integer, intent(in) :: max_ibool_interfaces_size_ac
- real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(in) :: &
- buffer_send_faces_vector_ac
- real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(in) :: &
- buffer_recv_faces_vector_ac
- integer, dimension(ninterface_acoustic*2), intent(inout) :: tab_requests_send_recv_acoustic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic
- integer, dimension(ninterface), intent(in) :: my_neighbours
-
- integer :: inum_interface,num_interface
- integer :: ier
-
- do inum_interface = 1, ninterface_acoustic
-
- num_interface = inum_interfaces_acoustic(inum_interface)
-
- call MPI_Send_init ( buffer_send_faces_vector_ac(1,inum_interface), &
- nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_acoustic(inum_interface), ier)
- call MPI_Recv_init ( buffer_recv_faces_vector_ac(1,inum_interface), &
- nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_acoustic(ninterface_acoustic+inum_interface), ier)
- end do
-
-end subroutine create_MPI_req_SEND_RECV_ac
-
-
-!-----------------------------------------------
-! Creation of persistent communication requests (send and recv) for elastic elements.
-! Should be disposed of if using Paraver (with MPItrace), since it does not instrument persistent
-! communications yet.
-!-----------------------------------------------
-subroutine 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 &
- )
-
- implicit none
-
- include 'constants.h'
- include 'mpif.h'
- include 'precision_mpi.h'
-
-
- integer, intent(in) :: ninterface, ninterface_elastic
- integer, dimension(ninterface), intent(in) :: inum_interfaces_elastic
- integer, intent(in) :: max_ibool_interfaces_size_el
- real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_el,ninterface_elastic), intent(in) :: &
- buffer_send_faces_vector_el
- real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_el,ninterface_elastic), intent(in) :: &
- buffer_recv_faces_vector_el
- integer, dimension(ninterface_elastic*2), intent(inout) :: tab_requests_send_recv_elastic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_elastic
- integer, dimension(ninterface), intent(in) :: my_neighbours
-
- integer :: inum_interface,num_interface
- integer :: ier
-
- do inum_interface = 1, ninterface_elastic
-
- num_interface = inum_interfaces_elastic(inum_interface)
-
- call MPI_Send_init ( buffer_send_faces_vector_el(1,inum_interface), &
- NDIM*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 13, MPI_COMM_WORLD, &
- tab_requests_send_recv_elastic(inum_interface), ier)
- call MPI_Recv_init ( buffer_recv_faces_vector_el(1,inum_interface), &
- NDIM*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 13, MPI_COMM_WORLD, &
- tab_requests_send_recv_elastic(ninterface_elastic+inum_interface), ier)
- end do
-
-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, 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)
+ 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
@@ -493,18 +332,19 @@
include 'mpif.h'
! array to assemble
- real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1, array_val2, array_val3, array_val4
+ 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, max_ibool_interfaces_size_po
+ 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,ibool_interfaces_poroelastic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_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+2*max_ibool_interfaces_size_po, ninterface) :: &
+ double precision, dimension(max_ibool_interfaces_size_ac+max_ibool_interfaces_size_el, ninterface) :: &
buffer_send_faces_scalar, &
buffer_recv_faces_scalar
integer :: msg_status(MPI_STATUS_SIZE)
@@ -534,15 +374,15 @@
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)+2*nibool_interfaces_poroelastic(num_interface),&
+ call MPI_ISSEND( buffer_send_faces_scalar(1,num_interface), &
+ nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface)+&
+ nibool_interfaces_poroelastic(num_interface)+nibool_interfaces_poroelastic(num_interface), &
MPI_DOUBLE_PRECISION, &
my_neighbours(num_interface), 11, &
MPI_COMM_WORLD, msg_requests(num_interface), ier)
@@ -551,7 +391,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)+2*nibool_interfaces_poroelastic(num_interface),&
+ nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface)+&
+ nibool_interfaces_poroelastic(num_interface)+nibool_interfaces_poroelastic(num_interface), &
MPI_DOUBLE_PRECISION, &
my_neighbours(num_interface), 11, &
MPI_COMM_WORLD, msg_status(1), ier)
@@ -574,7 +415,6 @@
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)) + &
@@ -590,25 +430,34 @@
!-----------------------------------------------
! Assembling potential_dot_dot for acoustic 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).
+! the buffers are filled, the Isend and Irecv are started here, then
+! contributions are added.
+! The previous version included communication overlap using persistent
+! communication, but the merging of the outer and inner elements rendered
+! overlap no longer possible, while persistent communications were removed
+! because trace tool MPITrace does not yet instrument those.
+! Particular care should be taken concerning possible optimisations of the
+! communication scheme.
!-----------------------------------------------
-subroutine assemble_MPI_vector_ac_start(array_val1,npoin, &
+subroutine assemble_MPI_vector_ac(array_val1,npoin, &
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 &
+ buffer_send_faces_vector_ac, &
+ buffer_recv_faces_vector_ac, &
+ my_neighbours &
)
implicit none
include 'constants.h'
include 'mpif.h'
+ include 'precision_mpi.h'
! array to assemble
- real(kind=CUSTOM_REAL), dimension(npoin), intent(in) :: array_val1
+ real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1
integer, intent(in) :: npoin
integer, intent(in) :: ninterface, ninterface_acoustic
@@ -620,9 +469,13 @@
integer, dimension(ninterface_acoustic*2), intent(inout) :: tab_requests_send_recv_acoustic
real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(inout) :: &
buffer_send_faces_vector_ac
+ real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(inout) :: &
+ buffer_recv_faces_vector_ac
+ integer, dimension(ninterface), intent(in) :: my_neighbours
integer :: ipoin, num_interface, inum_interface
integer :: ier
+ integer, dimension(MPI_STATUS_SIZE) :: status_acoustic
integer :: i
@@ -639,39 +492,82 @@
end do
- do inum_interface = 1, ninterface_acoustic*2
- call MPI_START(tab_requests_send_recv_acoustic(inum_interface), ier)
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_start unsuccessful in assemble_MPI_vector_start')
- end if
+ do inum_interface = 1, ninterface_acoustic
+
+ num_interface = inum_interfaces_acoustic(inum_interface)
+
+ call MPI_ISSEND( buffer_send_faces_vector_ac(1,inum_interface), &
+ nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_acoustic(inum_interface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_start')
+ end if
+
+ call MPI_Irecv ( buffer_recv_faces_vector_ac(1,inum_interface), &
+ nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_acoustic(ninterface_acoustic+inum_interface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector')
+ end if
+
end do
-!call MPI_Startall ( ninterface*2, tab_requests_send_recv(1), ier )
+ do inum_interface = 1, ninterface_acoustic*2
-end subroutine assemble_MPI_vector_ac_start
+ call MPI_Wait (tab_requests_send_recv_acoustic(inum_interface), status_acoustic, ier)
+ enddo
+ do inum_interface = 1, ninterface_acoustic
+
+ num_interface = inum_interfaces_acoustic(inum_interface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_acoustic(num_interface)
+ ipoin = ipoin + 1
+ array_val1(ibool_interfaces_acoustic(i,num_interface)) = array_val1(ibool_interfaces_acoustic(i,num_interface)) + &
+ buffer_recv_faces_vector_ac(ipoin,inum_interface)
+ end do
+
+ end do
+
+end subroutine assemble_MPI_vector_ac
+
+
!-----------------------------------------------
! Assembling accel_elastic for elastic 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).
+! the buffers are filled, the Isend and Irecv are started here, then
+! contributions are added.
+! The previous version included communication overlap using persistent
+! communication, but the merging of the outer and inner elements rendered
+! overlap no longer possible, while persistent communications were removed
+! because trace tool MPITrace does not yet instrument those.
+! Particular care should be taken concerning possible optimisations of the
+! communication scheme.
!-----------------------------------------------
-subroutine assemble_MPI_vector_el_start(array_val2,npoin, &
+subroutine assemble_MPI_vector_el(array_val2,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 &
+ buffer_send_faces_vector_el, &
+ buffer_recv_faces_vector_el, &
+ my_neighbours &
)
implicit none
include 'constants.h'
include 'mpif.h'
+ include 'precision_mpi.h'
! array to assemble
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(in) :: array_val2
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(inout) :: array_val2
integer, intent(in) :: npoin
integer, intent(in) :: ninterface, ninterface_elastic
@@ -683,10 +579,13 @@
integer, dimension(ninterface_elastic*2), intent(inout) :: tab_requests_send_recv_elastic
real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_el,ninterface_elastic), intent(inout) :: &
buffer_send_faces_vector_el
+ real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_el,ninterface_elastic), intent(inout) :: &
+ buffer_recv_faces_vector_el
+ integer, dimension(ninterface), intent(in) :: my_neighbours
-
integer :: ipoin, num_interface, inum_interface
integer :: ier
+ integer, dimension(MPI_STATUS_SIZE) :: status_elastic
integer :: i
@@ -704,38 +603,82 @@
end do
+ do inum_interface = 1, ninterface_elastic
+
+ num_interface = inum_interfaces_elastic(inum_interface)
+
+ call MPI_ISSEND( buffer_send_faces_vector_el(1,inum_interface), &
+ NDIM*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_elastic(inum_interface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_el')
+ end if
+
+ call MPI_Irecv ( buffer_recv_faces_vector_el(1,inum_interface), &
+ NDIM*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_elastic(ninterface_elastic+inum_interface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_el')
+ end if
+
+ end do
+
do inum_interface = 1, ninterface_elastic*2
- call MPI_START(tab_requests_send_recv_elastic(inum_interface), ier)
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_start unsuccessful in assemble_MPI_vector_start')
- end if
+
+ call MPI_Wait (tab_requests_send_recv_elastic(inum_interface), status_elastic, ier)
+
+ enddo
+
+ do inum_interface = 1, ninterface_elastic
+
+ num_interface = inum_interfaces_elastic(inum_interface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_elastic(num_interface)
+ array_val2(:,ibool_interfaces_elastic(i,num_interface)) = array_val2(:,ibool_interfaces_elastic(i,num_interface)) + &
+ buffer_recv_faces_vector_el(ipoin+1:ipoin+2,inum_interface)
+ ipoin = ipoin + 2
+ end do
+
end do
-!call MPI_Startall ( ninterface*2, tab_requests_send_recv(1), ier )
+end subroutine assemble_MPI_vector_el
-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).
+! Assembling accel_elastic for elastic elements :
+! the buffers are filled, the Isend and Irecv are started here, then
+! contributions are added.
+! The previous version included communication overlap using persistent
+! communication, but the merging of the outer and inner elements rendered
+! overlap no longer possible, while persistent communications were removed
+! because trace tool MPITrace does not yet instrument those.
+! Particular care should be taken concerning possible optimisations of the
+! communication scheme.
!-----------------------------------------------
-subroutine assemble_MPI_vector_po_start(array_val3,array_val4,npoin, &
+subroutine assemble_MPI_vector_po(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&
+ buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
+ my_neighbours &
)
implicit none
include 'constants.h'
include 'mpif.h'
+ include 'precision_mpi.h'
! array to assemble
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(in) :: array_val3,array_val4
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(inout) :: array_val3,array_val4
integer, intent(in) :: npoin
integer, intent(in) :: ninterface, ninterface_poroelastic
@@ -744,13 +687,16 @@
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
+ integer, dimension(ninterface_elastic*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
+ real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(inout) :: &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow
+ integer, dimension(ninterface), intent(in) :: my_neighbours
-
integer :: ipoin, num_interface, inum_interface
integer :: ier
+ integer, dimension(MPI_STATUS_SIZE) :: status_poroelastic
integer :: i
@@ -763,187 +709,66 @@
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
-! for the points on the interfaces.
-!-----------------------------------------------
-subroutine assemble_MPI_vector_ac_wait(array_val1,npoin, &
- 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 &
- )
-
- implicit none
-
- include 'constants.h'
- include 'mpif.h'
-
- ! array to assemble
- real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1
-
- integer, intent(in) :: npoin
- integer, intent(in) :: ninterface, ninterface_acoustic
- integer, dimension(ninterface), intent(in) :: inum_interfaces_acoustic
- integer, intent(in) :: max_interface_size
- integer, intent(in) :: max_ibool_interfaces_size_ac
- integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_acoustic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic
- integer, dimension(ninterface_acoustic*2), intent(inout) :: tab_requests_send_recv_acoustic
- real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(inout) :: &
- buffer_recv_faces_vector_ac
-
- integer :: ipoin, num_interface, inum_interface
- integer :: ier
- integer, dimension(MPI_STATUS_SIZE,ninterface_acoustic*2) :: tab_statuses_acoustic
-
- integer :: i
-
- call MPI_Waitall ( ninterface_acoustic*2, tab_requests_send_recv_acoustic(1), tab_statuses_acoustic(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_acoustic
-
- num_interface = inum_interfaces_acoustic(inum_interface)
-
ipoin = 0
- do i = 1, nibool_interfaces_acoustic(num_interface)
- ipoin = ipoin + 1
- array_val1(ibool_interfaces_acoustic(i,num_interface)) = array_val1(ibool_interfaces_acoustic(i,num_interface)) + &
- buffer_recv_faces_vector_ac(ipoin,inum_interface)
+ do i = 1, nibool_interfaces_poroelastic(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
-end subroutine assemble_MPI_vector_ac_wait
+ do inum_interface = 1, ninterface_poroelastic
+ num_interface = inum_interfaces_poroelastic(inum_interface)
-!-----------------------------------------------
-! Assembling accel_elastic for elastic elements :
-! We wait for the completion of the communications, and add the contributions received
-! for the points on the interfaces.
-!-----------------------------------------------
-subroutine assemble_MPI_vector_el_wait(array_val2,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 &
- )
+ call MPI_ISSEND( buffer_send_faces_vector_pos(1,inum_interface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poroelastic(inum_interface), ier)
- implicit none
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pos')
+ end if
- include 'constants.h'
- include 'mpif.h'
+ call MPI_Irecv ( buffer_recv_faces_vector_pos(1,inum_interface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poroelastic(ninterface_poroelastic+inum_interface), ier)
- ! array to assemble
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(inout) :: array_val2
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pos')
+ end if
- integer, intent(in) :: npoin
- integer, intent(in) :: ninterface, ninterface_elastic
- integer, dimension(ninterface), intent(in) :: inum_interfaces_elastic
- integer, intent(in) :: max_interface_size
- integer, intent(in) :: max_ibool_interfaces_size_el
- integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_elastic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_elastic
- integer, dimension(ninterface_elastic*2), intent(inout) :: tab_requests_send_recv_elastic
- real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_el,ninterface_elastic), intent(inout) :: &
- buffer_recv_faces_vector_el
+ call MPI_ISSEND( buffer_send_faces_vector_pow(1,inum_interface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poroelastic(ninterface_poroelastic*2+inum_interface), ier)
- integer :: ipoin, num_interface, inum_interface
- integer :: ier
- integer, dimension(MPI_STATUS_SIZE,ninterface_elastic*2) :: tab_statuses_elastic
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pow')
+ end if
- integer :: i
+ call MPI_Irecv ( buffer_recv_faces_vector_pow(1,inum_interface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poroelastic(ninterface_poroelastic*3+inum_interface), ier)
- call MPI_Waitall ( ninterface_elastic*2, tab_requests_send_recv_elastic(1), tab_statuses_elastic(1,1), ier )
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_WAITALL unsuccessful in assemble_MPI_vector_wait')
- end if
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pow')
+ end if
- do inum_interface = 1, ninterface_elastic
-
- num_interface = inum_interfaces_elastic(inum_interface)
-
- ipoin = 0
- do i = 1, nibool_interfaces_elastic(num_interface)
- array_val2(:,ibool_interfaces_elastic(i,num_interface)) = array_val2(:,ibool_interfaces_elastic(i,num_interface)) + &
- buffer_recv_faces_vector_el(ipoin+1:ipoin+2,inum_interface)
- ipoin = ipoin + 2
- end do
-
end do
-end subroutine assemble_MPI_vector_el_wait
+ do inum_interface = 1, ninterface_poroelastic*4
-!-----------------------------------------------
-! 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 &
- )
+ call MPI_Wait (tab_requests_send_recv_elastic(inum_interface), status_poroelastic, ier)
- implicit none
+ enddo
- 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)
@@ -952,20 +777,25 @@
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)
+ ipoin = ipoin + 2
+ end do
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_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
+end subroutine assemble_MPI_vector_po
#endif
+
!-----------------------------------------------
-! Dummy subroutine, to be able to stop the code whether sequential or parallel.
+! subroutine to stop the code whether sequential or parallel.
!-----------------------------------------------
subroutine exit_MPI(error_msg)
Modified: seismo/2D/SPECFEM2D/branches/BIOT/attenuation_compute_param.c
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/attenuation_compute_param.c 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/attenuation_compute_param.c 2009-07-30 21:33:24 UTC (rev 15488)
@@ -17,12 +17,12 @@
#define PI2 6.28318530717958
/* Underscores should or should not follow this function name, depending on the compiler and its options.
- It is called in "attenuation_model.f90".
+ It is called in "attenuation_model.f90".
*/
-int attenuation_compute_param_(int *nmech_in, double *Qp_in, double *Qs_in, double *f1_in, double *f2_in,
- double *tau_sigma_nu1, double *tau_sigma_nu2,
- double *tau_epsilon_nu1, double *tau_epsilon_nu2
- )
+int attenuation_compute_param_(int *nmech_in, double *Qp_in, double *Qs_in, double *f1_in, double *f2_in,
+ double *tau_sigma_nu1, double *tau_sigma_nu2,
+ double *tau_epsilon_nu1, double *tau_epsilon_nu2
+ )
{
int xmgr, n, i, j, plot, nu;
@@ -120,35 +120,35 @@
/* output in Fortran90 format */
for (i = 1; i <= n; i++) {
- /*
+ /*
printf(" tau_sigma_nu%d(%1d) = %30.20lfd0\n", nu, i, tau_s[i]);
*/
/* We put the results in tau_sigma_nu to get them in fortran. */
if ( nu == 1 ) {
- tau_sigma_nu1[i-1] = tau_s[i];
+ tau_sigma_nu1[i-1] = tau_s[i];
}
if ( nu == 2 ) {
- tau_sigma_nu2[i-1] = tau_s[i];
+ tau_sigma_nu2[i-1] = tau_s[i];
}
-
- }
+
+ }
//printf("\n");
-
+
for (i = 1; i <= n; i++) {
/*
- printf(" tau_epsilon_nu%d(%1d) = %30.20lfd0\n", nu, i, tau_e[i]);
+ printf(" tau_epsilon_nu%d(%1d) = %30.20lfd0\n", nu, i, tau_e[i]);
*/
/* We put the results in tau_epsilon_nu to get them in fortran. */
if ( nu == 1 ) {
- tau_epsilon_nu1[i-1] = tau_e[i];
+ tau_epsilon_nu1[i-1] = tau_e[i];
}
if ( nu == 2 ) {
- tau_epsilon_nu2[i-1] = tau_e[i];
+ tau_epsilon_nu2[i-1] = tau_e[i];
}
-
+
}
//printf("\n");
-
+
free_dvector(tau_s, 1, n);
free_dvector(tau_e, 1, n);
Modified: seismo/2D/SPECFEM2D/branches/BIOT/attenuation_model.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/attenuation_model.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/attenuation_model.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/checkgrid.F90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,15 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 6.3
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -42,11 +40,10 @@
!
!========================================================================
- 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,any_poroelastic,myrank,nproc)
+ subroutine checkgrid(vpext,vsext,rhoext,density,poroelastcoef,porosity,tortuosity,ibool,kmato,coord,npoin, &
+ vpImin,vpImax,vpIImin,vpIImax,assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat, &
+ f0,t0,initialfield,time_function_type,coorg,xinterp,zinterp,shapeint,knods,simulation_title, &
+ npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,myrank,nproc,NSOURCE,poroelastic)
! check the mesh, stability and number of points per wavelength
@@ -57,6 +54,10 @@
include 'mpif.h'
#endif
+! option to display only part of the mesh and not the whole mesh,
+! for instance to analyze Cuthill-McKee mesh partitioning etc.
+ integer :: UPPER_LIMIT_DISPLAY
+
! color palette
integer, parameter :: NUM_COLORS = 236
double precision, dimension(NUM_COLORS) :: red,green,blue
@@ -65,27 +66,32 @@
integer :: icol
#endif
- integer i,j,ispec,material,npoin,nspec,numat,time_function_type
+ integer i,j,ispec,material,npoin,nspec,numat,NSOURCE
+ integer, dimension(NSOURCE) :: time_function_type
+
integer, dimension(nspec) :: kmato
+ logical, dimension(nspec) :: poroelastic
integer, dimension(NGLLX,NGLLX,nspec) :: ibool
double precision, dimension(2,numat) :: density
double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(numat) :: porosity,tortuosity
double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
double precision coord(NDIM,npoin)
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 kappa_s,kappa_f,kappa_fr,mu_s,mu_fr,denst_s,denst_f,denst,phi,tort,cpIloc,cpIIloc,csloc
double precision afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,cpIsquare,cpIIsquare,cssquare
+ double precision f0min,f0max
+ double precision lambdaplus2mu,mu
double precision distance_min,distance_max,distance_min_local,distance_max_local
- 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
-
+ double precision courant_stability_number_max,lambdaPImin,lambdaPImax,lambdaPIImin,lambdaPIImax, &
+ lambdaSmin,lambdaSmax
+ double precision deltat,distance_1,distance_2,distance_3,distance_4
+ double precision, dimension(NSOURCE) :: f0,t0
logical assign_external_model,initialfield,any_elastic,any_poroelastic
! for the stability condition
@@ -101,6 +107,7 @@
#ifdef USE_MPI
double precision :: vpImin_glob,vpImax_glob,vsmin_glob,vsmax_glob,densmin_glob,densmax_glob
double precision :: vpIImin_glob,vpIImax_glob
+ double precision :: densmin_glob,densmax_glob
double precision :: distance_min_glob,distance_max_glob
double precision :: courant_stability_max_glob,lambdaPImin_glob,lambdaPImax_glob,&
lambdaPIImin_glob,lambdaPIImax_glob,lambdaSmin_glob,lambdaSmax_glob
@@ -130,10 +137,11 @@
double precision coorg(NDIM,npgeo)
-
! title of the plot
character(len=60) simulation_title
+ if(UPPER_LIMIT_DISPLAY > nspec) stop 'cannot have UPPER_LIMIT_DISPLAY > nspec in checkgrid.F90'
+
#ifndef USE_MPI
allocate(coorg_recv(1,1))
allocate(RGB_recv(1))
@@ -146,7 +154,6 @@
deallocate(greyscale_recv)
#endif
-
! define percentage of smallest distance between GLL points for NGLLX points
! percentages were computed by calling the GLL points routine for each degree
percent_GLL(2) = 100.d0
@@ -169,7 +176,7 @@
if(NGLLX > NGLLX_MAX_STABILITY) then
call exit_MPI('cannot estimate the stability condition for that degree')
- end if
+ endif
! define color palette in random order
@@ -1366,7 +1373,7 @@
vsmin = 0
vsmax = 0
endif
-
+
if(any_poroelastic) then
vpIImin = HUGEVAL
vpIImax = -HUGEVAL
@@ -1393,7 +1400,7 @@
lambdaSmin = 0
lambdaSmax = 0
endif
-
+
if(any_poroelastic) then
lambdaPIImin = HUGEVAL
lambdaPIImax = -HUGEVAL
@@ -1405,7 +1412,8 @@
do ispec=1,nspec
material = kmato(ispec)
-
+
+ if(poroelastic(ispec)) then
phi = porosity(material)
tort = tortuosity(material)
!solid properties
@@ -1418,15 +1426,15 @@
!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
+ denst = (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
+ afactor = denst - phi/tort*denst_f
+ bfactor = H_biot + phi*denst/(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)
@@ -1435,14 +1443,15 @@
cpIloc = sqrt(cpIsquare)
cpIIloc = sqrt(cpIIsquare)
csloc = sqrt(cssquare)
+ else
+ mu = poroelastcoef(2,1,material)
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
- 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
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ cpIIloc = 0.d0
+ csloc = sqrt(mu/denst)
+ endif
vpImax_local = -HUGEVAL
vpImin_local = HUGEVAL
@@ -1460,7 +1469,7 @@
if(assign_external_model) then
cpIloc = vpext(i,j,ispec)
csloc = vsext(i,j,ispec)
- denst_bar = rhoext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
endif
!--- compute min and max of velocity and density models
@@ -1472,11 +1481,11 @@
vpIImax = max(vpIImax,cpIIloc)
! ignore fluid regions with Vs = 0
- if((assign_external_model .and. csloc > 0.0001d0) .or. (phi < 1.d0)) vsmin = min(vsmin,csloc)
+ if(csloc > 0.0001d0) vsmin = min(vsmin,csloc)
vsmax = max(vsmax,csloc)
- densmin = min(densmin,denst_bar)
- densmax = max(densmax,denst_bar)
+ densmin = min(densmin,denst)
+ densmax = max(densmax,denst)
vpImax_local = max(vpImax_local,vpImax)
vpImin_local = min(vpImin_local,vpImin)
@@ -1509,7 +1518,7 @@
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(phi < 1.d0) then
+ if(csloc > 0.0001d0) then
lambdaSmin = min(lambdaSmin,vsmin_local / (distance_max_local / (NGLLX - 1)))
lambdaSmax = max(lambdaSmax,vsmin_local / (distance_max_local / (NGLLX - 1)))
endif
@@ -1529,8 +1538,8 @@
#ifdef USE_MPI
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 (vpIImin, vpIImin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpIImax, 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)
@@ -1570,7 +1579,7 @@
if ( myrank == 0 ) then
write(IOUT,*)
write(IOUT,*) '********'
- write(IOUT,*) 'Model: PI velocity min,max = ',vpImin,vpImax
+ write(IOUT,*) 'Model: P (or 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
@@ -1586,32 +1595,44 @@
write(IOUT,*) '*** Min grid size = ',distance_min
write(IOUT,*) '*** Max/min ratio = ',distance_max/distance_min
write(IOUT,*)
- write(IOUT,*) '*** Max stability for P (or PI) wave velocity = ',courant_stability_number_max
+ write(IOUT,*) '*** Max stability for P wave velocity = ',courant_stability_number_max
write(IOUT,*)
! only if time source is not a Dirac or Heaviside (otherwise maximum frequency of spectrum undefined)
! and if source is not an initial field, for the same reason
- if(.not. initialfield .and. time_function_type /= 4 .and. time_function_type /= 5) then
+ if(.not. initialfield) then
+ f0max = -HUGEVAL
+ f0min = HUGEVAL
+ do i = 1,NSOURCE
+ if(time_function_type(i) /= 4 .and. time_function_type(i) /= 5) then
- write(IOUT,*) ' Onset time = ',t0
- write(IOUT,*) ' Fundamental period = ',1.d0/f0
- write(IOUT,*) ' Fundamental frequency = ',f0
- if(t0 <= 1.d0/f0) then
+ write(IOUT,*) ' Onset time = ',t0(i)
+ write(IOUT,*) ' Fundamental period = ',1.d0/f0(i)
+ write(IOUT,*) ' Fundamental frequency = ',f0(i)
+ if(f0(i) > f0max) f0max = f0(i)
+ if(f0(i) < f0min) f0min = f0(i)
+ if(t0(i) <= 1.d0/f0(i)) then
call exit_MPI('Onset time too small')
else
write(IOUT,*) ' --> onset time ok'
endif
+
+ if(i==NSOURCE)then
write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambdaPImin_fmax max = ',lambdaPImax/(2.5d0*f0)
- write(IOUT,*) ' Nb pts / lambdaPImin_fmax min = ',lambdaPImin/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaPImin_fmax max = ',lambdaPImax/(2.5d0*f0min)
+ write(IOUT,*) ' Nb pts / lambdaPImin_fmax min = ',lambdaPImin/(2.5d0*f0max)
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,*) ' Nb pts / lambdaPIImin_fmax max = ',lambdaPIImax/(2.5d0*f0min)
+ write(IOUT,*) ' Nb pts / lambdaPIImin_fmax min = ',lambdaPIImin/(2.5d0*f0max)
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,*) ' Nb pts / lambdaSmin_fmax max = ',lambdaSmax/(2.5d0*f0min)
+ write(IOUT,*) ' Nb pts / lambdaSmin_fmax min = ',lambdaSmin/(2.5d0*f0max)
write(IOUT,*) '----'
+ endif
+
+ endif
+ enddo
endif
endif
@@ -1655,10 +1676,11 @@
ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
- if ( myrank == 0 ) then
- print *
- print *,'Creating PostScript file with stability condition'
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with stability condition'
+
!
!---- open PostScript file
!
@@ -1763,14 +1785,14 @@
write(24,*) '0 setgray'
num_ispec = 0
- end if
+ endif
do ispec = 1, nspec
if ( myrank == 0 ) then
num_ispec = num_ispec + 1
- write(24,*) '% elem ',ispec
- end if
+ write(24,*) '% elem ',num_ispec
+ endif
do i=1,pointsdisp
do j=1,pointsdisp
@@ -1796,7 +1818,7 @@
else
coorg_send(1,(ispec-1)*5+1) = x1
coorg_send(2,(ispec-1)*5+1) = z1
- end if
+ endif
! draw straight lines if elements have 4 nodes
@@ -1810,7 +1832,7 @@
else
coorg_send(1,(ispec-1)*5+2) = x2
coorg_send(2,(ispec-1)*5+2) = z2
- end if
+ endif
ir=pointsdisp
is=pointsdisp
@@ -1823,7 +1845,7 @@
else
coorg_send(1,(ispec-1)*5+3) = x2
coorg_send(2,(ispec-1)*5+3) = z2
- end if
+ endif
is=pointsdisp
ir=1
@@ -1836,7 +1858,7 @@
else
coorg_send(1,(ispec-1)*5+4) = x2
coorg_send(2,(ispec-1)*5+4) = z2
- end if
+ endif
ir=1
is=2
@@ -1850,10 +1872,11 @@
else
coorg_send(1,(ispec-1)*5+5) = x2
coorg_send(2,(ispec-1)*5+5) = z2
- end if
+ endif
material = kmato(ispec)
+ if(poroelastic(ispec)) then
phi=porosity(material)
tort=tortuosity(material)
!solid properties
@@ -1861,25 +1884,31 @@
kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
denst_s = density(1,material)
!fluid properties
- kappa_f = poroelastcoef(1,2,material)
+ 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
+ denst = (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
+ afactor = denst - phi/tort*denst_f
+ bfactor = H_biot + phi*denst/(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)
cpIloc = sqrt(cpIsquare)
+ else
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ endif
+
vpImax_local = -HUGEVAL
distance_min_local = HUGEVAL
@@ -1891,8 +1920,7 @@
!--- if heterogeneous formulation with external velocity model
if(assign_external_model) then
cpIloc = vpext(i,j,ispec)
- csloc = vsext(i,j,ispec)
- denst_bar = rhoext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
endif
vpImax_local = max(vpImax_local,cpIloc)
@@ -1927,14 +1955,14 @@
write(24,*) '1 0 0 RG GF 0 setgray ST'
else
RGB_send(ispec) = 1
- end if
+ endif
else
! do not color the elements if below the threshold
if ( myrank == 0 ) then
write(24,*) 'ST'
else
RGB_send(ispec) = 0
- end if
+ endif
endif
enddo ! end of loop on all the spectral elements
@@ -1963,19 +1991,19 @@
write(24,*) '1 0 0 RG GF 0 setgray ST'
else
write(24,*) 'ST'
- end if
- end do
+ endif
+ enddo
deallocate(coorg_recv)
deallocate(RGB_recv)
- end do
+ enddo
else
call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (coorg_send, nspec*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (RGB_send, nspec, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- end if
+ endif
#endif
@@ -1986,21 +2014,22 @@
close(24)
- print *,'End of creation of PostScript file with stability condition'
- end if
+ write(IOUT,*) 'End of creation of PostScript file with stability condition'
+ endif
!
!--------------------------------------------------------------------------------
!
- if ( myrank == 0 ) then
- print *
- print *,'Creating PostScript file with mesh dispersion'
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with mesh dispersion'
+
!
!---- open PostScript file
!
- if(any_elastic_glob .or. any_poroelastic_glob) then
+ if(any_elastic_glob .or. any_poroelastic) 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')
@@ -2109,13 +2138,13 @@
write(24,*) '0 setgray'
num_ispec = 0
- end if
+ endif
do ispec = 1, nspec
if ( myrank == 0 ) then
num_ispec = num_ispec + 1
- write(24,*) '% elem ',ispec
- end if
+ write(24,*) '% elem ',num_ispec
+ endif
do i=1,pointsdisp
do j=1,pointsdisp
@@ -2141,7 +2170,7 @@
else
coorg_send(1,(ispec-1)*5+1) = x1
coorg_send(2,(ispec-1)*5+1) = z1
- end if
+ endif
! draw straight lines if elements have 4 nodes
@@ -2155,7 +2184,7 @@
else
coorg_send(1,(ispec-1)*5+2) = x2
coorg_send(2,(ispec-1)*5+2) = z2
- end if
+ endif
ir=pointsdisp
is=pointsdisp
@@ -2168,7 +2197,7 @@
else
coorg_send(1,(ispec-1)*5+3) = x2
coorg_send(2,(ispec-1)*5+3) = z2
- end if
+ endif
is=pointsdisp
ir=1
@@ -2181,7 +2210,7 @@
else
coorg_send(1,(ispec-1)*5+4) = x2
coorg_send(2,(ispec-1)*5+4) = z2
- end if
+ endif
ir=1
is=2
@@ -2195,12 +2224,11 @@
else
coorg_send(1,(ispec-1)*5+5) = x2
coorg_send(2,(ispec-1)*5+5) = z2
- end if
+ endif
-
-
material = kmato(ispec)
-
+
+ if(poroelastic(ispec)) then
phi = porosity(material)
tort = tortuosity(material)
!solid properties
@@ -2213,30 +2241,30 @@
!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
+ denst = (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
+ afactor = denst - phi/tort*denst_f
+ bfactor = H_biot + phi*denst/(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
cpIloc = sqrt(cpIsquare)
- cpIIloc = sqrt(cpIIsquare)
csloc = sqrt(cssquare)
+ else
+ mu = poroelastcoef(2,1,material)
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
- if(csloc < TINYVAL) then ! acoustic domain
- cpIsquare = kappa_f/denst_f
- cpIIsquare = 0.d0
- cpIloc = sqrt(cpIsquare)
- cpIIloc = sqrt(cpIIsquare)
- endif
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+ endif
vpImax_local = -HUGEVAL
vpImin_local = HUGEVAL
@@ -2252,7 +2280,7 @@
if(assign_external_model) then
cpIloc = vpext(i,j,ispec)
csloc = vsext(i,j,ispec)
- denst_bar = rhoext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
endif
vpImax_local = max(vpImax_local,cpIloc)
@@ -2295,7 +2323,7 @@
write(24,*) '1 0 0 RG GF 0 setgray ST'
else
RGB_send(ispec) = 1
- end if
+ endif
! display bad elements that are below 120% of the threshold in blue
else if(lambdaS_local <= 1.20 * lambdaSmin) then
@@ -2303,7 +2331,7 @@
write(24,*) '0 0 1 RG GF 0 setgray ST'
else
RGB_send(ispec) = 3
- end if
+ endif
else
! do not color the elements if not close to the threshold
@@ -2311,7 +2339,7 @@
write(24,*) 'ST'
else
RGB_send(ispec) = 0
- end if
+ endif
endif
else
@@ -2320,10 +2348,10 @@
write(24,*) 'ST'
else
RGB_send(ispec) = 0
- end if
+ endif
endif
-! display mesh dispersion for P waves if there is no elastic/poroelastic element in the mesh
+! display mesh dispersion for P waves if there is no elastic element in the mesh
else
lambdaPI_local = vpImin_local / (distance_max_local / (NGLLX - 1))
@@ -2334,7 +2362,7 @@
write(24,*) '1 0 0 RG GF 0 setgray ST'
else
RGB_send(ispec) = 1
- end if
+ endif
! display bad elements that are below 120% of the threshold in blue
else if(lambdaPI_local <= 1.20 * lambdaPImin) then
@@ -2342,7 +2370,7 @@
write(24,*) '0 0 1 RG GF 0 setgray ST'
else
RGB_send(ispec) = 3
- end if
+ endif
else
! do not color the elements if not close to the threshold
@@ -2350,7 +2378,7 @@
write(24,*) 'ST'
else
RGB_send(ispec) = 0
- end if
+ endif
endif
endif
@@ -2379,29 +2407,28 @@
write(24,*) 'CO'
if ( RGB_recv(ispec) == 1) then
write(24,*) '1 0 0 RG GF 0 setgray ST'
- end if
+ endif
if ( RGB_recv(ispec) == 3) then
write(24,*) '0 0 1 RG GF 0 setgray ST'
- end if
+ endif
if ( RGB_recv(ispec) == 0) then
write(24,*) 'ST'
- end if
+ endif
- end do
+ enddo
deallocate(coorg_recv)
deallocate(RGB_recv)
- end do
+ enddo
else
call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (coorg_send, nspec*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (RGB_send, nspec, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- end if
+ endif
#endif
-
if ( myrank == 0 ) then
write(24,*) '%'
write(24,*) 'grestore'
@@ -2409,17 +2436,19 @@
close(24)
- print *,'End of creation of PostScript file with mesh dispersion'
- end if
+ write(IOUT,*) 'End of creation of PostScript file with mesh dispersion'
+ endif
+
!
!--------------------------------------------------------------------------------
!
- if ( myrank == 0 ) then
- print *
- print *,'Creating PostScript file with velocity model'
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with velocity model'
+
!
!---- open PostScript file
!
@@ -2524,13 +2553,13 @@
write(24,*) '0 setgray'
num_ispec = 0
-end if
+endif
- do ispec = 1, nspec
+ do ispec = 1, UPPER_LIMIT_DISPLAY
if ( myrank == 0 ) then
num_ispec = num_ispec + 1
- write(24,*) '% elem ',ispec
- end if
+ write(24,*) '% elem ',num_ispec
+ endif
do i=1,pointsdisp
do j=1,pointsdisp
xinterp(i,j) = 0.d0
@@ -2555,7 +2584,7 @@
else
coorg_send(1,(ispec-1)*5+1) = x1
coorg_send(2,(ispec-1)*5+1) = z1
- end if
+ endif
! draw straight lines if elements have 4 nodes
@@ -2569,7 +2598,7 @@
else
coorg_send(1,(ispec-1)*5+2) = x2
coorg_send(2,(ispec-1)*5+2) = z2
- end if
+ endif
ir=pointsdisp
is=pointsdisp
@@ -2582,7 +2611,7 @@
else
coorg_send(1,(ispec-1)*5+3) = x2
coorg_send(2,(ispec-1)*5+3) = z2
- end if
+ endif
is=pointsdisp
ir=1
@@ -2595,7 +2624,7 @@
else
coorg_send(1,(ispec-1)*5+4) = x2
coorg_send(2,(ispec-1)*5+4) = z2
- end if
+ endif
ir=1
is=2
@@ -2609,7 +2638,7 @@
else
coorg_send(1,(ispec-1)*5+5) = x2
coorg_send(2,(ispec-1)*5+5) = z2
- end if
+ endif
if((vpImax-vpImin)/vpImin > 0.02d0) then
if(assign_external_model) then
@@ -2617,6 +2646,7 @@
x1 = (vpext(1,1,ispec)-vpImin) / (vpImax-vpImin)
else
material = kmato(ispec)
+ if(poroelastic(ispec)) then
phi = porosity(material)
tort = tortuosity(material)
!solid properties
@@ -2629,24 +2659,23 @@
!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
+ denst = (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
+ afactor = denst - phi/tort*denst_f
+ bfactor = H_biot + phi*denst/(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
+ else
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ endif
x1 = (cpIloc-vpImin)/(vpImax-vpImin)
endif
else
@@ -2665,7 +2694,7 @@
write(24,*) sngl(x1),' setgray GF 0 setgray ST'
else
greyscale_send(ispec) = sngl(x1)
- end if
+ endif
enddo ! end of loop on all the spectral elements
#ifdef USE_MPI
@@ -2690,39 +2719,40 @@
write(24,*) 'CO'
write(24,*) greyscale_recv(ispec), ' setgray GF 0 setgray ST'
- end do
+ enddo
deallocate(coorg_recv)
deallocate(greyscale_recv)
- end do
+ enddo
else
- call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (coorg_send, nspec*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (greyscale_send, nspec, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
-
- end if
+ call MPI_SEND (UPPER_LIMIT_DISPLAY, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (coorg_send, UPPER_LIMIT_DISPLAY*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (greyscale_send, UPPER_LIMIT_DISPLAY, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+ endif
#endif
- if ( myrank == 0 ) then
+ if (myrank == 0) then
+
write(24,*) '%'
write(24,*) 'grestore'
write(24,*) 'showpage'
close(24)
- print *,'End of creation of PostScript file with velocity model'
+ write(IOUT,*) 'End of creation of PostScript file with velocity model'
- end if
+ endif
+ if (myrank == 0) then
- if ( myrank == 0 ) then
- print *
- print *,'Creating PostScript file with partitioning'
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with mesh partitioning'
+
!
!---- open PostScript file
!
- open(unit=24,file='OUTPUT_FILES/mesh_partition.ps',status='unknown')
+ open(unit=24,file='OUTPUT_FILES/mesh_partitioning.ps',status='unknown')
!
!---- write PostScript header
@@ -2797,7 +2827,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 stability condition \(red = bad\)) show'
+ write(24,*) '(Mesh partitioning) show'
write(24,*) 'grestore'
write(24,*) '25.35 CM 18.9 CM MV'
write(24,*) usoffset,' CM 2 div neg 0 MR'
@@ -2823,14 +2853,14 @@
write(24,*) '0 setgray'
num_ispec = 0
- end if
+ endif
- do ispec = 1, nspec
+ do ispec = 1, UPPER_LIMIT_DISPLAY
if ( myrank == 0 ) then
num_ispec = num_ispec + 1
- write(24,*) '% elem ',ispec
- end if
+ write(24,*) '% elem ',num_ispec
+ endif
do i=1,pointsdisp
do j=1,pointsdisp
@@ -2856,7 +2886,7 @@
else
coorg_send(1,(ispec-1)*5+1) = x1
coorg_send(2,(ispec-1)*5+1) = z1
- end if
+ endif
! draw straight lines if elements have 4 nodes
@@ -2870,7 +2900,7 @@
else
coorg_send(1,(ispec-1)*5+2) = x2
coorg_send(2,(ispec-1)*5+2) = z2
- end if
+ endif
ir=pointsdisp
is=pointsdisp
@@ -2883,7 +2913,7 @@
else
coorg_send(1,(ispec-1)*5+3) = x2
coorg_send(2,(ispec-1)*5+3) = z2
- end if
+ endif
is=pointsdisp
ir=1
@@ -2896,7 +2926,7 @@
else
coorg_send(1,(ispec-1)*5+4) = x2
coorg_send(2,(ispec-1)*5+4) = z2
- end if
+ endif
ir=1
is=2
@@ -2910,12 +2940,11 @@
else
coorg_send(1,(ispec-1)*5+5) = x2
coorg_send(2,(ispec-1)*5+5) = z2
- end if
+ endif
-
if ( myrank == 0 ) then
write(24,*) red(1), green(1), blue(1), 'RG GF 0 setgray ST'
- end if
+ endif
enddo ! end of loop on all the spectral elements
@@ -2944,30 +2973,29 @@
write(24,*) red(icol), green(icol), blue(icol), ' RG GF 0 setgray ST'
- end do
+ enddo
deallocate(coorg_recv)
- end do
+ enddo
else
- call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (coorg_send, nspec*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (UPPER_LIMIT_DISPLAY, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (coorg_send, UPPER_LIMIT_DISPLAY*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
- end if
+ endif
#endif
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
+ if (myrank == 0) then
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
- close(24)
+ close(24)
- print *,'End of creation of PostScript file with partitioning'
- end if
+ write(IOUT,*) 'End of creation of PostScript file with partitioning'
+ write(IOUT,*)
+ endif
-
-
10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
681 format(f6.2,1x,f6.2)
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_Bielak_conditions.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_Bielak_conditions.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_Bielak_conditions.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_arrays_source.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,15 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 6.3
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -130,11 +128,9 @@
! ------------------------------------------------------------------------------------------------------
- subroutine compute_arrays_adj_source(myrank,adj_source_file, &
- xi_receiver,gamma_receiver, adj_sourcearray, &
- xigll,zigll,NSTEP)
+ subroutine compute_arrays_adj_source(myrank,adj_source_file,xi_receiver,gamma_receiver,adj_sourcearray, &
+ xigll,zigll,NSTEP)
-
implicit none
include 'constants.h'
@@ -190,5 +186,3 @@
end subroutine compute_arrays_adj_source
-
-
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_curl_one_element.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_curl_one_element.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_curl_one_element.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -40,10 +40,10 @@
!
!========================================================================
-subroutine compute_curl_one_element(curl_element,displ_elastic,elastic, &
+subroutine compute_curl_one_element(curl_element,displ_elastic,displs_poroelastic,elastic,poroelastic, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
- ! compute curl in elastic elements (for rotational study)
+ ! compute curl in (poro)elastic elements (for rotational study)
implicit none
@@ -58,8 +58,8 @@
! curl in this element
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
- logical, dimension(nspec) :: elastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic
+ logical, dimension(nspec) :: elastic,poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic,displs_poroelastic
! array with derivatives of Lagrange polynomials
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
@@ -111,6 +111,42 @@
enddo
enddo
+ elseif(poroelastic(ispec)) then
+
+ 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
+
+ ! 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)
+ 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_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+
+ ! store pressure
+ curl_element(i,j) = - 0.5d0 * (dux_dzl - duz_dxl)
+
+ enddo
+ enddo
+
else
call exit_MPI('no curl in acoustic')
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_energy.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_energy.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_energy.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -4,12 +4,10 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -42,18 +40,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,poroelastcoef,density, &
- porosity,tortuosity,&
+ subroutine compute_energy(displ_elastic,veloc_elastic,displs_poroelastic,velocs_poroelastic, &
+ displw_poroelastic,velocw_poroelastic, &
+ xix,xiz,gammax,gammaz,jacobian,ibool,elastic,poroelastic,hprime_xx,hprime_zz, &
+ nspec,npoin,assign_external_model,it,deltat,t0,kmato,elastcoef,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"
@@ -66,7 +63,7 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
- double precision :: Mu_nu1,Mu_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_dot_acoustic,potential_dot_dot_acoustic
@@ -89,7 +86,7 @@
double precision, dimension(2,numat) :: density
double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(4,3,numat) :: elastcoef
double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic,veloc_elastic
@@ -136,9 +133,9 @@
if(elastic(ispec)) then
! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec))
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = elastcoef(3,1,kmato(ispec))
rhol = density(1,kmato(ispec))
! double loop over GLL points
@@ -207,15 +204,15 @@
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
+ mul_s = elastcoef(2,1,kmato(ispec))
+ kappal_s = elastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
rhol_s = density(1,kmato(ispec))
!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
+ kappal_f = elastcoef(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
+ mul_fr = elastcoef(2,3,kmato(ispec))
+ kappal_fr = elastcoef(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))
@@ -229,12 +226,6 @@
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
@@ -256,16 +247,16 @@
! 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)
+ 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(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)
+ 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)
@@ -291,12 +282,11 @@
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
+ + two*C_biot*dwx_dxl*dux_dxl + two*C_biot*dwz_dzl*duz_dzl &
+ + two*C_biot*(dwx_dxl*duz_dzl + dwz_dzl*dux_dxl) &
+ + M_biot*dwx_dxl**2 + M_biot*dwz_dzl**2 &
+ + two*M_biot*dwx_dxl*dwz_dzl )*wxgll(i)*wzgll(j)*jacobianl / TWO
-
! compute kinetic energy
if(phil > 0.0d0) then
kinetic_energy = kinetic_energy + ( &
@@ -321,30 +311,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 displacement potential Chi is used as in Chaljub and Valette,
+! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
! This permits acoustic-elastic coupling based on a non-iterative time scheme.
-! Displacement is then: u = grad(Chi)
-! 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).
+! 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).
! compute pressure in this element
- call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
- displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
+ 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,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
+ numat,kmato,elastcoef,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,&
- velocs_poroelastic,elastic,poroelastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
+ 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)
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
- cpl = sqrt(kappal_f/rhol_f)
+! get density 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)
! double loop over GLL points
do j = 1,NGLLZ
@@ -353,16 +343,16 @@
!--- if external medium, get density of current grid point
if(assign_external_model) then
cpl = vpext(i,j,ispec)
- rhol_f = rhoext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
endif
! compute kinetic energy
kinetic_energy = kinetic_energy + &
- rhol_f*(vector_field_element(1,i,j)**2 + &
+ rhol*(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_f * cpl**2)
+ potential_energy = potential_energy + (pressure_element(i,j)**2)*wxgll(i)*wzgll(j)*jacobianl / (TWO * rhol * cpl**2)
enddo
enddo
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_acoustic.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_acoustic.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_acoustic.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,15 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 6.3
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -42,61 +40,57 @@
!
!========================================================================
- 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, &
+ subroutine compute_forces_acoustic(npoin,nspec,nelemabs,numat,it,NSTEP, &
+ anyabs,assign_external_model,ibool,kmato,numabs, &
+ elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,b_potential_dot_dot_acoustic,b_potential_acoustic, &
+ density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,rhoext,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, &
- nrec,isolver,save_forward,b_absorb_acoustic_left,&
+ jbegin_left,jend_left,jbegin_right,jend_right,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,kappa_ac_k,NSOURCE)
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,kappa_ac_k)
! compute forces for the acoustic elements
implicit none
include "constants.h"
- integer :: NSOURCE, i_source
- integer :: npoin,nspec,myrank,numat,it,NSTEP
- integer, dimension(NSOURCE) ::iglob_source,ispec_selected_source,is_proc_source,source_type
- integer :: nrec,isolver
- integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
+
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP,isolver
+
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
+ 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
+ logical :: anyabs,assign_external_model
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,poroelastic
+ logical, dimension(4,nelemabs) :: codeabs
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
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
+ 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
- real(kind=CUSTOM_REAL), dimension(NSOURCE,NSTEP) :: source_time_function
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
- real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,NDIM,NGLLX,NGLLZ) :: adj_sourcearrays
real(kind=CUSTOM_REAL), dimension(npoin) :: kappa_ac_k
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
@@ -105,16 +99,11 @@
real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-! for overlapping MPI communications with computation
- integer, intent(in) :: nspec_inner_outer
- integer, dimension(max(1,nspec_inner_outer)), intent(in) :: ispec_inner_outer_to_glob
- logical, intent(in) :: num_phase_inner_outer
-
!---
!--- local variables
!---
- integer :: ispec,ispec_inner_outer,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend,irec,irec_local
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,dux_dxl,dux_dzl
@@ -125,21 +114,26 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2
! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl,nx,nz
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-! material properties of the acoustic medium
- real(kind=CUSTOM_REAL) :: kappal,cpl,rhol,rho_vp
+! material properties of the elastic medium
+ real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,kappal,cpl,rhol
-! loop over spectral elements
- do ispec_inner_outer = 1,nspec_inner_outer
+ integer :: ifirstelem,ilastelem
- ispec = ispec_inner_outer_to_glob(ispec_inner_outer)
+ ifirstelem = 1
+ ilastelem = nspec
+! loop over spectral elements
+ do ispec = ifirstelem,ilastelem
+
!---
!--- acoustic spectral element
!---
if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ rhol = density(1,kmato(ispec))
+
! first double loop over GLL points to compute and store gradients
do j = 1,NGLLZ
do i = 1,NGLLX
@@ -148,8 +142,10 @@
dux_dxi = ZERO
dux_dgamma = ZERO
+ if(isolver == 2) then
b_dux_dxi = ZERO
b_dux_dgamma = ZERO
+ endif
! first double loop over GLL points to compute and store gradients
! we can merge the two loops because NGLLX == NGLLZ
@@ -161,7 +157,6 @@
b_dux_dxi = b_dux_dxi + b_potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
b_dux_dgamma = b_dux_dgamma + b_potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
endif
-
enddo
xixl = xix(i,j,ispec)
@@ -176,24 +171,25 @@
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
! kernels calculation
- if(isolver == 2) then
iglob = ibool(i,j,ispec)
- kappa_ac_k(iglob) = dux_dxl * b_dux_dxl
- endif
+ kappa_ac_k(iglob) = dux_dxl * b_dux_dxl + dux_dzl * b_dux_dzl
+ 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)
- tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl)
+ 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
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)
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(xixl*b_dux_dxl + xizl*b_dux_dzl) /rhol
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*b_dux_dxl + gammazl*b_dux_dzl) /rhol
endif
enddo
@@ -212,6 +208,7 @@
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(k,i) + b_tempx2(i,k)*hprimewgll_zz(k,j))
@@ -225,28 +222,26 @@
enddo ! end of loop over all spectral elements
-! only for the first call to compute_forces_acoustic (during computation on outer elements)
- if ( num_phase_inner_outer ) then
-
!
!--- absorbing boundaries
!
if(anyabs) then
-!--- 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,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ rhol = density(1,kmato(ispec))
-! get parameters of current spectral element
-! acoustic (fluid) properties
- kappal = poroelastcoef(1,2,kmato(ispec))
- rhol = density(2,kmato(ispec))
-
cpl = sqrt(kappal/rhol)
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
i = 1
jbegin = jbegin_left(ispecabs)
@@ -256,56 +251,37 @@
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) .and. .not. poroelastic(ispec)) then
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
if(save_forward .and. isolver ==1) then
- b_absorb_acoustic_left(j,ispecabs,it) = potential_dot_acoustic(iglob)*weight/cpl
+ b_absorb_acoustic_left(j,ib_xmin(ispecabs),it) = potential_dot_acoustic(iglob)*weight/cpl/rhol
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)
+ b_absorb_acoustic_left(j,ib_xmin(ispecabs),NSTEP-it+1)
endif
-
endif
- enddo
-
enddo
endif ! end of left absorbing boundary
!--- right absorbing boundary
- if( nspec_xmax > 0 ) then
-
- do ispecabs = 1, nspec_xmax
+ if(codeabs(IRIGHT,ispecabs)) then
- 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)
@@ -315,236 +291,126 @@
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) .and. .not. poroelastic(ispec)) then
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+
if(save_forward .and. isolver ==1) then
- b_absorb_acoustic_right(j,ispecabs,it) = potential_dot_acoustic(iglob)*weight/cpl
+ b_absorb_acoustic_right(j,ib_xmax(ispecabs),it) = potential_dot_acoustic(iglob)*weight/cpl/rhol
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
-
+ b_absorb_acoustic_right(j,ib_xmax(ispecabs),NSTEP-it+1)
+ endif
endif
- enddo
-
enddo
endif ! end of right absorbing boundary
!--- bottom absorbing boundary
- if( nspec_zmin > 0) then
+ if(codeabs(IBOTTOM,ispecabs)) 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( nspec_xmin > 0 ) ibegin = 2
- if( nspec_xmax > 0 ) iend = NGLLX-1
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) 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) .and. .not. poroelastic(ispec)) then
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
if(save_forward .and. isolver ==1) then
- b_absorb_acoustic_bottom(i,ispecabs,it) = potential_dot_acoustic(iglob)*weight/cpl
+ b_absorb_acoustic_bottom(i,ib_zmin(ispecabs),it) = potential_dot_acoustic(iglob)*weight/cpl/rhol
elseif(isolver == 2) then
b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
- b_absorb_acoustic_bottom(i,ispecabs,NSTEP-it+1)
+ b_absorb_acoustic_bottom(i,ib_zmin(ispecabs),NSTEP-it+1)
endif
-
endif
- enddo
-
enddo
endif ! end of bottom absorbing boundary
!--- top absorbing boundary
- if( nspec_zmax > 0 ) then
+ if(codeabs(ITOP,ispecabs)) 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( nspec_xmin > 0) ibegin = 2
- if( nspec_xmax > 0) iend = NGLLX-1
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) 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) .and. .not. poroelastic(ispec)) then
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
if(save_forward .and. isolver ==1) then
- b_absorb_acoustic_top(i,ispecabs,it) = potential_dot_acoustic(iglob)*weight/cpl
+ b_absorb_acoustic_top(i,ib_zmax(ispecabs),it) = potential_dot_acoustic(iglob)*weight/cpl/rhol
elseif(isolver == 2) then
- b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - b_absorb_acoustic_top(i,ispecabs,NSTEP-it+1)
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_top(i,ib_zmax(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
-do i_source=1,NSOURCE
-
- if (is_proc_source(i_source) == 1 ) then
-! collocated force
-! beware, for acoustic medium, source is a pressure source
- if(source_type(i_source) == 1) then
- if(.not. elastic(ispec_selected_source(i_source)) .and. .not. poroelastic(ispec_selected_source(i_source))) then
-
- if(isolver == 1) then ! forward wavefield
- potential_dot_dot_acoustic(iglob_source(i_source)) = potential_dot_dot_acoustic(iglob_source(i_source)) + &
- source_time_function(i_source,it)
- else ! backward wavefield
- b_potential_dot_dot_acoustic(iglob_source(i_source)) = b_potential_dot_dot_acoustic(iglob_source(i_source)) +&
- source_time_function(i_source,NSTEP-it+1)
- endif
-
- endif
-
-! moment tensor
- else if(source_type(i_source) == 2) then
-
- if(.not. elastic(ispec_selected_source(i_source)) .and. .not. poroelastic(ispec_selected_source(i_source))) then
- call exit_MPI('cannot have moment tensor source in acoustic element')
- endif
- endif
- endif
-enddo
-
- 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,NSTEP-it+1,1,i,j) + nz*adj_sourcearrays(irec,NSTEP-it+1,2,i,j))
-
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + &
- adj_sourcearrays(irec_local,NSTEP-it+1,1,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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_elastic.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,15 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 6.3
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -42,32 +40,34 @@
!
!========================================================================
- subroutine compute_forces_elastic(npoin,nspec,myrank,nelemabs,numat,iglob_source, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ subroutine compute_forces_elastic(npoin,nspec,myrank,nelemabs,numat, &
+ 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,elastic, &
- accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic,&
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
+ 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,&
- nrec,isolver,save_forward,b_absorb_elastic_left,&
+ 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,NSOURCE,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,NSOURCE)
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,mu_k,kappa_k)
! compute forces for the elastic elements
implicit none
include "constants.h"
+
integer :: NSOURCE, i_source
integer :: npoin,nspec,myrank,nelemabs,numat,it,NSTEP
- integer, dimension(NSOURCE) ::iglob_source,ispec_selected_source, is_proc_source,source_type
- real, dimension(NSOURCE) :: angleforce
+ integer, dimension(NSOURCE) :: ispec_selected_source,is_proc_source,source_type
+
integer :: nrec,isolver
integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
@@ -77,23 +77,28 @@
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 :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+ double precision, dimension(NSOURCE) :: angleforce
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
- 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(NSOURCE,NSTEP) :: source_time_function
real(kind=CUSTOM_REAL), dimension(NSOURCE,NDIM,NGLLX,NGLLZ) :: sourcearray
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accel_elastic,b_displ_elastic
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
@@ -103,8 +108,8 @@
integer :: N_SLS
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11,e13
- double precision, dimension(N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
- double precision :: Mu_nu1,Mu_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
real(kind=CUSTOM_REAL) :: e1_sum,e11_sum,e13_sum
integer :: i_sls
@@ -119,16 +124,12 @@
real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-! for overlapping MPI communications with computation
- integer, intent(in) :: nspec_inner_outer
- integer, dimension(max(1,nspec_inner_outer)), intent(in) :: ispec_inner_outer_to_glob
- logical, intent(in) :: num_phase_inner_outer
!---
!--- local variables
!---
- integer :: ispec,ispec_inner_outer,i,j,k,iglob,ispecabs,ibegin,iend,irec_local,irec
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,irec,irec_local
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
@@ -159,20 +160,26 @@
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
+ integer :: ifirstelem,ilastelem
+
! compute Grad(displ_elastic) at time step n for attenuation
if(TURN_ATTENUATION_ON) call compute_gradient_attenuation(displ_elastic,dux_dxl_n,duz_dxl_n, &
dux_dzl_n,duz_dzl_n,xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
- endif
+ ifirstelem = 1
+ ilastelem = nspec
+
! loop over spectral elements
- do ispec_inner_outer = 1,nspec_inner_outer
+ do ispec = ifirstelem,ilastelem
-! get global numbering for inner or outer elements
- ispec = ispec_inner_outer_to_glob(ispec_inner_outer)
-
!---
!--- elastic spectral element
!---
@@ -204,7 +211,7 @@
dux_dgamma = ZERO
duz_dgamma = ZERO
- if(isolver == 2) then ! backward wavefield
+ if(isolver == 2) then ! Adjoint calculation, backward wavefield
b_dux_dxi = ZERO
b_duz_dxi = ZERO
@@ -219,12 +226,13 @@
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
+
+ if(isolver == 2) then ! Adjoint calculation, 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
+ endif
enddo
xixl = xix(i,j,ispec)
@@ -239,7 +247,7 @@
duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
- if(isolver == 2) then ! backward wavefield
+ if(isolver == 2) then ! Adjoint calculation, backward wavefield
b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
@@ -258,8 +266,8 @@
! 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
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(i,j,ispec) - mul_relaxed * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_relaxed * Mu_nu2(i,j,ispec)
lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
@@ -290,7 +298,7 @@
sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
- if(isolver == 2) then ! backward wavefield
+ if(isolver == 2) then ! Adjoint calculation, 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
@@ -308,7 +316,7 @@
endif
-! kernels calculation
+! Pre-kernels calculation
if(isolver == 2) then
iglob = ibool(i,j,ispec)
dsxx = dux_dxl
@@ -334,7 +342,7 @@
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
+ if(isolver == 2) then ! Adjoint calculation, 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)
@@ -360,13 +368,12 @@
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
+ if(isolver == 2) then ! Adjoint calculation, 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
@@ -376,20 +383,18 @@
enddo ! end of loop over all spectral elements
-! only for the first call to compute_forces_elastic (during computation on outer elements)
- if ( num_phase_inner_outer ) then
-
!
!--- absorbing boundaries
!
if(anyabs) then
-!--- left absorbing boundary
- if( nspec_xmin > 0 ) then
+ count_left=1
+ count_right=1
+ count_bot=1
- do ispecabs = 1, nspec_xmin
+ do ispecabs = 1,nelemabs
- ispec = ib_xmin(ispecabs)
+ ispec = numabs(ispecabs)
! get elastic parameters of current spectral element
lambdal_relaxed = elastcoef(1,1,kmato(ispec))
@@ -399,6 +404,9 @@
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
@@ -408,11 +416,19 @@
! for analytical initial plane wave for Bielak's conditions
! left or right edge, horizontal normal vector
if(add_Bielak_conditions .and. initialfield) 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(1), 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)
+ 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
else
veloc_horiz = 0
veloc_vert = 0
@@ -452,35 +468,22 @@
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz + traction_z_t0)*weight
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
+ b_absorb_elastic_left(1,j,ib_xmin(ispecabs),it) = tx*weight
+ b_absorb_elastic_left(2,j,ib_xmin(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)
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_left(1,j,ib_xmin(ispecabs),NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_left(2,j,ib_xmin(ispecabs),NSTEP-it+1)
endif
- endif
- enddo
+ endif
enddo
endif ! end of left absorbing boundary
!--- right absorbing boundary
- if( nspec_xmax > 0 ) then
+ if(codeabs(IRIGHT,ispecabs)) 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
@@ -490,11 +493,19 @@
! for analytical initial plane wave for Bielak's conditions
! left or right edge, horizontal normal vector
if(add_Bielak_conditions .and. initialfield) 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(1), 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)
+ 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
else
veloc_horiz = 0
veloc_vert = 0
@@ -533,43 +544,31 @@
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
+
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
+ b_absorb_elastic_right(1,j,ib_xmax(ispecabs),it) = tx*weight
+ b_absorb_elastic_right(2,j,ib_xmax(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)
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_right(1,j,ib_xmax(ispecabs),NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_right(2,j,ib_xmax(ispecabs),NSTEP-it+1)
endif
- endif
- enddo
+ endif
enddo
endif ! end of right absorbing boundary
!--- bottom absorbing boundary
- if( nspec_zmin > 0 ) then
+ if(codeabs(IBOTTOM,ispecabs)) 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( nspec_xmin > 0) ibegin = 2
- if( nspec_xmax > 0) iend = NGLLX-1
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
do i = ibegin,iend
@@ -578,11 +577,19 @@
! for analytical initial plane wave for Bielak's conditions
! top or bottom edge, vertical normal vector
if(add_Bielak_conditions .and. initialfield) 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(1), 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
+ 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
else
veloc_horiz = 0
veloc_vert = 0
@@ -622,42 +629,29 @@
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz + traction_z_t0)*weight
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
+ b_absorb_elastic_bottom(1,i,ib_zmin(ispecabs),it) = tx*weight
+ b_absorb_elastic_bottom(2,i,ib_zmin(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)
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_bottom(1,i,ib_zmin(ispecabs),NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_bottom(2,i,ib_zmin(ispecabs),NSTEP-it+1)
endif
- endif
- enddo
+ endif
enddo
endif ! end of bottom absorbing boundary
!--- top absorbing boundary
- if( nspec_zmax > 0 ) then
+ if(codeabs(ITOP,ispecabs)) 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( nspec_xmin > 0) ibegin = 2
- if( nspec_xmax > 0) iend = NGLLX-1
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
do i = ibegin,iend
@@ -667,7 +661,7 @@
! top or bottom edge, vertical normal vector
if(add_Bielak_conditions .and. initialfield) 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(1), angleforce_refl, &
+ 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
@@ -710,59 +704,42 @@
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz - traction_z_t0)*weight
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
+ b_absorb_elastic_top(1,i,ib_zmax(ispecabs),it) = tx*weight
+ b_absorb_elastic_top(2,i,ib_zmax(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)
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_top(1,i,ib_zmax(ispecabs),NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_top(2,i,ib_zmax(ispecabs),NSTEP-it+1)
endif
- endif
- enddo
+ endif
enddo
endif ! end of top absorbing boundary
+ enddo
+
endif ! end of absorbing boundaries
-! --- add the source
-
+! --- add the source if it is a moment tensor
if(.not. initialfield) then
-do i_source=1,NSOURCE
+ do i_source=1,NSOURCE
! if this processor carries the source and the source element is elastic
if (is_proc_source(i_source) == 1 .and. elastic(ispec_selected_source(i_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(i_source) == 1) then
-
- if(isolver == 1) then ! forward wavefield
- accel_elastic(1,iglob_source(i_source)) = accel_elastic(1,iglob_source(i_source)) - &
- sin(angleforce(i_source))*source_time_function(i_source,it)
- accel_elastic(2,iglob_source(i_source)) = accel_elastic(2,iglob_source(i_source)) + &
- cos(angleforce(i_source))*source_time_function(i_source,it)
- else ! backward wavefield
- b_accel_elastic(1,iglob_source(i_source)) = b_accel_elastic(1,iglob_source(i_source)) - &
- sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- b_accel_elastic(2,iglob_source(i_source)) = b_accel_elastic(2,iglob_source(i_source)) + &
- cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- endif !endif isolver == 1
-
! moment tensor
- else if(source_type(i_source) == 2) then
+ if(source_type(i_source) == 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(i_source))
- accel_elastic(:,iglob) = accel_elastic(:,iglob) + &
- sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
- enddo
- enddo
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ accel_elastic(:,iglob) = accel_elastic(:,iglob) + &
+ sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
+ enddo
+ enddo
else ! backward wavefield
do j=1,NGLLZ
do i=1,NGLLX
@@ -773,14 +750,13 @@
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
-enddo
+ enddo ! do i_source=1,NSOURCE
+
if(isolver == 2) then ! adjoint wavefield
-
+
irec_local = 0
do irec = 1,nrec
! add the source (only if this proc carries the source)
@@ -802,8 +778,6 @@
endif ! if not using an initial field
- else
-
! implement attenuation
if(TURN_ATTENUATION_ON) then
@@ -826,12 +800,12 @@
! evolution e1
Un = e1(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu1(i_sls)
+ tauinv = - inv_tau_sigma_nu1(i,j,ispec,i_sls)
tauinvsquare = tauinv * tauinv
tauinvcube = tauinvsquare * tauinv
tauinvUn = tauinv * Un
- Sn = theta_n * phi_nu1(i_sls)
- Snp1 = theta_np1 * phi_nu1(i_sls)
+ Sn = theta_n * phi_nu1(i,j,ispec,i_sls)
+ Snp1 = theta_np1 * phi_nu1(i,j,ispec,i_sls)
Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
@@ -840,12 +814,12 @@
! evolution e11
Un = e11(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
tauinvsquare = tauinv * tauinv
tauinvcube = tauinvsquare * tauinv
tauinvUn = tauinv * Un
- Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i_sls)
- Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i_sls)
+ Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i,j,ispec,i_sls)
Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
@@ -854,12 +828,12 @@
! evolution e13
Un = e13(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
tauinvsquare = tauinv * tauinv
tauinvcube = tauinvsquare * tauinv
tauinvUn = tauinv * Un
- Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i_sls)
- Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i_sls)
+ Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
@@ -874,7 +848,5 @@
endif ! end of test on attenuation
- endif ! if ( num_phase_inner_outer )
-
end subroutine compute_forces_elastic
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_fluid.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_fluid.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_fluid.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -42,27 +42,26 @@
!
!========================================================================
- subroutine compute_forces_fluid(npoin,nspec,myrank,numat,iglob_source, &
+ subroutine compute_forces_fluid(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,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,poroelastic, &
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
b_accelw_poroelastic,b_velocw_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, &
+ jacobian,source_time_function,sourcearray,adj_sourcearrays,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, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu2,N_SLS, &
rx_viscous,rz_viscous,theta_e,theta_s,&
b_viscodampx,b_viscodampz,&
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_outer,ispec_inner_outer_to_glob,num_phase_inner_outer,nrec,isolver,save_forward,&
+ C_k,M_k,NSOURCE,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,NSOURCE)
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax)
! compute forces for the fluid poroelastic part
@@ -71,16 +70,16 @@
include "constants.h"
integer :: NSOURCE, i_source
integer, dimension(NSOURCE) ::iglob_source,ispec_selected_source,source_type,is_proc_source
- integer :: npoin,nspec,myrank,numat,it,NSTEP
- integer :: nrec,isolver
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP
+ integer :: nrec,isolver,myrank
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_poro,jend_left_poro
- integer, dimension(nspec_xmax) :: ib_xmax,jbegin_right_poro,jend_right_poro
- integer, dimension(nspec_zmin) :: ib_zmin,ibegin_bottom_poro,iend_bottom_poro
- integer, dimension(nspec_zmax) :: ib_zmax,ibegin_top_poro,iend_top_poro
+ 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
+ logical :: anyabs,initialfield,TURN_ATTENUATION_ON
logical :: save_forward
double precision ::deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
@@ -88,8 +87,11 @@
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
integer, dimension(nspec) :: kmato
+ integer, dimension(nelemabs) :: numabs,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro
logical, dimension(nspec) :: poroelastic
+ logical, dimension(4,nelemabs) :: codeabs
real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: accelw_poroelastic,velocw_poroelastic,displw_poroelastic,&
displs_poroelastic,velocs_poroelastic
@@ -100,7 +102,6 @@
double precision, dimension(numat) :: porosity,tortuosity
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,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NSOURCE,NSTEP) :: source_time_function
real(kind=CUSTOM_REAL), dimension(NSOURCE,NDIM,NGLLX,NGLLZ) :: sourcearray
real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,NDIM,NGLLX,NGLLZ) :: adj_sourcearrays
@@ -112,10 +113,10 @@
real(kind=CUSTOM_REAL), dimension(npoin) :: b_viscodampx,b_viscodampz
integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11,e13
- double precision, dimension(N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
- double precision :: Mu_nu1,Mu_nu2
- real(kind=CUSTOM_REAL) :: e1_sum,e11_sum,e13_sum
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e11,e13
+ double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu2,phi_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu2
+ real(kind=CUSTOM_REAL) :: e11_sum,e13_sum
integer :: i_sls
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: &
@@ -136,16 +137,12 @@
real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-! for overlapping MPI communications with computation
- integer, intent(in) :: nspec_inner_outer
- integer, dimension(max(1,nspec_inner_outer)), intent(in) :: ispec_inner_outer_to_glob
- logical, intent(in) :: num_phase_inner_outer
!---
!--- local variables
!---
- integer :: ispec,ispec_inner_outer,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend,irec,irec_local
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend,irec,irec_local
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
@@ -177,7 +174,6 @@
! material properties of the poroelastic medium
real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed
real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
real(kind=CUSTOM_REAL) :: etal_f,kappal_f,rhol_f
real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl,viscodampx,viscodampz
@@ -190,19 +186,13 @@
! for attenuation
real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
-! only for the first call to compute_forces_fluid (during computation on outer elements)
- if ( num_phase_inner_outer ) then
-! compute Grad(displ_elastic) at time step n for attenuation
+! compute Grad(displs_poroelastic) at time step n for attenuation
if(TURN_ATTENUATION_ON) call compute_gradient_attenuation(displs_poroelastic,dux_dxl_n,duz_dxl_n, &
dux_dzl_n,duz_dzl_n,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
- endif
! loop over spectral elements
- do ispec_inner_outer = 1,nspec_inner_outer
+ do ispec = 1,nspec
-! get global numbering for inner or outer elements
- ispec = ispec_inner_outer_to_glob(ispec_inner_outer)
-
!---
!--- poroelastic spectral element
!---
@@ -240,17 +230,6 @@
do j = 1,NGLLZ
do i = 1,NGLLX
-!--- if external medium, get poroelastic parameters of current grid point
- if(assign_external_model) then
- stop 'external model is elastic and/or acoustic'
-! at the moment external model are elastic and/or acoustic
-! cpl = vpext(i,j,ispec)
-! csl = vsext(i,j,ispec)
-! rhol_s = rhoext(i,j,ispec)
-! mul_relaxed = rhol_s*csl*csl
-! lambdal_relaxed = rhol_s*cpl*cpl - TWO*mul_relaxed
-! lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
- endif
! derivative along x and along z for u_s and w
dux_dxi = ZERO
@@ -291,6 +270,7 @@
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)
+
if(isolver == 2) then ! kernels calculation
b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
@@ -336,11 +316,10 @@
b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
endif
-! compute stress tensor (include attenuation or anisotropy if needed)
+! compute stress tensor (include attenuation if needed)
if(TURN_ATTENUATION_ON) then
-!-------------------- ATTENTION TO BE DEFINED ------------------------------!
-
+! Dissipation only controlled by frame share attenuation in poroelastic (see Morency & Tromp, GJI 2008).
! 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
@@ -348,30 +327,30 @@
! 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
+ lambdal_unrelaxed = (lambdal_G + mul_G) - mul_G * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_G * Mu_nu2(i,j,ispec)
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_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
! 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
e13_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)
e13_sum = e13_sum + e13(i,j,ispec,i_sls)
enddo
- sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum + TWO * mul_relaxed * e11_sum
- sigma_xz = sigma_xz + mul_relaxed * e13_sum
- sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum - TWO * mul_relaxed * e11_sum
+ sigma_xx = sigma_xx + TWO * mul_G * e11_sum
+ sigma_xz = sigma_xz + mul_G * e13_sum
+ sigma_zz = sigma_zz - TWO * mul_G * e11_sum
else
@@ -391,17 +370,6 @@
endif
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
- sigma_xz = c15val*dux_dxl + c55val*(duz_dxl + dux_dzl) + c35val*duz_dzl
-
- endif
-
! kernels calculation
if(isolver == 2) then
iglob = ibool(i,j,ispec)
@@ -485,10 +453,8 @@
! add - eta_f k^-1 dot(w)
! loop over spectral elements
- do ispec_inner_outer = 1,nspec_inner_outer
+ do ispec = 1,nspec
-! get global numbering for inner or outer elements
- ispec = ispec_inner_outer_to_glob(ispec_inner_outer)
etal_f = poroelastcoef(2,2,kmato(ispec))
if(poroelastic(ispec) .and. etal_f > 0.d0) then
@@ -556,21 +522,16 @@
enddo ! end of loop over all spectral elements
-! only for the first call to compute_forces_fluid (during computation on outer elements)
- if ( num_phase_inner_outer ) then
!
!--- absorbing boundaries
!
if(anyabs) then
-!--- 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 poroelastic parameters of current spectral element
phil = porosity(kmato(ispec))
tortl = tortuosity(kmato(ispec))
@@ -602,6 +563,8 @@
cpIIl = sqrt(cpIIsquare)
csl = sqrt(cssquare)
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
i = 1
@@ -612,14 +575,6 @@
iglob = ibool(i,j,ispec)
-! external velocity model
- if(assign_external_model) then
-! cpl = vpext(i,j,ispec)
-! csl = vsext(i,j,ispec)
-! rhol = rhoext(i,j,ispec)
- endif
-
-
xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xgamma**2 + zgamma**2)
@@ -648,59 +603,24 @@
accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
if(isolver == 1 .and. save_forward) then
- b_absorb_poro_w_left(1,j,ispecabs,it) = tx*weight
- b_absorb_poro_w_left(2,j,ispecabs,it) = tz*weight
+ b_absorb_poro_w_left(1,j,ib_xmin(ispecabs),it) = tx*weight
+ b_absorb_poro_w_left(2,j,ib_xmin(ispecabs),it) = tz*weight
elseif(isolver == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - b_absorb_poro_w_left(1,j,ispecabs,NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - b_absorb_poro_w_left(2,j,ispecabs,NSTEP-it+1)
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_left(1,j,ib_xmin(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_left(2,j,ib_xmin(ispecabs),NSTEP-it+1)
endif
endif
enddo
- enddo
-
endif ! end of left absorbing boundary
!--- right absorbing boundary
- if( nspec_xmax > 0 ) then
-
- do ispecabs = 1, nspec_xmax
+ if(codeabs(IRIGHT,ispecabs)) then
- ispec = ib_xmax(ispecabs)
-
-! 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)) - 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)
-! 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))/(TWO*afactor)
- cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4._CUSTOM_REAL*afactor*cfactor))/(TWO*afactor)
- cssquare = mul_fr/afactor
-
- cpIl = sqrt(cpIsquare)
- cpIIl = sqrt(cpIIsquare)
- csl = sqrt(cssquare)
-
i = NGLLX
jbegin = jbegin_right_poro(ispecabs)
@@ -710,13 +630,6 @@
iglob = ibool(i,j,ispec)
-! external velocity model
- if(assign_external_model) then
-! cpl = vpext(i,j,ispec)
-! csl = vsext(i,j,ispec)
-! rhol = rhoext(i,j,ispec)
- endif
-
xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xgamma**2 + zgamma**2)
@@ -746,79 +659,37 @@
accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
if(isolver == 1 .and. save_forward) then
- b_absorb_poro_w_right(1,j,ispecabs,it) = tx*weight
- b_absorb_poro_w_right(2,j,ispecabs,it) = tz*weight
+ b_absorb_poro_w_right(1,j,ib_xmax(ispecabs),it) = tx*weight
+ b_absorb_poro_w_right(2,j,ib_xmax(ispecabs),it) = tz*weight
elseif(isolver == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - b_absorb_poro_w_right(1,j,ispecabs,NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - b_absorb_poro_w_right(2,j,ispecabs,NSTEP-it+1)
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_right(1,j,ib_xmax(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_right(2,j,ib_xmax(ispecabs),NSTEP-it+1)
endif
endif
enddo
- enddo
-
endif ! end of right absorbing boundary
!--- bottom absorbing boundary
- if( nspec_zmin > 0) then
+ if(codeabs(IBOTTOM,ispecabs)) then
- do ispecabs = 1, nspec_zmin
-
- ispec = ib_zmin(ispecabs)
-
-! 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)) - 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)
-! 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))/(TWO*afactor)
- cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4._CUSTOM_REAL*afactor*cfactor))/(TWO*afactor)
- cssquare = mul_fr/afactor
-
- cpIl = sqrt(cpIsquare)
- cpIIl = sqrt(cpIIsquare)
- csl = sqrt(cssquare)
-
j = 1
ibegin = ibegin_bottom_poro(ispecabs)
iend = iend_bottom_poro(ispecabs)
! exclude corners to make sure there is no contradiction on the normal
- if(nspec_xmin > 0) ibegin = 2
- if(nspec_xmax > 0) iend = NGLLX-1
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
do i = ibegin,iend
iglob = ibool(i,j,ispec)
-! external velocity model
- if(assign_external_model) then
-! cpl = vpext(i,j,ispec)
-! csl = vsext(i,j,ispec)
-! rhol = rhoext(i,j,ispec)
- endif
-
xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xxi**2 + zxi**2)
@@ -848,79 +719,37 @@
accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
if(isolver == 1 .and. save_forward) then
- b_absorb_poro_w_bottom(1,i,ispecabs,it) = tx*weight
- b_absorb_poro_w_bottom(2,i,ispecabs,it) = tz*weight
+ b_absorb_poro_w_bottom(1,i,ib_zmin(ispecabs),it) = tx*weight
+ b_absorb_poro_w_bottom(2,i,ib_zmin(ispecabs),it) = tz*weight
elseif(isolver == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - b_absorb_poro_w_bottom(1,i,ispecabs,NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - b_absorb_poro_w_bottom(2,i,ispecabs,NSTEP-it+1)
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_bottom(1,i,ib_zmin(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_bottom(2,i,ib_zmin(ispecabs),NSTEP-it+1)
endif
endif
enddo
- enddo
-
endif ! end of bottom absorbing boundary
!--- top absorbing boundary
- if( nspec_zmax > 0 ) then
+ if(codeabs(ITOP,ispecabs)) then
- do ispecabs = 1, nspec_zmax
-
- ispec = ib_zmax(ispecabs)
-
-! 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)) - 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)
-! 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))/(TWO*afactor)
- cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4._CUSTOM_REAL*afactor*cfactor))/(TWO*afactor)
- cssquare = mul_fr/afactor
-
- cpIl = sqrt(cpIsquare)
- cpIIl = sqrt(cpIIsquare)
- csl = sqrt(cssquare)
-
j = NGLLZ
ibegin = ibegin_top_poro(ispecabs)
iend = iend_top_poro(ispecabs)
! exclude corners to make sure there is no contradiction on the normal
- if(nspec_xmin > 0) ibegin = 2
- if(nspec_xmax > 0) iend = NGLLX-1
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
do i = ibegin,iend
iglob = ibool(i,j,ispec)
-! external velocity model
- if(assign_external_model) then
-! cpl = vpext(i,j,ispec)
-! csl = vsext(i,j,ispec)
-! rhol = rhoext(i,j,ispec)
- endif
-
xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xxi**2 + zxi**2)
@@ -950,28 +779,29 @@
accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
if(isolver == 1 .and. save_forward) then
- b_absorb_poro_w_top(1,i,ispecabs,it) = tx*weight
- b_absorb_poro_w_top(2,i,ispecabs,it) = tz*weight
+ b_absorb_poro_w_top(1,i,ib_zmax(ispecabs),it) = tx*weight
+ b_absorb_poro_w_top(2,i,ib_zmax(ispecabs),it) = tz*weight
elseif(isolver == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - b_absorb_poro_w_top(1,i,ispecabs,NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - b_absorb_poro_w_top(2,i,ispecabs,NSTEP-it+1)
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_top(1,i,ib_zmax(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_top(2,i,ib_zmax(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
-do i_source=1,NSOURCE
+ do i_source=1,NSOURCE
! if this processor carries the source and the source element is poroelastic
if (is_proc_source(i_source) == 1 .and. poroelastic(ispec_selected_source(i_source))) then
@@ -980,37 +810,16 @@
rhol_f = density(2,kmato(ispec_selected_source(i_source)))
rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-! collocated force
-! beware, for acoustic medium, source is a potential, therefore source time function
-! gives shape of velocity, not displacement
-! The source term is not applied to the fluid equation
- if(source_type(i_source) == 1) then
-
- if(isolver == 1) then ! forward wavefield
- accelw_poroelastic(1,iglob_source(i_source)) = accelw_poroelastic(1,iglob_source(i_source)) - &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,it)
- accelw_poroelastic(2,iglob_source(i_source)) = accelw_poroelastic(2,iglob_source(i_source)) + &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,it)
- else ! backward wavefield
- b_accelw_poroelastic(1,iglob_source(i_source)) = b_accelw_poroelastic(1,iglob_source(i_source)) - &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- b_accelw_poroelastic(2,iglob_source(i_source)) = b_accelw_poroelastic(2,iglob_source(i_source)) + &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- endif !endif isolver == 1
-
! moment tensor
- else if(source_type(i_source) == 2) then
+ if(source_type(i_source) == 2) then
! add source array
if(isolver == 1) then ! forward wavefield
do j=1,NGLLZ
do i=1,NGLLX
iglob = ibool(i,j,ispec_selected_source(i_source))
-!!!!!!!!!!!!!!!!!!!!!!!yang!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
accelw_poroelastic(:,iglob) = accelw_poroelastic(:,iglob) + &
(1._CUSTOM_REAL - rhol_f/rhol_bar)*sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
-! write(*,*) 'rhol_bar = ', rhol_bar
-! accelw_poroelastic(:,iglob) = accelw_poroelastic(:,iglob)
enddo
enddo
else ! backward wavefield
@@ -1023,12 +832,11 @@
enddo
endif !endif isolver == 1
- else
- call exit_MPI('wrong source type in poroelastic element')
- endif
+ endif !if(source_type(i_source) == 2)
endif ! if this processor carries the source and the source element is poroelastic
-enddo
+ enddo
+
if(isolver == 2) then ! adjoint wavefield
irec_local = 0
do irec = 1,nrec
@@ -1055,12 +863,10 @@
endif ! if not using an initial field
- else
-
! implement attenuation
if(TURN_ATTENUATION_ON) then
-! compute Grad(displ_elastic) at time step n+1 for attenuation
+! compute Grad(displs_poroelastic) at time step n+1 for attenuation
call compute_gradient_attenuation(displs_poroelastic,dux_dxl_np1,duz_dxl_np1, &
dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
@@ -1077,28 +883,28 @@
! loop on all the standard linear solids
do i_sls = 1,N_SLS
-! evolution e1
- Un = e1(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu1(i_sls)
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = theta_n * phi_nu1(i_sls)
- Snp1 = theta_np1 * phi_nu1(i_sls)
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e1(i,j,ispec,i_sls) = Unp1
+! evolution e1 ! no need since we are just considering shear attenuation
+! Un = e1(i,j,ispec,i_sls)
+! tauinv = - inv_tau_sigma_nu1(i,j,ispec,i_sls)
+! tauinvsquare = tauinv * tauinv
+! tauinvcube = tauinvsquare * tauinv
+! tauinvUn = tauinv * Un
+! Sn = theta_n * phi_nu1(i,j,ispec,i_sls)
+! Snp1 = theta_np1 * phi_nu1(i,j,ispec,i_sls)
+! Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+! twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+! fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+! deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+! e1(i,j,ispec,i_sls) = Unp1
! evolution e11
Un = e11(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
tauinvsquare = tauinv * tauinv
tauinvcube = tauinvsquare * tauinv
tauinvUn = tauinv * Un
- Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i_sls)
- Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i_sls)
+ Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i,j,ispec,i_sls)
Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
@@ -1107,12 +913,12 @@
! evolution e13
Un = e13(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
tauinvsquare = tauinv * tauinv
tauinvcube = tauinvsquare * tauinv
tauinvUn = tauinv * Un
- Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i_sls)
- Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i_sls)
+ Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
@@ -1127,7 +933,5 @@
endif ! end of test on attenuation
- endif ! if ( num_phase_inner_outer )
-
end subroutine compute_forces_fluid
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_solid.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_solid.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_forces_solid.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -42,27 +42,26 @@
!
!========================================================================
- subroutine compute_forces_solid(npoin,nspec,myrank,numat,iglob_source, &
+ subroutine compute_forces_solid(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,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,poroelastic, &
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
accels_poroelastic,velocs_poroelastic,velocw_poroelastic,displs_poroelastic,displw_poroelastic,&
b_accels_poroelastic,b_displs_poroelastic,b_velocw_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, &
+ jacobian,source_time_function,sourcearray,adj_sourcearrays,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, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu2,N_SLS, &
rx_viscous,rz_viscous,theta_e,theta_s,&
b_viscodampx,b_viscodampz,&
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_outer,ispec_inner_outer_to_glob,num_phase_inner_outer,nrec,isolver,save_forward,&
+ mufr_k,B_k,NSOURCE,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,NSOURCE)
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax)
! compute forces for the solid poroelastic part
@@ -71,16 +70,16 @@
include "constants.h"
integer :: NSOURCE, i_source
integer, dimension(NSOURCE) :: iglob_source,ispec_selected_source,source_type,is_proc_source
- integer :: npoin,nspec,myrank,numat,it,NSTEP
- integer :: nrec,isolver
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP
+ integer :: nrec,isolver,myrank
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_poro,jend_left_poro
- integer, dimension(nspec_xmax) :: ib_xmax,jbegin_right_poro,jend_right_poro
- integer, dimension(nspec_zmin) :: ib_zmin,ibegin_bottom_poro,iend_bottom_poro
- integer, dimension(nspec_zmax) :: ib_zmax,ibegin_top_poro,iend_top_poro
+ 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
+ logical :: anyabs,initialfield,TURN_ATTENUATION_ON
logical :: save_forward
double precision :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
@@ -88,8 +87,11 @@
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
integer, dimension(nspec) :: kmato
+ integer, dimension(nelemabs) :: numabs,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro
logical, dimension(nspec) :: poroelastic
+ logical, dimension(4,nelemabs) :: codeabs
real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: accels_poroelastic,velocs_poroelastic,displs_poroelastic
real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: velocw_poroelastic,displw_poroelastic
@@ -100,7 +102,6 @@
double precision, dimension(numat) :: porosity,tortuosity
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,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NSOURCE,NSTEP) :: source_time_function
real(kind=CUSTOM_REAL), dimension(NSOURCE,NDIM,NGLLX,NGLLZ) :: sourcearray
real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,NDIM,NGLLX,NGLLZ) :: adj_sourcearrays
@@ -112,10 +113,10 @@
real(kind=CUSTOM_REAL), dimension(npoin) :: b_viscodampx,b_viscodampz
integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11,e13
- double precision, dimension(N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
- double precision :: Mu_nu1,Mu_nu2
- real(kind=CUSTOM_REAL) :: e1_sum,e11_sum,e13_sum
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e11,e13
+ double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu2,phi_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu2
+ real(kind=CUSTOM_REAL) :: e11_sum,e13_sum
integer :: i_sls
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: &
@@ -136,16 +137,12 @@
real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-! for overlapping MPI communications with computation
- integer, intent(in) :: nspec_inner_outer
- integer, dimension(max(1,nspec_inner_outer)), intent(in) :: ispec_inner_outer_to_glob
- logical, intent(in) :: num_phase_inner_outer
!---
!--- local variables
!---
- integer :: ispec,ispec_inner_outer,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend,irec,irec_local
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend,irec,irec_local
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
@@ -176,7 +173,6 @@
! material properties of the poroelastic medium
real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed
real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
real(kind=CUSTOM_REAL) :: etal_f,kappal_f,rhol_f
real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl,viscodampx,viscodampz
@@ -189,19 +185,13 @@
! for attenuation
real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
-! only for the first call to compute_forces_solid (during computation on outer elements)
- if ( num_phase_inner_outer ) then
-! compute Grad(displ_elastic) at time step n for attenuation
+! compute Grad(displs_poroelastic) at time step n for attenuation
if(TURN_ATTENUATION_ON) call compute_gradient_attenuation(displs_poroelastic,dux_dxl_n,duz_dxl_n, &
dux_dzl_n,duz_dzl_n,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
- endif
! loop over spectral elements
- do ispec_inner_outer = 1,nspec_inner_outer
+ do ispec = 1,nspec
-! get global numbering for inner or outer elements
- ispec = ispec_inner_outer_to_glob(ispec_inner_outer)
-
!---
!--- poroelastic spectral element
!---
@@ -239,18 +229,6 @@
do j = 1,NGLLZ
do i = 1,NGLLX
-!--- if external medium, get poroelastic parameters of current grid point
- if(assign_external_model) then
- stop 'external model is elastic and/or acoustic'
-! at the moment external model are elastic and/or acoustic
-! cpl = vpext(i,j,ispec)
-! csl = vsext(i,j,ispec)
-! rhol_s = rhoext(i,j,ispec)
-! mul_relaxed = rhol_s*csl*csl
-! lambdal_relaxed = rhol_s*cpl*cpl - TWO*mul_relaxed
-! lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
- endif
-
! derivative along x and along z for u_s and w
dux_dxi = ZERO
duz_dxi = ZERO
@@ -339,7 +317,7 @@
! compute stress tensor (include attenuation or anisotropy if needed)
if(TURN_ATTENUATION_ON) then
-
+! Dissipation only controlled by frame share attenuation in poroelastic (see Morency & Tromp, GJI 2008).
! 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
@@ -347,30 +325,30 @@
! 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
+ lambdal_unrelaxed = (lambdal_G + mul_G) - mul_G * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_G * Mu_nu2(i,j,ispec)
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_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
! 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
e13_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)
e13_sum = e13_sum + e13(i,j,ispec,i_sls)
enddo
- sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum + TWO * mul_relaxed * e11_sum
- sigma_xz = sigma_xz + mul_relaxed * e13_sum
- sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum - TWO * mul_relaxed * e11_sum
+ sigma_xx = sigma_xx + TWO * mul_G * e11_sum
+ sigma_xz = sigma_xz + mul_G * e13_sum
+ sigma_zz = sigma_zz - TWO * mul_G * e11_sum
else
@@ -390,17 +368,6 @@
endif
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
- sigma_xz = c15val*dux_dxl + c55val*(duz_dxl + dux_dzl) + c35val*duz_dzl
-
- endif
-
! kernels calculation
if(isolver == 2) then
iglob = ibool(i,j,ispec)
@@ -501,10 +468,8 @@
! add + phi/tort eta_f k^-1 dot(w)
! loop over spectral elements
- do ispec_inner_outer = 1,nspec_inner_outer
+ do ispec = 1,nspec
-! get global numbering for inner or outer elements
- ispec = ispec_inner_outer_to_glob(ispec_inner_outer)
etal_f = poroelastcoef(2,2,kmato(ispec))
if(poroelastic(ispec) .and. etal_f >0.d0) then
@@ -559,6 +524,7 @@
accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + phil/tortl*wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
viscodampz
+! if isolver == 1 .and. save_forward then b_viscodamp is save in compute_forces_fluid.f90
if(isolver == 2) then ! kernels calculation
b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + phil/tortl*b_viscodampx(iglob)
b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + phil/tortl*b_viscodampz(iglob)
@@ -571,21 +537,16 @@
enddo ! end of loop over all spectral elements
-! only for the first call to compute_forces_solid (during computation on outer elements)
- if ( num_phase_inner_outer ) then
!
!--- absorbing boundaries
!
if(anyabs) then
-!--- 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 poroelastic parameters of current spectral element
phil = porosity(kmato(ispec))
tortl = tortuosity(kmato(ispec))
@@ -617,6 +578,8 @@
cpIIl = sqrt(cpIIsquare)
csl = sqrt(cssquare)
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
i = 1
@@ -627,18 +590,7 @@
iglob = ibool(i,j,ispec)
-! external velocity model
- if(assign_external_model) then
-! cpl = vpext(i,j,ispec)
-! csl = vsext(i,j,ispec)
-! rhol = rhoext(i,j,ispec)
- endif
-
-! rho_vpI = (rhol_bar - phil/tortl*rhol_f)*cpIl
-! rho_vpII = (rhol_bar - phil/tortl*rhol_f)*cpIIl
-! rho_vs = (rhol_bar - phil/tortl*rhol_f)*csl
-
xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xgamma**2 + zgamma**2)
@@ -669,59 +621,24 @@
accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
if(isolver == 1 .and. save_forward) then
- b_absorb_poro_s_left(1,j,ispecabs,it) = tx*weight
- b_absorb_poro_s_left(2,j,ispecabs,it) = tz*weight
+ b_absorb_poro_s_left(1,j,ib_xmin(ispecabs),it) = tx*weight
+ b_absorb_poro_s_left(2,j,ib_xmin(ispecabs),it) = tz*weight
elseif(isolver == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - b_absorb_poro_s_left(1,j,ispecabs,NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - b_absorb_poro_s_left(2,j,ispecabs,NSTEP-it+1)
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_left(1,j,ib_xmin(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_left(2,j,ib_xmin(ispecabs),NSTEP-it+1)
endif
endif
enddo
- enddo
-
endif ! end of left absorbing boundary
!--- right absorbing boundary
- if( nspec_xmax > 0 ) then
-
- do ispecabs = 1, nspec_xmax
-
- ispec = ib_xmax(ispecabs)
-
-! 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)) - 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)
-! 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))/(TWO*afactor)
- cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4._CUSTOM_REAL*afactor*cfactor))/(TWO*afactor)
- cssquare = mul_fr/afactor
-
- cpIl = sqrt(cpIsquare)
- cpIIl = sqrt(cpIIsquare)
- csl = sqrt(cssquare)
-
+ if(codeabs(IRIGHT,ispecabs)) then
+
i = NGLLX
jbegin = jbegin_right_poro(ispecabs)
@@ -731,13 +648,6 @@
iglob = ibool(i,j,ispec)
-! external velocity model
- if(assign_external_model) then
-! cpl = vpext(i,j,ispec)
-! csl = vsext(i,j,ispec)
-! rhol = rhoext(i,j,ispec)
- endif
-
xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xgamma**2 + zgamma**2)
@@ -767,78 +677,37 @@
accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
if(isolver == 1 .and. save_forward) then
- b_absorb_poro_s_right(1,j,ispecabs,it) = tx*weight
- b_absorb_poro_s_right(2,j,ispecabs,it) = tz*weight
+ b_absorb_poro_s_right(1,j,ib_xmax(ispecabs),it) = tx*weight
+ b_absorb_poro_s_right(2,j,ib_xmax(ispecabs),it) = tz*weight
elseif(isolver == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - b_absorb_poro_s_right(1,j,ispecabs,NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - b_absorb_poro_s_right(2,j,ispecabs,NSTEP-it+1)
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_right(1,j,ib_xmax(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_right(2,j,ib_xmax(ispecabs),NSTEP-it+1)
endif
endif
enddo
- enddo
endif ! end of right absorbing boundary
!--- bottom absorbing boundary
- if( nspec_zmin > 0) then
+ if(codeabs(IBOTTOM,ispecabs)) then
- do ispecabs = 1, nspec_zmin
-
- ispec = ib_zmin(ispecabs)
-
-! 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)) - 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)
-! 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))/(TWO*afactor)
- cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4._CUSTOM_REAL*afactor*cfactor))/(TWO*afactor)
- cssquare = mul_fr/afactor
-
- cpIl = sqrt(cpIsquare)
- cpIIl = sqrt(cpIIsquare)
- csl = sqrt(cssquare)
-
j = 1
ibegin = ibegin_bottom_poro(ispecabs)
iend = iend_bottom_poro(ispecabs)
! exclude corners to make sure there is no contradiction on the normal
- if( nspec_xmin > 0 ) ibegin = 2
- if( nspec_xmax > 0 ) iend = NGLLX-1
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
do i = ibegin,iend
iglob = ibool(i,j,ispec)
-! external velocity model
- if(assign_external_model) then
-! cpl = vpext(i,j,ispec)
-! csl = vsext(i,j,ispec)
-! rhol = rhoext(i,j,ispec)
- endif
-
xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xxi**2 + zxi**2)
@@ -868,79 +737,37 @@
accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
if(isolver == 1 .and. save_forward) then
- b_absorb_poro_s_bottom(1,i,ispecabs,it) = tx*weight
- b_absorb_poro_s_bottom(2,i,ispecabs,it) = tz*weight
+ b_absorb_poro_s_bottom(1,i,ib_zmin(ispecabs),it) = tx*weight
+ b_absorb_poro_s_bottom(2,i,ib_zmin(ispecabs),it) = tz*weight
elseif(isolver == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - b_absorb_poro_s_bottom(1,i,ispecabs,NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - b_absorb_poro_s_bottom(2,i,ispecabs,NSTEP-it+1)
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_bottom(1,i,ib_zmin(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_bottom(2,i,ib_zmin(ispecabs),NSTEP-it+1)
endif
endif
enddo
- enddo
-
endif ! end of bottom absorbing boundary
!--- top absorbing boundary
- if( nspec_zmax > 0 ) then
+ if(codeabs(ITOP,ispecabs)) then
- do ispecabs = 1, nspec_zmax
-
- ispec = ib_zmax(ispecabs)
-
-! 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)) - 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)
-! 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))/(TWO*afactor)
- cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4._CUSTOM_REAL*afactor*cfactor))/(TWO*afactor)
- cssquare = mul_fr/afactor
-
- cpIl = sqrt(cpIsquare)
- cpIIl = sqrt(cpIIsquare)
- csl = sqrt(cssquare)
-
j = NGLLZ
ibegin = ibegin_top_poro(ispecabs)
iend = iend_top_poro(ispecabs)
! exclude corners to make sure there is no contradiction on the normal
- if( nspec_xmin > 0) ibegin = 2
- if( nspec_xmax > 0) iend = NGLLX-1
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
do i = ibegin,iend
iglob = ibool(i,j,ispec)
-! external velocity model
- if(assign_external_model) then
-! cpl = vpext(i,j,ispec)
-! csl = vsext(i,j,ispec)
-! rhol = rhoext(i,j,ispec)
- endif
-
xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
jacobian1D = sqrt(xxi**2 + zxi**2)
@@ -970,28 +797,29 @@
accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
if(isolver == 1 .and. save_forward) then
- b_absorb_poro_s_top(1,i,ispecabs,it) = tx*weight
- b_absorb_poro_s_top(2,i,ispecabs,it) = tz*weight
+ b_absorb_poro_s_top(1,i,ib_zmax(ispecabs),it) = tx*weight
+ b_absorb_poro_s_top(2,i,ib_zmax(ispecabs),it) = tz*weight
elseif(isolver == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - b_absorb_poro_s_top(1,i,ispecabs,NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - b_absorb_poro_s_top(2,i,ispecabs,NSTEP-it+1)
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_top(1,i,ib_zmax(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_top(2,i,ib_zmax(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
-do i_source=1,NSOURCE
+ do i_source=1,NSOURCE
! if this processor carries the source and the source element is poroelastic
if (is_proc_source(i_source) == 1 .and. poroelastic(ispec_selected_source(i_source))) then
@@ -999,25 +827,8 @@
phil = porosity(kmato(ispec_selected_source(i_source)))
tortl = tortuosity(kmato(ispec_selected_source(i_source)))
-! collocated force
-! beware, for acoustic medium, source is a potential, therefore source time function
-! gives shape of velocity, not displacement
- if(source_type(i_source) == 1) then
-
- if(isolver == 1) then ! forward wavefield
- accels_poroelastic(1,iglob_source(i_source)) = accels_poroelastic(1,iglob_source(i_source)) - &
- (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,it)
- accels_poroelastic(2,iglob_source(i_source)) = accels_poroelastic(2,iglob_source(i_source)) + &
- (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,it)
- else ! backward wavefield
- b_accels_poroelastic(1,iglob_source(i_source)) = b_accels_poroelastic(1,iglob_source(i_source)) - &
- (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- b_accels_poroelastic(2,iglob_source(i_source)) = b_accels_poroelastic(2,iglob_source(i_source)) + &
- (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- endif !endif isolver == 1
-
! moment tensor
- else if(source_type(i_source) == 2) then
+ if(source_type(i_source) == 2) then
! add source array
if(isolver == 1) then ! forward wavefield
@@ -1035,15 +846,14 @@
b_accels_poroelastic(:,iglob) = b_accels_poroelastic(:,iglob) + &
(1._CUSTOM_REAL - phil/tortl)*sourcearray(i_source,:,i,j)*source_time_function(i_source,NSTEP-it+1)
enddo
- enddo
+ enddo
endif !endif isolver == 1
- else
- call exit_MPI('wrong source type in poroelastic element')
- endif
+ endif !if(source_type(i_source) == 2)
endif ! if this processor carries the source and the source element is poroelastic
-enddo
+ enddo
+
if(isolver == 2) then ! adjoint wavefield
irec_local = 0
do irec = 1,nrec
@@ -1065,12 +875,10 @@
endif ! if not using an initial field
- else
-
! implement attenuation
if(TURN_ATTENUATION_ON) then
-! compute Grad(displs_elastic) at time step n+1 for attenuation
+! compute Grad(displs_poroelastic) at time step n+1 for attenuation
call compute_gradient_attenuation(displs_poroelastic,dux_dxl_np1,duz_dxl_np1, &
dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
@@ -1087,28 +895,28 @@
! loop on all the standard linear solids
do i_sls = 1,N_SLS
-! evolution e1
- Un = e1(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu1(i_sls)
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = theta_n * phi_nu1(i_sls)
- Snp1 = theta_np1 * phi_nu1(i_sls)
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e1(i,j,ispec,i_sls) = Unp1
+! evolution e1 ! no need since we are just considering shear attenuation
+! Un = e1(i,j,ispec,i_sls)
+! tauinv = - inv_tau_sigma_nu1(i,j,ispec,i_sls)
+! tauinvsquare = tauinv * tauinv
+! tauinvcube = tauinvsquare * tauinv
+! tauinvUn = tauinv * Un
+! Sn = theta_n * phi_nu1(i,j,ispec,i_sls)
+! Snp1 = theta_np1 * phi_nu1(i,j,ispec,i_sls)
+! Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+! twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+! fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+! deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+! e1(i,j,ispec,i_sls) = Unp1
! evolution e11
Un = e11(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
tauinvsquare = tauinv * tauinv
tauinvcube = tauinvsquare * tauinv
tauinvUn = tauinv * Un
- Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i_sls)
- Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i_sls)
+ Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i,j,ispec,i_sls)
Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
@@ -1117,12 +925,12 @@
! evolution e13
Un = e13(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
tauinvsquare = tauinv * tauinv
tauinvcube = tauinvsquare * tauinv
tauinvUn = tauinv * Un
- Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i_sls)
- Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i_sls)
+ Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
@@ -1137,7 +945,6 @@
endif ! end of test on attenuation
- endif ! if ( num_phase_inner_outer )
end subroutine compute_forces_solid
Modified: seismo/2D/SPECFEM2D/branches/BIOT/compute_gradient_attenuation.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/compute_gradient_attenuation.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_gradient_attenuation.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_pressure.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -4,12 +4,10 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -45,7 +43,7 @@
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,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,elastcoef,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
@@ -61,7 +59,7 @@
double precision, dimension(2,numat) :: density
double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(4,3,numat) :: elastcoef
double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
@@ -79,7 +77,7 @@
integer :: N_SLS
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
- double precision :: Mu_nu1,Mu_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
! local variables
integer :: i,j,ispec,iglob
@@ -94,7 +92,7 @@
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, &
+ numat,kmato,density,porosity,tortuosity,elastcoef,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
@@ -116,10 +114,10 @@
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,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,elastcoef,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 (poro)elastic elements
+! compute pressure in acoustic elements and in elastic elements
implicit none
@@ -132,7 +130,7 @@
double precision, dimension(2,numat) :: density
double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(4,3,numat) :: elastcoef
double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
@@ -153,7 +151,7 @@
integer :: N_SLS
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
real(kind=CUSTOM_REAL) :: e1_sum,e11_sum
- double precision :: Mu_nu1,Mu_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
integer :: i_sls
! local variables
@@ -169,8 +167,7 @@
real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dzl
-! material properties of the (poro)elastic medium
- integer :: material
+! material properties of the elastic medium
real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,denst
real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed,cpl,csl
@@ -205,9 +202,9 @@
if(elastic(ispec)) then
! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec))
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = elastcoef(3,1,kmato(ispec))
do j = 1,NGLLZ
do i = 1,NGLLX
@@ -257,8 +254,8 @@
! 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
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(i,j,ispec) - mul_relaxed * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_relaxed * Mu_nu2(i,j,ispec)
lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
@@ -307,15 +304,15 @@
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
+ mul_s = elastcoef(2,1,kmato(ispec))
+ kappal_s = elastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
rhol_s = density(1,kmato(ispec))
!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
+ kappal_f = elastcoef(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
+ mul_fr = elastcoef(2,3,kmato(ispec))
+ kappal_fr = elastcoef(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))
@@ -332,15 +329,6 @@
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
@@ -381,7 +369,7 @@
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)
+! compute diagonal components of the stress tensor (include attenuation if needed)
if(TURN_ATTENUATION_ON) then
!-------------------- ATTENTION TO BE DEFINED ------------------------------!
@@ -393,8 +381,8 @@
! 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
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(i,j,ispec) - mul_relaxed * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_relaxed * Mu_nu2(i,j,ispec)
lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
@@ -424,35 +412,22 @@
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
+! pressure = - Chi_dot_dot if acoustic element
+ else
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) = - denst * potential_dot_dot_acoustic(iglob)
+ pressure_element(i,j) = - 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/compute_vector_field.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,15 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 6.3
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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,8 +41,8 @@
!========================================================================
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)
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
! compute Grad(potential) in acoustic elements
! and combine with existing velocity vector field in elastic elements
@@ -53,8 +51,16 @@
include "constants.h"
- integer nspec,npoin
+ integer nspec,npoin,numat
+ logical :: assign_external_model
+
+ integer, dimension(nspec) :: kmato
+
+ double precision, dimension(NGLLX,NGLLX,nspec) :: rhoext
+
+ double precision, dimension(2,numat) :: density
+
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
@@ -78,9 +84,9 @@
do ispec = 1,nspec
! compute vector field in this element
- 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)
+ 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,numat,kmato,&
+ density,rhoext,assign_external_model)
! store the result
do j = 1,NGLLZ
@@ -98,9 +104,9 @@
!=====================================================================
!
- 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)
+ 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,numat,kmato,&
+ density,rhoext,assign_external_model)
! compute Grad(potential) if acoustic element or copy existing vector if elastic element
@@ -108,8 +114,16 @@
include "constants.h"
- integer nspec,npoin,ispec
+ integer nspec,npoin,ispec,numat
+ logical :: assign_external_model
+
+ integer, dimension(nspec) :: kmato
+
+ double precision, dimension(NGLLX,NGLLX,nspec) :: rhoext
+
+ double precision, dimension(2,numat) :: density
+
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
@@ -135,6 +149,9 @@
! 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
@@ -156,8 +173,11 @@
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(1,kmato(ispec))
+
! double loop over GLL points to compute and store gradients
do j = 1,NGLLZ
do i = 1,NGLLX
@@ -183,9 +203,11 @@
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
- vector_field_element(2,i,j) = tempx1l*xizl + tempx2l*gammazl
+ vector_field_element(1,i,j) = (tempx1l*xixl + tempx2l*gammaxl) / rhol
+ vector_field_element(2,i,j) = (tempx1l*xizl + tempx2l*gammazl) / rhol
enddo
enddo
Modified: seismo/2D/SPECFEM2D/branches/BIOT/constants.h
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/constants.h 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/constants.h 2009-07-30 21:33:24 UTC (rev 15488)
@@ -9,13 +9,59 @@
! DO NOT forget to change precision_mpi.h accordingly
!
integer, parameter :: CUSTOM_REAL = SIZE_DOUBLE
-! integer, parameter :: CUSTOM_REAL = SIZE_REAL
+! integer, parameter :: CUSTOM_REAL = SIZE_REAL
! polynomial degree
integer, parameter :: NGLLX = 5
! the code does NOT work if NGLLZ /= NGLLX because it then cannot handle a non-structured mesh
integer, parameter :: NGLLZ = NGLLX
+! 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.
+
+! for inverse Cuthill-McKee (1969) permutation
+ logical, parameter :: PERFORM_CUTHILL_MCKEE = .true.
+ logical, parameter :: INVERSE = .true.
+ logical, parameter :: FACE = .false.
+ integer, parameter :: NGNOD_QUADRANGLE = 4
+! perform classical or multi-level Cuthill-McKee ordering
+ logical, parameter :: CMcK_MULTI = .false.
+! maximum size if multi-level Cuthill-McKee ordering
+ integer, parameter :: LIMIT_MULTI_CUTHILL = 50
+
+! implement Cuthill-McKee or replace with identity permutation
+ logical, parameter :: ACTUALLY_IMPLEMENT_PERM_OUT = .false.
+ logical, parameter :: ACTUALLY_IMPLEMENT_PERM_INN = .false.
+ logical, parameter :: ACTUALLY_IMPLEMENT_PERM_WHOLE = .true.
+
+! add MPI barriers and suppress seismograms if we generate traces of the run for analysis with "ParaVer"
+ logical, parameter :: GENERATE_PARAVER_TRACES = .false.
+
+! option to display only part of the mesh and not the whole mesh,
+! for instance to analyze Cuthill-McKee mesh partitioning etc.
+! Possible values are:
+! 1: display all the elements (i.e., the whole mesh)
+! 2: display inner elements only
+! 3: display outer elements only
+! 4: display a fixed number of elements (in each partition) only
+ integer, parameter :: DISPLAY_SUBSET_OPTION = 1
+! number of spectral elements to display in each subset when a fixed subset size is used (option 4 above)
+ integer, parameter :: NSPEC_DISPLAY_SUBSET = 2300
+
+!--- beginning of Nicolas Le Goff's constants for an unstructured CUBIT/METIS/SCOTCH mesh
+
+! number of nodes per element
+ integer, parameter :: ESIZE = 4
+
+! maximum number of neighbors per element
+ integer, parameter :: max_neighbor = 30
+
+! maximum number of elements that can contain the same node
+ integer, parameter :: nsize = 20
+
+!--- end of Nicolas Le Goff's constants for an unstructured CUBIT/METIS/SCOTCH mesh
+
! compute and output acoustic and elastic energy (slows down the code significantly)
logical, parameter :: OUTPUT_ENERGY = .false.
@@ -26,7 +72,7 @@
logical, parameter :: FAST_NUMBERING = .true.
! mesh tolerance for fast global numbering
- double precision, parameter :: SMALLVALTOL = 0.000001d0
+ double precision, parameter :: SMALLVALTOL = 0.00001d0
! displacement threshold above which we consider the code became unstable
double precision, parameter :: STABILITY_THRESHOLD = 1.d+25
Modified: seismo/2D/SPECFEM2D/branches/BIOT/construct_acoustic_surface.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/construct_acoustic_surface.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/construct_acoustic_surface.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/convolve_source_timefunction.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/create_color_image.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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,8 +252,6 @@
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 ; rm -f image',i7.7,'.pnm')") it,it,it
-! for cluster
write(system_command,"('cd OUTPUT_FILES ; convert image',i7.7,'.pnm image',i7.7,'.gif')") it,it
! call the system to convert image to GIF
Modified: seismo/2D/SPECFEM2D/branches/BIOT/createnum_fast.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/createnum_fast.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/createnum_fast.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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,7 +40,7 @@
!
!========================================================================
- subroutine createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod)
+ subroutine createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
! equivalent de la routine "createnum_slow" mais algorithme plus rapide
@@ -48,7 +48,7 @@
include "constants.h"
- integer npoin,npgeo,nspec,ngnod
+ integer npoin,npgeo,nspec,ngnod,myrank,ipass
integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
double precision shape(ngnod,NGLLX,NGLLX)
double precision coorg(NDIM,npgeo)
@@ -68,10 +68,12 @@
!---- create global mesh numbering
- write(IOUT,*)
- write(IOUT,*)
- write(IOUT,*) 'Generating global mesh numbering (fast version)...'
- write(IOUT,*)
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,*) 'Generating global mesh numbering (fast version)...'
+ write(IOUT,*)
+ endif
nxyz = NGLLX*NGLLZ
ntot = nxyz*nspec
@@ -147,7 +149,7 @@
enddo
! define a tolerance, small with respect to the minimum size
- xtol=smallvaltol*xtypdist
+ xtol = SMALLVALTOL * xtypdist
ifseg(:) = .false.
nseg = 1
@@ -202,7 +204,7 @@
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! recuperer resultat a mon format
+! get result in my format
do ispec=1,nspec
ieoff = nxyz*(ispec - 1)
ilocnum = 0
@@ -224,15 +226,15 @@
deallocate(work)
deallocate(iwork)
-! verification de la coherence de la numerotation generee
- if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) then
- call exit_MPI('Error while generating global numbering')
+! check the numbering obtained
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) call exit_MPI('Error while generating global numbering')
+
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Total number of points of the global mesh: ',npoin
+ write(IOUT,*)
endif
- write(IOUT,*)
- write(IOUT,*) 'Total number of points of the global mesh: ',npoin
- write(IOUT,*)
-
end subroutine createnum_fast
Modified: seismo/2D/SPECFEM2D/branches/BIOT/createnum_slow.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/createnum_slow.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/createnum_slow.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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,7 +40,7 @@
!
!========================================================================
- subroutine createnum_slow(knods,ibool,npoin,nspec,ngnod)
+ subroutine createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
! generate the global numbering
@@ -48,7 +48,7 @@
include "constants.h"
- integer npoin,nspec,ngnod
+ integer npoin,nspec,ngnod,myrank,ipass
integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
@@ -61,9 +61,11 @@
!---- create global mesh numbering
- write(IOUT,*)
- write(IOUT,*) 'Generating global mesh numbering (slow version)...'
- write(IOUT,*)
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Generating global mesh numbering (slow version)...'
+ write(IOUT,*)
+ endif
npoin = 0
npedge = 0
@@ -268,14 +270,10 @@
endif
! verifier que le point de depart n'existe pas deja
- if(ibool(iloc,jloc,numelem) /= 0) then
- call exit_MPI('point genere deux fois')
- endif
+ if(ibool(iloc,jloc,numelem) /= 0) call exit_MPI('point generated twice')
! verifier que le point d'arrivee existe bien deja
- if(ibool(i2,j2,num2) == 0) then
- call exit_MPI('point inconnu dans le maillage')
- endif
+ if(ibool(i2,j2,num2) == 0) call exit_MPI('unknown point in the mesh')
! affecter le meme numero
ibool(iloc,jloc,numelem) = ibool(i2,j2,num2)
@@ -309,17 +307,16 @@
enddo
! verification de la coherence de la numerotation generee
- if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) then
- call exit_MPI('Error while generating global numbering')
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) call exit_MPI('Error while generating global numbering')
+
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*) 'Total number of points of the global mesh: ',npoin,' distributed as follows:'
+ write(IOUT,*)
+ write(IOUT,*) 'Number of interior points: ',npoin-npedge-npcorn
+ write(IOUT,*) 'Number of edge points (without corners): ',npedge
+ write(IOUT,*) 'Number of corner points: ',npcorn
+ write(IOUT,*)
endif
- write(IOUT,*) 'Total number of points of the global mesh: ',npoin
- write(IOUT,*) 'distributed as follows:'
- write(IOUT,*)
- write(IOUT,*) 'Number of interior points: ',npoin-npedge-npcorn
- write(IOUT,*) 'Number of edge points (without corners): ',npedge
- write(IOUT,*) 'Number of corner points: ',npcorn
- write(IOUT,*)
-
end subroutine createnum_slow
Modified: seismo/2D/SPECFEM2D/branches/BIOT/datim.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/datim.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/datim.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/define_derivation_matrices.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/define_external_model.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/define_shape_functions.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/enforce_acoustic_free_surface.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/gmat01.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,18 +1,16 @@
!========================================================================
!
-! S P E C F E M 2 D Version 6.3
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 and poroelastic wave equations
+! the two-dimensional viscoelastic anisotropic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
@@ -42,29 +40,33 @@
!
!========================================================================
- subroutine gmat01(density_array,porosity_array,tortuosity_array,permeability,poroelastcoef,numat)
+ subroutine gmat01(density_array,porosity_array,tortuosity_array,permeability,poroelastcoef,&
+ numat,myrank,ipass,Qp_array,Qs_array)
-! 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
+! read properties of a 2D isotropic or anisotropic linear elastic element
implicit none
include "constants.h"
character(len=80) datlin
+ double precision lambdaplus2mu,kappa
- integer numat
+ integer numat,myrank,ipass
double precision density_array(2,numat),poroelastcoef(4,3,numat),porosity_array(numat)
double precision tortuosity_array(numat),permeability(3,numat)
+ double precision Qp_array(numat),Qs_array(numat)
integer in,n,indic
+ double precision young,poisson,cp,cs,mu,two_mu,lambda,Qp,Qs
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 val1,val2,val3,val4,val5,val6
+ double precision val7,val8,val9,val10,val11,val12,val0
double precision c11,c13,c33,c44
+ double precision afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,density_bar
- double precision afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,density_bar
!
!---- loop over the different material sets
!
@@ -73,28 +75,78 @@
tortuosity_array(:) = zero
permeability(:,:) = zero
poroelastcoef(:,:,:) = zero
+ Qp_array(:) = zero
+ Qs_array(:) = zero
- write(iout,100) numat
+ if(myrank == 0 .and. ipass == 1) write(IOUT,100) numat
- read(iin ,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
do in = 1,numat
- 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)
+ read(IIN,*) n,indic,val0,val1,val2,val3,val4,val5,val6,val7,val8,val9,val10,val11,val12
if(n<1 .or. n>numat) call exit_MPI('Wrong material set number')
-!---- isotropic material, kappa and mu/eta, for solid, fluid, and frame given
+!---- isotropic material, P and S velocities given, allows for declaration of elastic/acoustic material
+!---- elastic (cs/=0) and acoustic (cs=0)
if(indic == 1) then
+ density(1) = val0
+! P and S velocity
+ cp = val1
+ cs = val2
+
+! Qp and Qs values
+ Qp = val5
+ Qs = val6
+
+! Lam'e parameters
+ lambdaplus2mu = density(1)*cp*cp
+ mu = density(1)*cs*cs
+ two_mu = 2.d0*mu
+ lambda = lambdaplus2mu - two_mu
+
+! bulk modulus Kappa
+ kappa = lambda + two_mu/3.d0
+
+! Young modulus
+ young = 9.d0*kappa*mu/(3.d0*kappa + mu)
+
+! 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')
+
+!---- anisotropic material, c11, c13, c33 and c44 given in Pascal
+ else if (indic == 2) then
+
+ density(1) =val0
+ c11 = val1
+ c13 = val2
+ c33 = val3
+ c44 = val4
+
+!---- isotropic material, moduli are given, allows for declaration of poroelastic material
+!---- poroelastic (<0phi<1)
+ else if (indic == 3) then
+! Qs values
+ Qs = val12
+
+ density(1) =val0
+ density(2) =val1
+
! Solid properties
- kappa_s = vals(1)
- mu_s = vals(2)
+ kappa_s = val7
+ mu_s = val11
! Fluid properties
- kappa_f = valf(1)
- eta_f = valf(2)
+ kappa_f = val8
+ eta_f = val10
! Frame properties
- kappa_fr = valfr(1)
- mu_fr = valfr(2)
+ kappa_fr = val9
+ mu_fr = val11
! 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
@@ -113,13 +165,14 @@
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)
-
- if(phi <= 0.d0) then
- cssquare = mu_s/afactor
- else
- cssquare = mu_fr/afactor
- endif
+ cssquare = val11/afactor
+ porosity_array(n) = val2
+ tortuosity_array(n) = val3
+ permeability(1,n) = val4
+ permeability(2,n) = val5
+ permeability(3,n) = val6
+
! Young modulus for the solid phase
young_s = 9.d0*kappa_s*mu_s/(3.d0*kappa_s + mu_s)
@@ -129,14 +182,6 @@
! Poisson's ratio must be between -1 and +1/2
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
- stop 'Attention, anisotropic still needs to be defined'
-! c11 = val1
-! c13 = val2
-! c33 = val3
-! c44 = val4
-
else
call exit_MPI('wrong model flag read')
@@ -145,12 +190,36 @@
!
!---- set elastic coefficients and density
!
-! Isotropic : lambda, mu, K (= lambda + 2*mu), zero for the solid phase (1) and the frame (3)
+! Isotropic : lambda, mu, K (= lambda + 2*mu), zero
! Transverse anisotropic : c11, c13, c33, c44
!
if(indic == 1) then
+ density_array(1,n) = density(1)
+ poroelastcoef(1,1,n) = lambda
+ poroelastcoef(2,1,n) = mu
+ poroelastcoef(3,1,n) = lambdaplus2mu
+ poroelastcoef(4,1,n) = zero
+ Qp_array(n) = Qp
+ Qs_array(n) = Qs
+ if(mu > TINYVAL) then
+ porosity_array(n) = 0.d0
+ else
+ porosity_array(n) = 1.d0
+ endif
+ elseif(indic == 2) then
+ density_array(1,n) = density(1)
+ poroelastcoef(1,1,n) = c11
+ poroelastcoef(2,1,n) = c13
+ poroelastcoef(3,1,n) = c33
+ poroelastcoef(4,1,n) = c44
+ Qp_array(n) = Qp
+ Qs_array(n) = Qs
+ porosity_array(n) = 0.d0
+ else
+ density_array(1,n) = density(1)
+ density_array(2,n) = density(2)
poroelastcoef(1,1,n) = lambda_s
- poroelastcoef(2,1,n) = mu_s
+ poroelastcoef(2,1,n) = mu_s ! = mu_fr
poroelastcoef(3,1,n) = lambdaplus2mu_s
poroelastcoef(4,1,n) = zero
@@ -163,42 +232,33 @@
poroelastcoef(2,3,n) = mu_fr
poroelastcoef(3,3,n) = lambdaplus2mu_fr
poroelastcoef(4,3,n) = zero
- else
- 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
+ Qp_array(n) = 10.d0 ! dummy for attenuation_model
+ Qs_array(n) = Qs
endif
- 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
+!---- check what has been read
!
+ if(myrank == 0 .and. ipass == 1) then
if(indic == 1) then
-! 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
+! material can be acoustic (fluid) or elastic (solid)
+ if(poroelastcoef(2,1,n) > TINYVAL) then ! elastic
+ write(IOUT,200) n,cp,cs,density(1),poisson,lambda,mu,kappa,young,Qp,Qs
+ else ! acoustic
+ write(IOUT,300) n,cp,density(1),kappa,Qp,Qs
endif
+ elseif(indic == 2) then ! elastic (anisotropic)
+ write(IOUT,400) n,c11,c13,c33,c44,density,sqrt(c33/density),sqrt(c11/density),sqrt(c44/density),sqrt(c44/density),Qp,Qs
else
- 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))
+! material is poroelastic (solid/fluid)
+ write(iout,500) n,sqrt(cpIsquare),sqrt(cpIIsquare),sqrt(cssquare)
+ write(iout,600) density(1),poisson_s,lambda_s,mu_s,kappa_s,young_s
+ write(iout,700) density(2),kappa_f,eta_f
+ write(iout,800) lambda_fr,mu_fr,kappa_fr,porosity_array(n),tortuosity_array(n),&
+ permeability(1,n),permeability(2,n),permeability(3,n),Qs
+ write(iout,900) D_biot,H_biot,C_biot,M_biot
endif
+ endif
enddo
@@ -210,6 +270,47 @@
/1x,54('='),//5x,'Number of material sets . . . . . . (numat) =',i6)
200 format(//5x,'----------------------------------------',/5x, &
+ '-- Elastic (solid) 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,/5x, &
+ 'Qp_attenuation. . . . . . . . . . . .(Qp) =',1pe15.8,/5x, &
+ 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
+
+ 300 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,/5x, &
+ 'Qp_attenuation. . . . . . . . . . . .(Qp) =',1pe15.8,/5x, &
+ 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
+
+ 400 format(//5x,'-------------------------------------',/5x, &
+ '-- Transverse anisotropic material --',/5x, &
+ '-------------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
+ 'c11 coefficient (Pascal). . . . . . (c11) =',1pe15.8,/5x, &
+ 'c13 coefficient (Pascal). . . . . . (c13) =',1pe15.8,/5x, &
+ 'c33 coefficient (Pascal). . . . . . (c33) =',1pe15.8,/5x, &
+ 'c44 coefficient (Pascal). . . . . . (c44) =',1pe15.8,/5x, &
+ 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
+ 'Velocity of qP along vertical axis. . . . =',1pe15.8,/5x, &
+ 'Velocity of qP along horizontal axis. . . =',1pe15.8,/5x, &
+ 'Velocity of qSV along vertical axis . . . =',1pe15.8,/5x, &
+ 'Velocity of qSV along horizontal axis . . =',1pe15.8,/5x, &
+ 'Qp_attenuation. . . . . . . . . . . .(Qp) =',1pe15.8,/5x, &
+ 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
+
+ 500 format(//5x,'----------------------------------------',/5x, &
'-- Poroelastic isotropic material --',/5x, &
'----------------------------------------',/5x, &
'Material set number. . . . . . . . (jmat) =',i6,/5x, &
@@ -217,7 +318,7 @@
'Second P-wave velocity. . . . . . . . . . . (cpII) =',1pe15.8,/5x, &
'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8)
- 300 format(//5x,'-------------------------------',/5x, &
+ 600 format(//5x,'-------------------------------',/5x, &
'-- Solid phase properties --',/5x, &
'Mass density. . . . . . . . . . (density_s) =',1pe15.8,/5x, &
'Poisson''s ratio. . . . . . . . .(poisson_s) =',1pe15.8,/5x, &
@@ -226,24 +327,25 @@
'Solid bulk modulus Kappa . . . . . . . .(kappa_s) =',1pe15.8,/5x, &
'Young''s modulus E. . . . . . . . .(young_s) =',1pe15.8)
- 400 format(//5x,'-------------------------------',/5x, &
+ 700 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, &
+ 800 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,&
+ 'Tortuosity. . . . . . . . . . . . . . . . .(c) =',1pe15.8,/5x,&
'Permeability xx component. . . . . . . . . . =',1pe15.8,/5x,&
'Permeability zx component. . . . . . . . . . =',1pe15.8,/5x,&
- 'Permeability zz component. . . . . . . . . . =',1pe15.8)
+ 'Permeability zz component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
- 600 format(//5x,'-------------------------------',/5x, &
+ 900 format(//5x,'-------------------------------',/5x, &
'-- Biot coefficients --',/5x, &
'-------------------------------',/5x, &
'D. . . . . . . . =',1pe15.8,/5x, &
@@ -251,40 +353,5 @@
'C. . . . . . . . =',1pe15.8,/5x, &
'M. . . . . . . . =',1pe15.8)
- 700 format(//5x,'-------------------------------------',/5x, &
- '-- Transverse anisotropic material --',/5x, &
- '-------------------------------------',/5x, &
- 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
- 'c11 coefficient (Pascal). . . . . . (c11) =',1pe15.8,/5x, &
- 'c13 coefficient (Pascal). . . . . . (c13) =',1pe15.8,/5x, &
- 'c33 coefficient (Pascal). . . . . . (c33) =',1pe15.8,/5x, &
- 'c44 coefficient (Pascal). . . . . . (c44) =',1pe15.8,/5x, &
- 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
- 'Velocity of qP along vertical axis. . . . =',1pe15.8,/5x, &
- 'Velocity of qP along horizontal axis. . . =',1pe15.8,/5x, &
- '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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/lagrange_poly.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/locate_receivers.F90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -46,7 +46,8 @@
subroutine 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)
+ xi_receiver,gamma_receiver,station_name,network_name,x_source,z_source,coorg,knods,ngnod,npgeo,ipass, &
+ x_final_receiver, z_final_receiver)
implicit none
@@ -55,7 +56,7 @@
include "mpif.h"
#endif
- integer nrec,nspec,npoin,ngnod,npgeo
+ integer nrec,nspec,npoin,ngnod,npgeo,ipass
integer, intent(in) :: nproc, myrank
integer knods(ngnod,nspec)
@@ -93,6 +94,8 @@
double precision, dimension(nrec) :: st_xval,st_zval
+! tangential detection
+ double precision, dimension(nrec) :: x_final_receiver, z_final_receiver
double precision, dimension(nrec,nproc) :: gather_final_distance
double precision, dimension(nrec,nproc) :: gather_xi_receiver, gather_gamma_receiver
@@ -105,7 +108,7 @@
! **************
- if (myrank == 0) then
+ if (myrank == 0 .and. ipass == 1) then
write(IOUT,*)
write(IOUT,*) '********************'
write(IOUT,*) ' locating receivers'
@@ -208,6 +211,9 @@
! compute final distance between asked and found
final_distance(irec) = sqrt((st_xval(irec)-x)**2 + (st_zval(irec)-z)**2)
+ x_final_receiver(irec) = x
+ z_final_receiver(irec) = z
+
enddo
! close receiver file
@@ -228,8 +234,8 @@
do irec = 1, nrec
which_proc_receiver(irec:irec) = minloc(gather_final_distance(irec,:)) - 1
- end do
-end if
+ enddo
+endif
call MPI_BCAST(which_proc_receiver(1),nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
@@ -250,13 +256,11 @@
if ( which_proc_receiver(irec) == myrank ) then
nrecloc = nrecloc + 1
recloc(nrecloc) = irec
- end if
+ endif
+enddo
-end do
+if (myrank == 0 .and. ipass == 1) then
-
-if ( myrank == 0 ) then
-
do irec = 1, nrec
write(IOUT,*)
write(IOUT,*) 'Station # ',irec,' ',station_name(irec),network_name(irec)
@@ -273,19 +277,14 @@
gather_gamma_receiver(irec,which_proc_receiver(irec)+1)
write(IOUT,*)
- end do
+ enddo
-
-! display maximum error for all the receivers
- !write(IOUT,*) 'maximum error in location of all the receivers: ',sngl(maxval(final_distance(:))),' m'
-
write(IOUT,*)
write(IOUT,*) 'end of receiver detection'
write(IOUT,*)
-end if
+endif
-
! deallocate arrays
deallocate(final_distance)
@@ -293,6 +292,5 @@
call MPI_BARRIER(MPI_COMM_WORLD,ierror)
#endif
-
end subroutine locate_receivers
Modified: seismo/2D/SPECFEM2D/branches/BIOT/locate_source_force.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/locate_source_force.F90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/locate_source_force.F90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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,source_type,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,ix_source,iz_source, &
+ ispec_source,iglob_source,is_proc_source,nb_proc_source,ipass)
!
!----- calculer la position reelle de la source
@@ -54,7 +54,7 @@
include "mpif.h"
#endif
- integer npoin,nspec,source_type
+ integer npoin,nspec,ipass
integer ibool(NGLLX,NGLLZ,nspec)
double precision x_source,z_source
@@ -80,29 +80,22 @@
ihighx = NGLLX
ihighz = NGLLZ
-! 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
+! look for the closest grid point
+ do numelem = 1,nspec
-! recherche du point de grille le plus proche
- do numelem=1,nspec
- do ix=ilowx,ihighx
- do iz=ilowz,ihighz
+ do ix = ilowx,ihighx
+ do iz = ilowz,ihighz
-! numero global du point
- ip=ibool(ix,iz,numelem)
+! global point number
+ ip = ibool(ix,iz,numelem)
-! coordonnees du point de grille
+! coordinates of this grid point
xp = coord(1,ip)
zp = coord(2,ip)
dist = sqrt((xp-x_source)**2 + (zp-z_source)**2)
-! retenir le point pour lequel l'ecart est minimal
+! keep the point for which distance is minimum
if(dist < distmin) then
distmin = dist
iglob_source = ip
@@ -113,13 +106,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
@@ -127,37 +120,28 @@
#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
nb_proc_source = is_proc_source
-
#endif
- if ( nb_proc_source < 1 ) then
- call exit_MPI('error locating force source')
- end if
+ if (nb_proc_source < 1) call exit_MPI('error locating force source')
- if ( is_proc_source == 1 ) then
- write(iout,200)
-
- write(iout,"(1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3,1x,i5.5)") x_source,z_source, &
+ if (is_proc_source == 1 .and. ipass == 1) then
+ write(IOUT,200)
+ write(IOUT,"(1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3,1x,i5.5)") x_source,z_source, &
coord(1,iglob_source),coord(2,iglob_source),distmin,nb_proc_source
- write(iout,*)
- write(iout,*)
- write(iout,"('Maximum distance between asked and real =',f12.3)") distminmax
+ write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,"('Maximum distance between asked and real =',f12.3)") distminmax
+ endif
- end if
-
#ifdef USE_MPI
call MPI_BARRIER(MPI_COMM_WORLD,ierror)
#endif
Modified: seismo/2D/SPECFEM2D/branches/BIOT/locate_source_moment_tensor.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/locate_source_moment_tensor.F90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/locate_source_moment_tensor.F90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -45,7 +45,8 @@
!----
subroutine locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
- ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod,npgeo)
+ ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank, &
+ xi_source,gamma_source,coorg,knods,ngnod,npgeo,ipass)
implicit none
@@ -54,7 +55,7 @@
include "mpif.h"
#endif
- integer nspec,npoin,ngnod,npgeo
+ integer nspec,npoin,ngnod,npgeo,ipass
integer knods(ngnod,nspec)
double precision coorg(NDIM,npgeo)
@@ -90,25 +91,25 @@
! **************
- if ( myrank == 0 .or. nproc == 1 ) then
- write(IOUT,*)
- write(IOUT,*) '*******************************'
- write(IOUT,*) ' locating moment-tensor source'
- write(IOUT,*) '*******************************'
- write(IOUT,*)
- end if
+ if ((myrank == 0 .or. nproc == 1) .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) '*******************************'
+ write(IOUT,*) ' locating moment-tensor source'
+ write(IOUT,*) '*******************************'
+ write(IOUT,*)
+ endif
! 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,7 +128,6 @@
! 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)
@@ -137,13 +137,9 @@
#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)
@@ -163,10 +159,10 @@
if ( myrank /= locate_is_proc_source(1) ) then
is_proc_source = 0
- end if
+ endif
nb_proc_source = 1
- end if
+ endif
#endif
@@ -175,8 +171,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
@@ -219,7 +215,7 @@
! compute final distance between asked and found
final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
- if ( is_proc_source == 1 ) then
+ if (is_proc_source == 1 .and. ipass == 1) then
write(IOUT,*)
write(IOUT,*) 'Moment-tensor source:'
@@ -235,7 +231,7 @@
write(IOUT,*)
write(IOUT,*) 'end of moment-tensor source detection'
write(IOUT,*)
- end if
+ endif
#ifdef USE_MPI
call MPI_BARRIER(MPI_COMM_WORLD,ierror)
Modified: seismo/2D/SPECFEM2D/branches/BIOT/meshfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/meshfem2D.F90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/meshfem2D.F90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,15 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 6.3
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -68,6 +66,20 @@
! 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
@@ -83,9 +95,10 @@
integer :: ioffset
double precision :: gamma,absx,a00,a01,bot0,top0
-! 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
+! to store density and velocity model
+ double precision, dimension(:), allocatable :: rho_s,cp,cs,aniso3,aniso4,Qp,Qs
+ double precision, dimension(:), allocatable :: rho_f,phi,tortuosity,permxx,permxz,&
+ permzz,kappa_s,kappa_f,kappa_fr,eta_f,mu_fr
integer, dimension(:), allocatable :: icodemat
integer, dimension(:), allocatable :: num_material
@@ -99,14 +112,14 @@
xinterface_top,zinterface_top,coefs_interface_top
! for the source and receivers
- integer, dimension(:), allocatable :: source_type,time_function_type !yang
+ integer, dimension(:), allocatable :: source_type,time_function_type
integer nrec_total,irec_global_number
- double precision, dimension(:),allocatable :: xs,zs,f0,t0,angleforce,Mxx,Mzz,Mxz,factor !yang
- integer NSOURCE, NSOURCES, i_source, icounter, ios !yang
+ double precision, dimension(:),allocatable :: xs,zs,f0,t0,angleforce,Mxx,Mzz,Mxz,factor
+ integer NSOURCE, NSOURCES, i_source, icounter, ios
logical, dimension(:),allocatable :: source_surf
double precision xrec,zrec
! file number for source file
- integer, parameter :: IIN_SOURCE = 22
+ integer, parameter :: IIN_SOURCE = 22
character(len=150) dummystring
character(len=50) interfacesfile,title
@@ -127,9 +140,8 @@
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 rhosread,rhofread,phiread,tortuosityread,kappasread,kappafread,kappafrread,musread,etafread,mufrread
- double precision permxxread,permxzread,permzzread
+ double precision val0read,val1read,val2read,val3read,val4read,val5read,val6read,val7read,&
+ val8read,val9read,val10read,val11read,val12read
double precision, dimension(:), allocatable :: xdeb,zdeb,xfin,zfin
@@ -145,13 +157,16 @@
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
+! flag to save the last frame for kernels calculation purpose and type of simulation
logical :: save_forward
integer :: isolver
! flag to indicate an anisotropic material
integer, parameter :: ANISOTROPIC_MATERIAL = 2
+! flag to indicate a poroelastic material
+ integer, parameter :: POROELASTIC_MATERIAL = 3
+
! file number for interface file
integer, parameter :: IIN_INTERFACES = 15
@@ -160,7 +175,7 @@
! parameters for external mesh
logical :: read_external_mesh
- character(len=256) :: mesh_file, nodes_coords_file, materials_file, free_surface_file, absorbing_surface_file,receivers_file
+ character(len=256) :: mesh_file, nodes_coords_file, materials_file, free_surface_file, absorbing_surface_file
! variables used for storing info about the mesh and partitions
integer, dimension(:), pointer :: elmnts
@@ -211,20 +226,24 @@
integer, dimension(:), pointer :: ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right
-! variables used for partitionning
+! variables used for partitioning
integer :: nproc
- integer :: partitionning_method
- character(len=256) :: partitionning_strategy
+ integer :: partitioning_method
+ character(len=256) :: partitioning_strategy
character(len=256) :: scotch_strategy
integer, dimension(0:4) :: metis_options
character(len=256) :: prname
! variables used for attenuation
integer :: N_SLS
- double precision :: Qp_attenuation
- double precision :: Qs_attenuation
double precision :: f0_attenuation
+! variables used for tangential detection
+ logical :: force_normal_to_surface,rec_normal_to_surface
+ character(len=256) :: tangential_detection_curve_file
+ integer :: nnodes_tangential_curve
+ double precision, dimension(:,:), allocatable :: nodes_tangential_curve
+
#if defined USE_METIS || defined USE_SCOTCH
integer :: edgecut
#endif
@@ -257,9 +276,9 @@
call read_value_string(IIN,IGNORE_JUNK,materials_file)
call read_value_string(IIN,IGNORE_JUNK,free_surface_file)
call read_value_string(IIN,IGNORE_JUNK,absorbing_surface_file)
- call read_value_string(IIN,IGNORE_JUNK,receivers_file)
+ call read_value_string(IIN,IGNORE_JUNK,tangential_detection_curve_file)
-! read info about partitionning
+! read info about partitioning
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.'
@@ -275,26 +294,26 @@
#endif
- call read_value_integer(IIN,IGNORE_JUNK,partitionning_method)
- call read_value_string(IIN,IGNORE_JUNK,partitionning_strategy)
- select case(partitionning_method)
+ call read_value_integer(IIN,IGNORE_JUNK,partitioning_method)
+ call read_value_string(IIN,IGNORE_JUNK,partitioning_strategy)
+ select case(partitioning_method)
case(1)
case(2)
- partitionning_strategy = trim(partitionning_strategy)
- if ( partitionning_strategy(1:1) == '0' ) then
+ partitioning_strategy = trim(partitioning_strategy)
+ if ( partitioning_strategy(1:1) == '0' ) then
metis_options(0) = 0
else
do i = 1, 5
- metis_options = iachar(partitionning_strategy(i:i)) - iachar('0')
- end do
+ metis_options = iachar(partitioning_strategy(i:i)) - iachar('0')
+ enddo
endif
case(3)
- scotch_strategy = trim(partitionning_strategy)
+ scotch_strategy = trim(partitioning_strategy)
case default
- print *, 'Invalid partionning method number.'
- print *, 'Partionning method', partitionning_method, 'was requested, but is not available.'
+ print *, 'Invalid partitioning method number.'
+ print *, 'Partitioning method ',partitioning_method,' was requested, but is not available.'
stop
end select
@@ -399,8 +418,8 @@
elmnts(num_elmnt*ngnod+2) = j*(nxread+1) + (i-1) + 1
elmnts(num_elmnt*ngnod+3) = j*(nxread+1) + (i-1)
num_elmnt = num_elmnt + 1
- end do
- end do
+ enddo
+ enddo
else
num_elmnt = 0
do j = 1, nzread
@@ -415,8 +434,8 @@
elmnts(num_elmnt*ngnod+7) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2
elmnts(num_elmnt*ngnod+8) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2 + 1
num_elmnt = num_elmnt + 1
- end do
- end do
+ enddo
+ enddo
endif
endif
@@ -440,21 +459,20 @@
call read_value_integer(IIN,IGNORE_JUNK,isolver)
! read source parameters
- call read_value_integer(IIN,IGNORE_JUNK,NSOURCE) !yang
- allocate(source_surf(NSOURCE))
- allocate(xs(NSOURCE))
- allocate(zs(NSOURCE))
- allocate(source_type(NSOURCE))
- allocate(time_function_type(NSOURCE))
- allocate(f0(NSOURCE))
- allocate(t0(NSOURCE))
- allocate(angleforce(NSOURCE))
- allocate(Mxx(NSOURCE))
- allocate(Mxz(NSOURCE))
- allocate(Mzz(NSOURCE))
- allocate(factor(NSOURCE))
+ call read_value_integer(IIN,IGNORE_JUNK,NSOURCE)
+ allocate(source_surf(NSOURCE))
+ allocate(xs(NSOURCE))
+ allocate(zs(NSOURCE))
+ allocate(source_type(NSOURCE))
+ allocate(time_function_type(NSOURCE))
+ allocate(f0(NSOURCE))
+ allocate(t0(NSOURCE))
+ allocate(angleforce(NSOURCE))
+ allocate(Mxx(NSOURCE))
+ allocate(Mxz(NSOURCE))
+ allocate(Mzz(NSOURCE))
+ allocate(factor(NSOURCE))
-!chris
open(unit=IIN_SOURCE,file='DATA/CMTSOLUTION',iostat=ios,status='old',action='read')
if(ios /= 0) stop 'error opening CMTSOLUTION file'
icounter = 0
@@ -471,7 +489,7 @@
stop 'total number of sources read is different than declared in Par_file'
open(unit=IIN_SOURCE,file='DATA/CMTSOLUTION',status='old',action='read')
- do i_source=1,NSOURCE
+ do i_source=1,NSOURCE
call read_value_logical(IIN_SOURCE,IGNORE_JUNK,source_surf(i_source))
call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,xs(i_source))
call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,zs(i_source))
@@ -484,17 +502,18 @@
call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mzz(i_source))
call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mxz(i_source))
call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,factor(i_source))
- ! if Dirac source time function, use a very thin Gaussian instead
- ! if Heaviside source time function, use a very thin error function instead
- if(time_function_type(i_source) == 4 .or. time_function_type(i_source) == 5) f0(i_source) = 1.d0 / (10.d0 * deltat)
-
+
+! if Dirac source time function, use a very thin Gaussian instead
+! if Heaviside source time function, use a very thin error function instead
+ if(time_function_type(i_source) == 4 .or. time_function_type(i_source) == 5) f0(i_source) = 1.d0 / (10.d0 * deltat)
+
! time delay of the source in seconds, use a 20 % security margin (use 2 / f0 if error function)
if(time_function_type(i_source)== 5) then
- t0(i_source) = 2.0d0 / f0(i_source)+t0(i_source)
+ t0(i_source) = 2.0d0 / f0(i_source)+t0(i_source)
else
t0(i_source) = 1.20d0 / f0(i_source)+t0(i_source)
endif
-
+
print *
print *,'Source', i_source
print *,'Position xs, zs = ',xs(i_source),zs(i_source)
@@ -509,14 +528,14 @@
enddo ! do i_source=1,NSOURCE
close(IIN_SOURCE)
+ call read_value_logical(IIN,IGNORE_JUNK,force_normal_to_surface)
+
! read constants for attenuation
call read_value_integer(IIN,IGNORE_JUNK,N_SLS)
- call read_value_double_precision(IIN,IGNORE_JUNK,Qp_attenuation)
- call read_value_double_precision(IIN,IGNORE_JUNK,Qs_attenuation)
call read_value_double_precision(IIN,IGNORE_JUNK,f0_attenuation)
-! if source is not a Dirac or Heavyside then f0_attenuation is f0
- if(.not. (time_function_type(1) == 4 .or. time_function_type(1) == 5)) then !yang use parameter of the first source
+! if source is not a Dirac or Heavyside then f0_attenuation is f0 of the first source
+ if(.not. (time_function_type(1) == 4 .or. time_function_type(1) == 5)) then
f0_attenuation = f0(1)
endif
@@ -526,6 +545,7 @@
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)
+ call read_value_logical(IIN,IGNORE_JUNK,rec_normal_to_surface)
if(nreceiverlines < 1) stop 'number of receiver lines must be greater than 1'
@@ -545,6 +565,9 @@
call read_value_double_precision(IIN,IGNORE_JUNK,xfin(ireceiverlines))
call read_value_double_precision(IIN,IGNORE_JUNK,zfin(ireceiverlines))
call read_value_logical(IIN,IGNORE_JUNK,enreg_surf(ireceiverlines))
+ if (read_external_mesh .and. enreg_surf(ireceiverlines)) then
+ stop 'Cannot use enreg_surf with external meshes!'
+ endif
enddo
! read display parameters
@@ -576,6 +599,12 @@
if(nb_materials <= 0) stop 'Negative number of materials not allowed!'
allocate(icodemat(nb_materials))
+ allocate(cp(nb_materials))
+ allocate(cs(nb_materials))
+ allocate(aniso3(nb_materials))
+ allocate(aniso4(nb_materials))
+ allocate(Qp(nb_materials))
+ allocate(Qs(nb_materials))
allocate(rho_s(nb_materials))
allocate(rho_f(nb_materials))
allocate(phi(nb_materials))
@@ -586,12 +615,17 @@
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
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+ aniso3(:) = 0.d0
+ aniso4(:) = 0.d0
+ Qp(:) = 0.d0
+ Qs(:) = 0.d0
rho_s(:) = 0.d0
rho_f(:) = 0.d0
phi(:) = 0.d0
@@ -602,59 +636,95 @@
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,rhosread,rhofread,phiread, &
- tortuosityread,permxxread,permxzread,permzzread,kappasread,kappafread,&
- kappafrread,musread,etafread,mufrread)
+ call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread,val0read,val1read,val2read,val3read, &
+ val4read,val5read,val6read,val7read,val8read,val9read,val10read,val11read,val12read)
if(i < 1 .or. i > nb_materials) stop 'Wrong material number!'
icodemat(i) = icodematread
- 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(icodemat(i) /= POROELASTIC_MATERIAL) then
+ rho_s(i) = val0read
+ cp(i) = val1read
+ cs(i) = val2read
+ Qp(i) = val5read
+ Qs(i) = val6read
+
+ if(rho_s(i) <= 0.d0 .or. cp(i) <= 0.d0 .or. cs(i) < 0.d0) stop 'negative value of velocity or density'
+ if(Qp(i) <= 0.d0 .or. Qs(i) <= 0.d0) stop 'negative value of Qp or Qs'
+
+ aniso3(i) = val3read
+ aniso4(i) = val4read
+ if(cs(i) /= 0.d0) then
+ phi(i) = 0.d0 ! elastic
+ else
+ phi(i) = 1.d0 ! acoustic
+ endif
+ else ! poroelastic
+ rho_s(i) = val0read
+ rho_f(i) = val1read
+ phi(i) = val2read
+ tortuosity(i) = val3read
+ permxx(i) = val4read
+ permxz(i) = val5read
+ permzz(i) = val6read
+ kappa_s(i) = val7read
+ kappa_f(i) = val8read
+ kappa_fr(i) = val9read
+ eta_f(i) = val10read
+ mu_fr(i) = val11read
+ Qs(i) = val12read
+
+ if(rho_s(i) <= 0.d0 .or. rho_f(i) <= 0.d0) stop 'negative value of density'
+ if(phi(i) <= 0.d0 .or. tortuosity(i) <= 0.d0) stop 'negative value of porosity or tortuosity'
+ if(kappa_s(i) <= 0.d0 .or. kappa_f(i) <= 0.d0 .or. kappa_fr(i) <= 0.d0 .or. mu_fr(i) <= 0.d0) stop 'negative value of modulus'
+ if(Qs(i) <= 0.d0) stop 'negative value of Qs'
+ endif
enddo
print *
print *, 'Nb of solid, fluid or porous materials = ',nb_materials
print *
do i=1,nb_materials
- if(icodemat(i) /= ANISOTROPIC_MATERIAL) then
+ if(icodemat(i) /= ANISOTROPIC_MATERIAL .and. icodemat(i) /= POROELASTIC_MATERIAL) then
print *,'Material #',i,' isotropic'
- 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 *,'rho,cp,cs = ',rho_s(i),cp(i),cs(i),Qp(i),Qs(i)
+ if(cs(i) < TINYVAL) then
print *,'Material is fluid'
- elseif(phi(i) < TINYVAL) then ! elastic domain
+ else
print *,'Material is solid'
- else ! poroelastic domain
- print *,'Material is porous'
endif
+ elseif(icodemat(i) == POROELASTIC_MATERIAL) then
+ print *,'Material #',i,' isotropic'
+ print *,'rho_s, kappa_s= ',rho_s(i),kappa_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, Qs= ',kappa_fr(i),mu_fr(i),Qs(i)
+ print *,'Material is porous'
else
print *,'Material #',i,' anisotropic'
- print *,'ATTENTION: to be defined'
-! print *,'rho,c11,c13,c33,c44 = ',rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
+ print *,'rho,c11,c13,c33,c44 = ',rho_s(i),cp(i),cs(i),aniso3(i),aniso4(i),Qp(i),Qs(i)
endif
print *
enddo
+! tangential detection
+ if (force_normal_to_surface .or. rec_normal_to_surface) then
+ open(unit=IIN,file=tangential_detection_curve_file,status='old',action='read')
+ read(IIN,*) nnodes_tangential_curve
+ allocate(nodes_tangential_curve(2,nnodes_tangential_curve))
+ do i = 1, nnodes_tangential_curve
+ read(IIN,*) nodes_tangential_curve(1,i), nodes_tangential_curve(2,i)
+ enddo
+ close(IIN)
+ else
+ nnodes_tangential_curve = 0
+ allocate(nodes_tangential_curve(2,1))
+ endif
+
if ( read_external_mesh ) then
call read_mat(materials_file, nelmnts, num_material)
else
@@ -681,32 +751,39 @@
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 .and. icodemat(imaterial_number) /= POROELASTIC_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_s(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'
+ print *,'Qp = ',Qp(imaterial_number)
+ print *,'Qs = ',Qs(imaterial_number)
+ elseif(icodemat(imaterial_number) == POROELASTIC_MATERIAL) then
+ print *,'Material # ',imaterial_number,' isotropic'
+ print *,'Material is poroelastic'
+ 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_s(imaterial_number)
+ print *,'Qp = ',Qp(imaterial_number)
+ print *,'Qs = ',Qs(imaterial_number)
+ endif
+ print *,' -----'
- ! store model properties
+ ! store density and velocity model
do i = ixdebregion,ixfinregion
do j = izdebregion,izfinregion
num_material((j-1)*nxread+i) = imaterial_number
@@ -715,7 +792,7 @@
enddo
- if(minval(num_material) <= 0) stop 'Model properties not entirely set...'
+ if(minval(num_material) <= 0) stop 'Velocity model not entirely set...'
endif
@@ -794,8 +871,10 @@
! check if we are in the last layer, which contains topography,
! and modify the position of the source accordingly if it is located exactly at the surface
- if(source_surf(1) .and. ilayer == number_of_layers) & !yang use first source
- zs = value_spline(xs(1),xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+ do i_source=1,NSOURCE
+ if(source_surf(i_source) .and. ilayer == number_of_layers) &
+ zs(i_source) = value_spline(xs(i_source),xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+ enddo
! compute the offset of this layer in terms of number of spectral elements below along Z
if(ilayer > 1) then
@@ -848,8 +927,8 @@
nodes_coords(1, num_node) = x(i,j)
nodes_coords(2, num_node) = z(i,j)
- end do
- end do
+ enddo
+ enddo
else
do j = 0, nz
@@ -858,8 +937,8 @@
nodes_coords(1, num_node) = x(i,j)
nodes_coords(2, num_node) = z(i,j)
- end do
- end do
+ enddo
+ enddo
endif
else
@@ -897,14 +976,14 @@
j = nzread
do i = 1,nxread
imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) 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
acoustic_surface(3,nelem_acoustic_surface) = elmnts(3+ngnod*((j-1)*nxread+i-1))
acoustic_surface(4,nelem_acoustic_surface) = elmnts(2+ngnod*((j-1)*nxread+i-1))
endif
- end do
+ enddo
endif
@@ -953,8 +1032,8 @@
abs_surface(3,nelemabs) = elmnts(0+ngnod*(inumelem-1))
abs_surface(4,nelemabs) = elmnts(3+ngnod*(inumelem-1))
endif
- end do
- end do
+ enddo
+ enddo
endif
endif
@@ -1031,9 +1110,9 @@
endif
- !*****************************
- ! Partitionning
- !*****************************
+!*****************************
+! partitioning
+!*****************************
allocate(part(0:nelmnts-1))
! if ngnod == 9, we work on a subarray of elmnts, which represents the elements with for nodes only
@@ -1042,7 +1121,7 @@
allocate(elmnts_bis(0:ESIZE*nelmnts-1))
do i = 0, nelmnts-1
elmnts_bis(i*esize:i*esize+esize-1) = elmnts(i*ngnod:i*ngnod+esize-1)
- end do
+ enddo
if ( nproc > 1 ) then
call mesh2dual_ncommonnodes(nelmnts, (nxread+1)*(nzread+1), elmnts_bis, xadj, adjncy, nnodes_elmnts, nodes_elmnts,1)
@@ -1066,14 +1145,17 @@
call read_weights(nelmnts, vwgt, nb_edges, adjwgt)
! partitioning
- select case (partitionning_method)
+ select case (partitioning_method)
+
case(1)
+
do iproc = 0, nproc-2
part(iproc*floor(real(nelmnts)/real(nproc)):(iproc+1)*floor(real(nelmnts)/real(nproc))-1) = iproc
- end do
+ enddo
part(floor(real(nelmnts)/real(nproc))*(nproc-1):nelmnts-1) = nproc - 1
case(2)
+
#ifdef USE_METIS
call Part_metis(nelmnts, xadj, adjncy, vwgt, adjwgt, nproc, nb_edges, edgecut, part, metis_options)
#else
@@ -1083,6 +1165,7 @@
#endif
case(3)
+
#ifdef USE_SCOTCH
call Part_scotch(nelmnts, xadj, adjncy, vwgt, adjwgt, nproc, nb_edges, edgecut, part, scotch_strategy)
#else
@@ -1136,7 +1219,7 @@
nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
- end do
+ enddo
else
if ( nproc < 2 ) then
allocate(nnodes_elmnts(0:nnodes-1))
@@ -1147,13 +1230,12 @@
nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
- end do
+ enddo
endif
endif
-
! local number of each node for each partition
call Construct_glob2loc_nodes(nelmnts, nnodes, nnodes_elmnts, nodes_elmnts, part, nproc, &
glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes)
@@ -1167,10 +1249,8 @@
call Construct_interfaces(nelmnts, nproc, part, elmnts, xadj, adjncy, tab_interfaces, &
tab_size_interfaces, ninterfaces, nb_materials, phi, num_material)
endif
- print *, '04'
allocate(my_interfaces(0:ninterfaces-1))
allocate(my_nb_interfaces(0:ninterfaces-1))
- print *, '05'
endif
! setting absorbing boundaries by elements instead of edges
@@ -1178,11 +1258,9 @@
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, nedges_acporo_coupled, edges_acporo_coupled, nedges_elporo_coupled, &
- edges_elporo_coupled,nb_materials, phi, num_material, &
+ nedges_coupled, edges_coupled, nb_materials, phi, num_material, &
nelmnts, &
elmnts, ngnod)
- print *, 'nelemabs_merge', nelemabs_merge
endif
! *** generate the databases for the solver
@@ -1194,7 +1272,7 @@
write(15,*) '#'
write(15,*) '# Database for SPECFEM2D'
- write(15,*) '# (c) University of Pau, France and Caltech, Pasadena'
+ write(15,*) '# Dimitri Komatitsch, (c) University of Pau, France'
write(15,*) '#'
write(15,*) 'Title of the simulation'
@@ -1249,21 +1327,19 @@
write(15,*) source_type(i_source),time_function_type(i_source),xs(i_source),zs(i_source),f0(i_source),t0(i_source), &
factor(i_source),angleforce(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
enddo
+
write(15,*) 'attenuation'
- write(15,*) N_SLS, Qp_attenuation, Qs_attenuation, f0_attenuation
+ write(15,*) N_SLS, f0_attenuation
write(15,*) 'Coordinates of macrobloc mesh (coorg):'
-
call write_glob2loc_nodes_database(15, iproc, npgeo, nodes_coords, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
glob2loc_nodes, nnodes, 2)
-
write(15,*) 'numat ngnod nspec pointsdisp plot_lowerleft_corner_only'
write(15,*) nb_materials,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
-
- if ( any_abs ) then
+ if (any_abs) then
call write_abs_merge_database(15, nelemabs_merge, nelemabs_loc, &
abs_surface_char, abs_surface_merge, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
@@ -1273,11 +1349,10 @@
nelemabs_loc = 0
endif
- call Write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
+ call write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
iproc, glob2loc_elmnts, &
glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes, part, 1)
-
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, &
@@ -1285,37 +1360,43 @@
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 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,*) 'nelemabs nelem_acoustic_surface num_fluid_solid_edges num_fluid_poro_edges'
+ write(15,*) 'num_solid_poro_edges nnodes_tangential_curve'
+ write(15,*) nelemabs_loc,nelem_acoustic_surface_loc,nedges_coupled_loc,nedges_acporo_coupled_loc,&
+ nedges_elporo_coupled_loc,nnodes_tangential_curve
- write(15,*) 'Material sets Isotropic (Anisotropic: to be defined)'
+ write(15,*) 'Material sets (num 1 rho vp vs 0 0 Qp Qs 0 0 0 0 0 0) or '
+ write(15,*) '(num 2 rho c11 c13 c33 c44 Qp Qs 0 0 0 0 0 0) or '
+ write(15,*) '(num 3 rhos rhof phi c k_xx k_xz k_zz Ks Kf Kfr etaf mufr Qs)'
do i=1,nb_materials
- 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)
+ if (icodemat(i) /= POROELASTIC_MATERIAL)then
+ write(15,*) i,icodemat(i),rho_s(i),cp(i),cs(i),aniso3(i),aniso4(i),Qp(i),Qs(i),0,0,0,0,0,0
+ else
+ 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),eta_f(i),mu_fr(i),Qs(i)
+ endif
enddo
write(15,*) 'Arrays kmato and knods for each bloc:'
-
call write_partition_database(15, iproc, nspec, nelmnts, elmnts, glob2loc_elmnts, glob2loc_nodes_nparts, &
glob2loc_nodes_parts, glob2loc_nodes, part, num_material, ngnod, 2)
if ( nproc /= 1 ) then
- call Write_interfaces_database(15, tab_interfaces, tab_size_interfaces, nproc, iproc, ninterfaces, &
+ call write_interfaces_database(15, tab_interfaces, tab_size_interfaces, nproc, iproc, ninterfaces, &
my_ninterface, my_interfaces, my_nb_interfaces, glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
glob2loc_nodes, 1)
write(15,*) 'Interfaces:'
write(15,*) my_ninterface, maxval(my_nb_interfaces)
- call Write_interfaces_database(15, tab_interfaces, tab_size_interfaces, nproc, iproc, ninterfaces, &
+ call write_interfaces_database(15, tab_interfaces, tab_size_interfaces, nproc, iproc, ninterfaces, &
my_ninterface, my_interfaces, my_nb_interfaces, glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
glob2loc_nodes, 2)
else
write(15,*) 'Interfaces:'
write(15,*) 0, 0
-
endif
@@ -1329,7 +1410,7 @@
endif
write(15,*) 'List of acoustic free-surface elements:'
- call Write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
+ call write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
iproc, glob2loc_elmnts, &
glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes, part, 2)
@@ -1346,7 +1427,13 @@
call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
edges_elporo_coupled, glob2loc_elmnts, part, iproc, 2)
- end do
+ write(15,*) 'List of tangential detection curve nodes:'
+ !write(15,*) nnodes_tangential_curve
+ write(15,*) force_normal_to_surface,rec_normal_to_surface
+ do i = 1, nnodes_tangential_curve
+ write(15,*) nodes_tangential_curve(1,i),nodes_tangential_curve(2,i)
+ enddo
+ enddo
! print position of the source
@@ -1355,12 +1442,9 @@
print *,'Position (x,z) of the source = ',xs(i_source),zs(i_source)
print *
enddo
+
!--- compute position of the receivers and write the STATIONS file
- if (read_external_mesh) then
- call read_receivers(receivers_file,xs,zs,NSOURCE)
-
- else
if (generate_STATIONS) then
print *
print *,'writing the DATA/STATIONS file'
@@ -1411,10 +1495,16 @@
enddo
close(15)
+
endif
print *
- endif !(if(external_mesh...
+ if (nproc == 1) then
+ print *,'This will be a serial simulation'
+ else
+ print *,'This will be a parallel simulation on ',nproc,' processors'
+ endif
+ print *
end program meshfem2D
Modified: seismo/2D/SPECFEM2D/branches/BIOT/part_unstruct.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/part_unstruct.F90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/part_unstruct.F90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,15 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 6.3
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -45,15 +43,12 @@
!
! 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
implicit none
- include './constants_unstruct.h'
-
contains
!-----------------------------------------------
@@ -63,6 +58,8 @@
!-----------------------------------------------
subroutine read_mesh(filename, nelmnts, elmnts, nnodes, num_start)
+ include "constants.h"
+
character(len=256), intent(in) :: filename
integer, intent(out) :: nelmnts
integer, intent(out) :: nnodes
@@ -71,25 +68,21 @@
integer :: i
- print *, trim(filename)
-
open(unit=990, file=trim(filename), form='formatted' , status='old', action='read')
read(990,*) nelmnts
allocate(elmnts(0:ESIZE*nelmnts-1))
do i = 0, nelmnts-1
read(990,*) elmnts(i*ESIZE), elmnts(i*ESIZE+1), elmnts(i*ESIZE+2), elmnts(i*ESIZE+3)
- end do
+ enddo
close(990)
num_start = minval(elmnts)
elmnts(:) = elmnts(:) - num_start
nnodes = maxval(elmnts) + 1
-
end subroutine read_mesh
-
!-----------------------------------------------
! Read the nodes coordinates and storing it in array 'nodes_coords'
!-----------------------------------------------
@@ -101,15 +94,12 @@
integer :: i
- print *, trim(filename)
-
open(unit=991, file=trim(filename), form='formatted' , status='old', action='read')
read(991,*) nnodes
allocate(nodes_coords(2,nnodes))
do i = 1, nnodes
read(991,*) nodes_coords(1,i), nodes_coords(2,i)
-
- end do
+ enddo
close(991)
end subroutine read_nodes_coords
@@ -126,13 +116,10 @@
integer :: i
- print *, trim(filename)
-
open(unit=992, file=trim(filename), form='formatted' , status='old', action='read')
do i = 1, nelmnts
read(992,*) num_material(i)
-
- end do
+ enddo
close(992)
end subroutine read_mat
@@ -147,7 +134,7 @@
subroutine read_acoustic_surface(filename, nelem_acoustic_surface, acoustic_surface, &
nelmnts, num_material, ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
- include './constants.h'
+ include "constants.h"
character(len=256), intent(in) :: filename
integer, intent(out) :: nelem_acoustic_surface
@@ -157,7 +144,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) :: phi
+ double precision, dimension(1:nb_materials), intent(in) :: phi
integer, intent(in) :: num_start
@@ -175,7 +162,7 @@
do i = 1, nelmnts_surface
read(993,*) acoustic_surface_tmp(1,i), acoustic_surface_tmp(2,i), acoustic_surface_tmp(3,i), acoustic_surface_tmp(4,i)
- end do
+ enddo
close(993)
acoustic_surface_tmp(1,:) = acoustic_surface_tmp(1,:) - num_start
@@ -188,8 +175,8 @@
if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
nelem_acoustic_surface = nelem_acoustic_surface + 1
- end if
- end do
+ endif
+ enddo
allocate(acoustic_surface(4,nelem_acoustic_surface))
@@ -199,8 +186,8 @@
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
- end do
+ endif
+ enddo
end subroutine read_acoustic_surface
@@ -213,7 +200,7 @@
!-----------------------------------------------
subroutine read_abs_surface(filename, nelemabs, abs_surface, num_start)
- include './constants.h'
+ include "constants.h"
character(len=256), intent(in) :: filename
integer, intent(out) :: nelemabs
@@ -232,7 +219,7 @@
do i = 1, nelemabs
read(994,*) abs_surface(1,i), abs_surface(2,i), abs_surface(3,i), abs_surface(4,i)
- end do
+ enddo
close(994)
@@ -243,54 +230,14 @@
end subroutine read_abs_surface
- !-----------------------------------------------
- ! Read receivers.
- ! 'receivers_file' contains
- ! first line: number of receivers
- ! following lines: xrec zrec
- !-----------------------------------------------
- subroutine read_receivers(filename,xs,zs,NSOURCE)
- character(len=256), intent(in) :: filename
- integer :: nrec, irec_global_number,NSOURCE
- double precision :: xrec,zrec
- double precision :: xs(NSOURCE),zs(NSOURCE)
- integer :: i,i_source
-
- open(unit=996,file='DATA/STATIONS',status='unknown')
- open(unit=997,file='OUTPUT_FILES/receivers_file',status='unknown')
- open(unit=995, file=trim(filename), form='formatted' , status='old', action='read')
- print *, 'reading receivers_file', trim(filename)
- read(995,*) nrec
- print *
- print *,'writing the DATA/STATIONS file'
- print *
- print *
- print *,'There are ',nrec,' receivers'
- print *
- print *,'Position (x,z) of the ',nrec,' receivers'
- print *
-
- do i_source = 1,NSOURCE
- write(997,"(f20.7,1x,f20.7)") xs(i_source),zs(i_source)
- enddo
- do i = 1, nrec
- read(995,*) xrec,zrec
- write(996,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") i,xrec,zrec
- write(997,"(f20.7,1x,f20.7)") xrec,zrec
- end do
-
- close(995)
- close(996)
- close(997)
-
- end subroutine read_receivers
-
!-----------------------------------------------
! Creating dual graph (adjacency is defined by 'ncommonnodes' between two elements).
!-----------------------------------------------
subroutine mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts, ncommonnodes)
+ include "constants.h"
+
integer, intent(in) :: nelmnts
integer, intent(in) :: nnodes
integer, dimension(0:esize*nelmnts-1), intent(in) :: elmnts
@@ -306,10 +253,9 @@
integer :: elem_base, elem_target
integer :: connectivity
-
allocate(xadj(0:nelmnts))
xadj(:) = 0
- allocate(adjncy(0:max_neighbour*nelmnts-1))
+ allocate(adjncy(0:max_neighbor*nelmnts-1))
adjncy(:) = 0
allocate(nnodes_elmnts(0:nnodes-1))
nnodes_elmnts(:) = 0
@@ -323,10 +269,8 @@
nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/esize
nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
- end do
+ enddo
- print *, 'nnodes_elmnts'
-
! checking which elements are neighbours ('ncommonnodes' criteria)
do j = 0, nnodes-1
do k = 0, nnodes_elmnts(j)-1
@@ -340,9 +284,9 @@
do m = 0, nnodes_elmnts(num_node)-1
if ( nodes_elmnts(m+num_node*nsize) == elem_target ) then
connectivity = connectivity + 1
- end if
- end do
- end do
+ endif
+ enddo
+ enddo
if ( connectivity >= ncommonnodes) then
@@ -350,32 +294,32 @@
do m = 0, xadj(nodes_elmnts(k+j*nsize))
if ( .not.is_neighbour ) then
- if ( adjncy(nodes_elmnts(k+j*nsize)*max_neighbour+m) == nodes_elmnts(l+j*nsize) ) then
+ if ( adjncy(nodes_elmnts(k+j*nsize)*max_neighbor+m) == nodes_elmnts(l+j*nsize) ) then
is_neighbour = .true.
- end if
- end if
- end do
+ endif
+ endif
+ enddo
if ( .not.is_neighbour ) then
- adjncy(nodes_elmnts(k+j*nsize)*max_neighbour+xadj(nodes_elmnts(k+j*nsize))) = nodes_elmnts(l+j*nsize)
+ adjncy(nodes_elmnts(k+j*nsize)*max_neighbor+xadj(nodes_elmnts(k+j*nsize))) = nodes_elmnts(l+j*nsize)
xadj(nodes_elmnts(k+j*nsize)) = xadj(nodes_elmnts(k+j*nsize)) + 1
- adjncy(nodes_elmnts(l+j*nsize)*max_neighbour+xadj(nodes_elmnts(l+j*nsize))) = nodes_elmnts(k+j*nsize)
+ adjncy(nodes_elmnts(l+j*nsize)*max_neighbor+xadj(nodes_elmnts(l+j*nsize))) = nodes_elmnts(k+j*nsize)
xadj(nodes_elmnts(l+j*nsize)) = xadj(nodes_elmnts(l+j*nsize)) + 1
- end if
- end if
- end do
- end do
- end do
+ endif
+ endif
+ enddo
+ enddo
+ enddo
! making adjacency arrays compact (to be used for partitioning)
do i = 0, nelmnts-1
k = xadj(i)
xadj(i) = nb_edges
do j = 0, k-1
- adjncy(nb_edges) = adjncy(i*max_neighbour+j)
+ adjncy(nb_edges) = adjncy(i*max_neighbor+j)
nb_edges = nb_edges + 1
- end do
- end do
+ enddo
+ enddo
xadj(nelmnts) = nb_edges
@@ -418,14 +362,14 @@
do num_part = 0, nparts-1
num_loc(num_part) = 0
- end do
+ enddo
do num_glob = 0, nelmnts-1
num_part = part(num_glob)
glob2loc_elmnts(num_glob) = num_loc(num_part)
num_loc(num_part) = num_loc(num_part) + 1
- end do
+ enddo
end subroutine Construct_glob2loc_elmnts
@@ -437,6 +381,8 @@
subroutine Construct_glob2loc_nodes(nelmnts, nnodes, nnodes_elmnts, nodes_elmnts, part, nparts, &
glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes)
+ include "constants.h"
+
integer, intent(in) :: nelmnts, nnodes, nparts
integer, dimension(0:nelmnts-1), intent(in) :: part
integer, dimension(0:nnodes-1), intent(in) :: nnodes_elmnts
@@ -464,17 +410,17 @@
do el = 0, nnodes_elmnts(num_node)-1
parts_node(part(nodes_elmnts(el+nsize*num_node))) = 1
- end do
+ enddo
do num_part = 0, nparts-1
if ( parts_node(num_part) == 1 ) then
size_glob2loc_nodes = size_glob2loc_nodes + 1
parts_node(num_part) = 0
- end if
- end do
+ endif
+ enddo
- end do
+ enddo
glob2loc_nodes_nparts(nnodes) = size_glob2loc_nodes
@@ -492,7 +438,7 @@
do el = 0, nnodes_elmnts(num_node)-1
parts_node(part(nodes_elmnts(el+nsize*num_node))) = 1
- end do
+ enddo
do num_part = 0, nparts-1
if ( parts_node(num_part) == 1 ) then
@@ -501,10 +447,10 @@
size_glob2loc_nodes = size_glob2loc_nodes + 1
num_parts(num_part) = num_parts(num_part) + 1
parts_node(num_part) = 0
- end if
+ endif
- end do
- end do
+ enddo
+ enddo
end subroutine Construct_glob2loc_nodes
@@ -515,18 +461,18 @@
! Two adjacent elements in distinct partitions make an entry in array tab_interfaces :
! 1/ first element, 2/ second element, 3/ number of common nodes, 4/ first node,
! 5/ second node, if relevant.
- ! No interface between acoustic and elastic elements.
+ ! No interface between acoustic, elastic, and poroelastic elements.
!--------------------------------------------------
subroutine Construct_interfaces(nelmnts, nparts, part, elmnts, xadj, adjncy, tab_interfaces, &
tab_size_interfaces, ninterfaces, nb_materials, phi_material, num_material)
- include 'constants.h'
+ include "constants.h"
integer, intent(in) :: nelmnts, nparts
integer, dimension(0:nelmnts-1), intent(in) :: part
integer, dimension(0:esize*nelmnts-1), intent(in) :: elmnts
integer, dimension(0:nelmnts), intent(in) :: xadj
- integer, dimension(0:max_neighbour*nelmnts-1), intent(in) :: adjncy
+ integer, dimension(0:max_neighbor*nelmnts-1), intent(in) :: adjncy
integer, dimension(:),pointer :: tab_size_interfaces, tab_interfaces
integer, intent(out) :: ninterfaces
integer, dimension(1:nelmnts), intent(in) :: num_material
@@ -543,8 +489,8 @@
do i = 0, nparts-1
do j = i+1, nparts-1
ninterfaces = ninterfaces + 1
- end do
- end do
+ enddo
+ enddo
allocate(tab_size_interfaces(0:ninterfaces))
tab_size_interfaces(:) = 0
@@ -556,43 +502,41 @@
do num_part_bis = num_part+1, nparts-1
do el = 0, nelmnts-1
if ( part(el) == num_part ) then
- if ( phi_material(num_material(el+1)) >= 1.d0 ) then
- is_acoustic_el = .true.
- else
+ if ( phi_material(num_material(el+1)) < TINYVAL) then
is_acoustic_el = .false.
- end if
- if ( phi_material(num_material(el+1)) < TINYVAL ) then
is_elastic_el = .true.
+ elseif ( phi_material(num_material(el+1)) >= 1.d0) then
+ is_acoustic_el = .true.
+ is_elastic_el = .false.
else
+ is_acoustic_el = .false.
is_elastic_el = .false.
- end if
-
+ endif
do el_adj = xadj(el), xadj(el+1)-1
- if ( phi_material(num_material(adjncy(el_adj)+1)) >= 1.d0 ) then
- is_acoustic_el_adj = .true.
- else
+ if ( phi_material(num_material(adjncy(el_adj)+1)) < TINYVAL) then
is_acoustic_el_adj = .false.
- end if
- if ( phi_material(num_material(adjncy(el_adj)+1)) < TINYVAL ) then
is_elastic_el_adj = .true.
+ elseif ( phi_material(num_material(adjncy(el_adj)+1)) >= 1.d0) then
+ is_acoustic_el_adj = .true.
+ is_elastic_el_adj = .false.
else
+ is_acoustic_el_adj = .false.
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
+ endif
+ if ( (part(adjncy(el_adj)) == num_part_bis) .and. (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
- end do
+
+ endif
+ enddo
+ endif
+ enddo
tab_size_interfaces(num_interface+1) = tab_size_interfaces(num_interface) + num_edge
num_edge = 0
num_interface = num_interface + 1
- end do
- end do
+ enddo
+ enddo
num_interface = 0
num_edge = 0
@@ -604,31 +548,29 @@
do num_part_bis = num_part+1, nparts-1
do el = 0, nelmnts-1
if ( part(el) == num_part ) then
- if ( phi_material(num_material(el+1)) >= 1.d0 ) then
- is_acoustic_el = .true.
- else
+ if ( phi_material(num_material(el+1)) < TINYVAL) then
is_acoustic_el = .false.
- end if
- if ( phi_material(num_material(el+1)) < TINYVAL ) then
is_elastic_el = .true.
+ elseif ( phi_material(num_material(el+1)) >= 1.d0) then
+ is_acoustic_el = .true.
+ is_elastic_el = .false.
else
+ is_acoustic_el = .false.
is_elastic_el = .false.
- end if
-
+ endif
do el_adj = xadj(el), xadj(el+1)-1
- if ( phi_material(num_material(adjncy(el_adj)+1)) >= 1.d0 ) then
- is_acoustic_el_adj = .true.
- else
+ if ( phi_material(num_material(adjncy(el_adj)+1)) < TINYVAL) then
is_acoustic_el_adj = .false.
- end if
- if ( phi_material(num_material(adjncy(el_adj)+1)) < TINYVAL ) then
is_elastic_el_adj = .true.
+ elseif ( phi_material(num_material(adjncy(el_adj)+1)) >= 1.d0) then
+ is_acoustic_el_adj = .true.
+ is_elastic_el_adj = .false.
else
+ is_acoustic_el_adj = .false.
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
+ endif
+ if ( (part(adjncy(el_adj)) == num_part_bis) .and. (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
@@ -638,27 +580,26 @@
tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+3+ncommon_nodes) &
= elmnts(el*esize+num_node)
ncommon_nodes = ncommon_nodes + 1
- end if
- end do
- end do
+ endif
+ enddo
+ enddo
if ( ncommon_nodes > 0 ) then
tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+2) = ncommon_nodes
else
print *, "Error while building interfaces!", ncommon_nodes
- end if
+ stop 'fatal error'
+ endif
num_edge = num_edge + 1
- end if
- end if
- end do
- end if
+ endif
+ enddo
+ endif
- end do
+ enddo
num_edge = 0
num_interface = num_interface + 1
- end do
- end do
+ enddo
+ enddo
-
end subroutine Construct_interfaces
@@ -687,19 +628,19 @@
if ( glob2loc_nodes_parts(j) == iproc ) then
npgeo = npgeo + 1
- end if
+ endif
- end do
- end do
+ enddo
+ enddo
else
do i = 0, nnodes-1
do j = glob2loc_nodes_nparts(i), glob2loc_nodes_nparts(i+1)-1
if ( glob2loc_nodes_parts(j) == iproc ) then
write(IIN_database,*) glob2loc_nodes(j)+1, nodes_coords(1,i+1), nodes_coords(2,i+1)
- end if
- end do
- end do
- end if
+ endif
+ enddo
+ enddo
+ endif
end subroutine Write_glob2loc_nodes_database
@@ -723,35 +664,28 @@
integer :: i,j,k
integer, dimension(0:ngnod-1) :: loc_nodes
- if ( num_phase == 1 ) then
+ if (num_phase == 1) then
+
nspec = 0
do i = 0, nelmnts-1
- if ( part(i) == iproc ) then
- nspec = nspec + 1
+ if (part(i) == iproc) nspec = nspec + 1
+ enddo
- end if
- end do
-
else
do i = 0, nelmnts-1
- if ( part(i) == iproc ) then
+ if (part(i) == iproc) then
do j = 0, ngnod-1
do k = glob2loc_nodes_nparts(elmnts(i*ngnod+j)), glob2loc_nodes_nparts(elmnts(i*ngnod+j)+1)-1
-
- if ( glob2loc_nodes_parts(k) == iproc ) then
- loc_nodes(j) = glob2loc_nodes(k)
-
- end if
- end do
-
- end do
+ if (glob2loc_nodes_parts(k) == iproc) loc_nodes(j) = glob2loc_nodes(k)
+ enddo
+ enddo
write(IIN_database,*) glob2loc_elmnts(i)+1, num_modele(i+1), (loc_nodes(k)+1, k=0,ngnod-1)
- end if
- end do
- end if
+ endif
+ enddo
+ endif
end subroutine write_partition_database
@@ -797,10 +731,10 @@
(i == iproc .or. j == iproc) ) then
my_interfaces(num_interface) = 1
my_nb_interfaces(num_interface) = tab_size_interfaces(num_interface+1) - tab_size_interfaces(num_interface)
- end if
+ endif
num_interface = num_interface + 1
- end do
- end do
+ enddo
+ enddo
my_ninterface = sum(my_interfaces(:))
else
@@ -812,22 +746,22 @@
write(IIN_database,*) j, my_nb_interfaces(num_interface)
else
write(IIN_database,*) i, my_nb_interfaces(num_interface)
- end if
+ endif
do k = tab_size_interfaces(num_interface), tab_size_interfaces(num_interface+1)-1
if ( i == iproc ) then
local_elmnt = glob2loc_elmnts(tab_interfaces(k*5+0))+1
else
local_elmnt = glob2loc_elmnts(tab_interfaces(k*5+1))+1
- end if
+ endif
if ( tab_interfaces(k*5+2) == 1 ) then
do l = glob2loc_nodes_nparts(tab_interfaces(k*5+3)), &
glob2loc_nodes_nparts(tab_interfaces(k*5+3)+1)-1
if ( glob2loc_nodes_parts(l) == iproc ) then
local_nodes(1) = glob2loc_nodes(l)+1
- end if
- end do
+ endif
+ enddo
write(IIN_database,*) local_elmnt, tab_interfaces(k*5+2), local_nodes(1), -1
else
@@ -836,28 +770,28 @@
glob2loc_nodes_nparts(tab_interfaces(k*5+3)+1)-1
if ( glob2loc_nodes_parts(l) == iproc ) then
local_nodes(1) = glob2loc_nodes(l)+1
- end if
- end do
+ endif
+ enddo
do l = glob2loc_nodes_nparts(tab_interfaces(k*5+4)), &
glob2loc_nodes_nparts(tab_interfaces(k*5+4)+1)-1
if ( glob2loc_nodes_parts(l) == iproc ) then
local_nodes(2) = glob2loc_nodes(l)+1
- end if
- end do
+ endif
+ enddo
write(IIN_database,*) local_elmnt, tab_interfaces(k*5+2), local_nodes(1), local_nodes(2)
else
write(IIN_database,*) "erreur_write_interface_", tab_interfaces(k*5+2)
- end if
- end if
- end do
+ endif
+ endif
+ enddo
- end if
+ endif
num_interface = num_interface + 1
- end do
- end do
+ enddo
+ enddo
- end if
+ endif
end subroutine Write_interfaces_database
@@ -895,8 +829,8 @@
if ( part(surface(1,i)) == iproc ) then
nsurface_loc = nsurface_loc + 1
- end if
- end do
+ endif
+ enddo
else
@@ -913,41 +847,40 @@
glob2loc_nodes_nparts(surface(3,i)+1)-1
if ( glob2loc_nodes_parts(l) == iproc ) then
local_nodes(1) = glob2loc_nodes(l)+1
- end if
- end do
+ endif
+ enddo
write(IIN_database,*) local_elmnt, surface(2,i), local_nodes(1), -1
- end if
+ endif
if ( surface(2,i) == 2 ) then
do l = glob2loc_nodes_nparts(surface(3,i)), &
glob2loc_nodes_nparts(surface(3,i)+1)-1
if ( glob2loc_nodes_parts(l) == iproc ) then
local_nodes(1) = glob2loc_nodes(l)+1
- end if
- end do
+ endif
+ enddo
do l = glob2loc_nodes_nparts(surface(4,i)), &
glob2loc_nodes_nparts(surface(4,i)+1)-1
if ( glob2loc_nodes_parts(l) == iproc ) then
local_nodes(2) = glob2loc_nodes(l)+1
- end if
- end do
+ endif
+ enddo
write(IIN_database,*) local_elmnt, surface(2,i), local_nodes(1), local_nodes(2)
- end if
+ endif
- end if
+ endif
- end do
+ enddo
- end if
+ endif
end subroutine Write_surface_database
!--------------------------------------------------
! Set absorbing boundaries by elements instead of edges.
- ! Excludes points that have both absorbing condition and coupled fluid/solid fluid/poro poro/solid
- ! relation (this is the
+ ! Excludes points that have both absorbing condition and coupled fluid/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.
!--------------------------------------------------
@@ -955,13 +888,12 @@
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, nedges_acporo_coupled, edges_acporo_coupled, nedges_elporo_coupled, &
- edges_elporo_coupled, nb_materials, phi_material, num_material, &
+ nedges_coupled, edges_coupled, nb_materials, phi_material, num_material, &
nelmnts, &
elmnts, ngnod)
implicit none
- include 'constants.h'
+ include "constants.h"
integer, intent(inout) :: nelemabs
integer, intent(out) :: nelemabs_merge
@@ -972,15 +904,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,nedges_acporo_coupled,nedges_elporo_coupled
- integer, dimension(:,:), pointer :: edges_coupled,edges_acporo_coupled,edges_elporo_coupled
+ integer :: nedges_coupled
+ integer, dimension(:,:), pointer :: edges_coupled
integer :: nb_materials
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,is_poroelastic
+ logical, dimension(nb_materials) :: is_acoustic
integer :: num_edge, nedge_bound
integer :: match
integer :: nb_elmnts_abs
@@ -1004,13 +936,13 @@
if ( abs_surface(1,num_edge) == abs_surface_merge(i) ) then
match = i
exit
- end if
- end do
+ endif
+ enddo
if ( match == 0 ) then
nb_elmnts_abs = nb_elmnts_abs + 1
match = nb_elmnts_abs
- end if
+ endif
abs_surface_merge(match) = abs_surface(1,num_edge)
@@ -1019,7 +951,7 @@
abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1)) ) then
abs_surface_char(1,match) = .true.
- end if
+ endif
if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1)) ) then
@@ -1028,13 +960,13 @@
abs_surface(3,num_edge) = temp
abs_surface_char(1,match) = .true.
- end if
+ endif
if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
abs_surface_char(4,match) = .true.
- end if
+ endif
if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
@@ -1043,13 +975,13 @@
abs_surface(3,num_edge) = temp
abs_surface_char(4,match) = .true.
- end if
+ endif
if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1) .and. &
abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2)) ) then
abs_surface_char(2,match) = .true.
- end if
+ endif
if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1) .and. &
abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2)) ) then
@@ -1058,7 +990,7 @@
abs_surface(3,num_edge) = temp
abs_surface_char(2,match) = .true.
- end if
+ endif
if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2) .and. &
abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
@@ -1067,15 +999,15 @@
abs_surface(3,num_edge) = temp
abs_surface_char(3,match) = .true.
- end if
+ endif
if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2) .and. &
abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
abs_surface_char(3,match) = .true.
- end if
+ endif
- end do
+ enddo
nelemabs_merge = nb_elmnts_abs
@@ -1098,15 +1030,11 @@
jend_left(:) = NGLLZ
is_acoustic(:) = .false.
- is_poroelastic(:) = .false.
do i = 1, nb_materials
- if (phi_material(i) >=1.d0) 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
+ endif
+ enddo
do num_edge = 1, nedge_bound
@@ -1115,8 +1043,8 @@
if ( abs_surface(1,num_edge) == abs_surface_merge(i) ) then
match = i
exit
- end if
- end do
+ endif
+ enddo
if ( is_acoustic(num_material(abs_surface(1,num_edge)+1)) ) then
@@ -1130,27 +1058,27 @@
abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) ) then
ibegin_bottom(match) = 2
- end if
+ endif
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
+ endif
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
+ endif
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
+ endif
- end if
- end do
+ endif
+ enddo
- end if
+ endif
if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_coupled(1,iedge)+inode1) ) then
do inode2 = 0, 3
@@ -1159,176 +1087,36 @@
abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) ) then
iend_bottom(match) = NGLLX - 1
- end if
+ endif
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
+ endif
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
+ endif
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
+ endif
+ endif
+ enddo
- end if
+ endif
- end do
+ enddo
- end do
+ enddo
- end if
+ endif
+ enddo
- 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
@@ -1363,8 +1151,8 @@
do i = 1, nelemabs_merge
if ( part(abs_surface_merge(i)) == iproc ) then
nelemabs_loc = nelemabs_loc + 1
- end if
- end do
+ endif
+ enddo
else
do i = 1, nelemabs_merge
if ( part(abs_surface_merge(i)) == iproc ) then
@@ -1376,10 +1164,10 @@
ibegin_top(i), iend_top(i), &
jbegin_left(i), jend_left(i)
- end if
+ endif
- end do
- end if
+ enddo
+ endif
end subroutine write_abs_merge_database
@@ -1391,10 +1179,12 @@
!--------------------------------------------------
subroutine Part_metis(nelmnts, xadj, adjncy, vwgt, adjwgt, nparts, nb_edges, edgecut, part, metis_options)
+ include "constants.h"
+
integer, intent(in) :: nelmnts, nparts, nb_edges
integer, intent(inout) :: edgecut
integer, dimension(0:nelmnts), intent(in) :: xadj
- integer, dimension(0:max_neighbour*nelmnts-1), intent(in) :: adjncy
+ integer, dimension(0:max_neighbor*nelmnts-1), intent(in) :: adjncy
integer, dimension(0:nelmnts-1), intent(in) :: vwgt
integer, dimension(0:nb_edges-1), intent(in) :: adjwgt
integer, dimension(:), pointer :: part
@@ -1406,14 +1196,11 @@
num_start = 0
wgtflag = 0
- print *, 'avant', edgecut
call METIS_PartGraphRecursive(nelmnts, xadj(0), adjncy(0), vwgt(0), adjwgt(0), wgtflag, num_start, nparts, &
metis_options, edgecut, part(0));
!call METIS_PartGraphVKway(nelmnts, xadj(0), adjncy(0), vwgt(0), adjwgt(0), wgtflag, num_start, nparts, &
! options, edgecut, part(0));
- print *, 'apres', edgecut
-
end subroutine Part_metis
#endif
@@ -1422,14 +1209,16 @@
!--------------------------------------------------
! Partitioning using SCOTCH
!--------------------------------------------------
- subroutine Part_scotch(nelmnts, xadj, adjncy, vwgt, adjwgt, nparts, nedges, edgecut, part, scotch_strategy)
+ subroutine Part_scotch(nelmnts, xadj, adjncy, vwgt, adjwgt, nparts, nb_edges, edgecut, part, scotch_strategy)
- include 'scotchf.h'
+ include "constants.h"
- integer, intent(in) :: nelmnts, nparts, nedges
+ include "scotchf.h"
+
+ integer, intent(in) :: nelmnts, nparts, nb_edges
integer, intent(inout) :: edgecut
integer, dimension(0:nelmnts), intent(in) :: xadj
- integer, dimension(0:max_neighbour*nelmnts-1), intent(in) :: adjncy
+ integer, dimension(0:max_neighbor*nelmnts-1), intent(in) :: adjncy
integer, dimension(0:nelmnts-1), intent(in) :: vwgt
integer, dimension(:), pointer :: adjwgt
integer, dimension(:), pointer :: part
@@ -1463,7 +1252,7 @@
CALL SCOTCHFGRAPHBUILD (SCOTCHGRAPH (1), 0, nelmnts, &
xadj (0), xadj (0), &
xadj (0), xadj (0), &
- nedges, &
+ nb_edges, &
adjncy (0), adjwgt (0), IERR)
IF (IERR .NE. 0) THEN
PRINT *, 'ERROR : MAIN : Cannot build graph'
@@ -1503,12 +1292,12 @@
! Repartitioning : two coupled acoustic/elastic elements are transfered to the same partition
!--------------------------------------------------
-subroutine acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
+ subroutine acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
nproc, part, nedges_coupled, edges_coupled)
implicit none
- include 'constants.h'
+ include "constants.h"
integer, intent(in) :: nelmnts, nnodes, nproc, nb_materials
double precision, dimension(nb_materials), intent(in) :: phi_material
@@ -1532,13 +1321,13 @@
is_acoustic(:) = .false.
is_elastic(:) = .false.
do i = 1, nb_materials
- if (phi_material(i) >=1.d0) then
+ if (phi_material(i) >= 1.d0) then
is_acoustic(i) = .true.
- end if
+ endif
if (phi_material(i) < TINYVAL) then
is_elastic(i) = .true.
- end if
- end do
+ endif
+ enddo
call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,2)
@@ -1548,14 +1337,12 @@
do el_adj = xadj(el), xadj(el+1) - 1
if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
nedges_coupled = nedges_coupled + 1
- end if
+ endif
- end do
- end if
- end do
+ enddo
+ endif
+ enddo
- print *, 'nedges_coupled (acoustic/elastic)', nedges_coupled
-
allocate(edges_coupled(2,nedges_coupled))
nedges_coupled = 0
@@ -1566,11 +1353,11 @@
nedges_coupled = nedges_coupled + 1
edges_coupled(1,nedges_coupled) = el
edges_coupled(2,nedges_coupled) = adjncy(el_adj)
- end if
+ endif
- end do
- end if
- end do
+ enddo
+ endif
+ enddo
do i = 1, nedges_coupled*nproc
is_repartitioned = .false.
@@ -1580,28 +1367,29 @@
part(edges_coupled(2,num_edge)) = part(edges_coupled(1,num_edge))
else
part(edges_coupled(1,num_edge)) = part(edges_coupled(2,num_edge))
- end if
+ endif
is_repartitioned = .true.
- end if
+ endif
- end do
+ enddo
if ( .not. is_repartitioned ) then
exit
- end if
- end do
+ endif
+ enddo
-end subroutine acoustic_elastic_repartitioning
+ end subroutine acoustic_elastic_repartitioning
+
!--------------------------------------------------
! Repartitioning : two coupled acoustic/poroelastic elements are transfered to the same partition
!--------------------------------------------------
-subroutine acoustic_poro_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
+ subroutine acoustic_poro_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
nproc, part, nedges_acporo_coupled, edges_acporo_coupled)
implicit none
- include 'constants.h'
+ include "constants.h"
integer, intent(in) :: nelmnts, nnodes, nproc, nb_materials
double precision, dimension(nb_materials), intent(in) :: phi_material
@@ -1627,11 +1415,11 @@
do i = 1, nb_materials
if (phi_material(i) >=1.d0) then
is_acoustic(i) = .true.
- end if
+ endif
if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
is_poroelastic(i) = .true.
- end if
- end do
+ endif
+ enddo
call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,2)
@@ -1641,11 +1429,11 @@
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
+ endif
- end do
- end if
- end do
+ enddo
+ endif
+ enddo
print *, 'nedges_coupled (acoustic/poroelastic)', nedges_acporo_coupled
@@ -1659,11 +1447,11 @@
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
+ endif
- end do
- end if
- end do
+ enddo
+ endif
+ enddo
do i = 1, nedges_acporo_coupled*nproc
is_repartitioned = .false.
@@ -1673,28 +1461,29 @@
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
+ endif
is_repartitioned = .true.
- end if
+ endif
- end do
+ enddo
if ( .not. is_repartitioned ) then
exit
- end if
- end do
+ endif
+ enddo
-end subroutine acoustic_poro_repartitioning
+ end subroutine acoustic_poro_repartitioning
+
!--------------------------------------------------
! Repartitioning : two coupled poroelastic/elastic elements are transfered to the same partition
!--------------------------------------------------
-subroutine poro_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
+ subroutine poro_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
nproc, part, nedges_elporo_coupled, edges_elporo_coupled)
implicit none
- include 'constants.h'
+ include "constants.h"
integer, intent(in) :: nelmnts, nnodes, nproc, nb_materials
double precision, dimension(nb_materials), intent(in) :: phi_material
@@ -1720,11 +1509,11 @@
do i = 1, nb_materials
if (phi_material(i) < TINYVAL) then
is_elastic(i) = .true.
- end if
+ endif
if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
is_poroelastic(i) = .true.
- end if
- end do
+ endif
+ enddo
call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,2)
@@ -1734,11 +1523,11 @@
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
+ endif
- end do
- end if
- end do
+ enddo
+ endif
+ enddo
print *, 'nedges_coupled (poroelastic/elastic)', nedges_elporo_coupled
@@ -1752,11 +1541,11 @@
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
+ endif
- end do
- end if
- end do
+ enddo
+ endif
+ enddo
do i = 1, nedges_elporo_coupled*nproc
is_repartitioned = .false.
@@ -1766,17 +1555,17 @@
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
+ endif
is_repartitioned = .true.
- end if
+ endif
- end do
+ enddo
if ( .not. is_repartitioned ) then
exit
- end if
- end do
+ endif
+ enddo
-end subroutine poro_elastic_repartitioning
+ end subroutine poro_elastic_repartitioning
!--------------------------------------------------
@@ -1784,7 +1573,7 @@
! pertaining to iproc partition in the corresponding Database
!--------------------------------------------------
-subroutine write_fluidsolid_edges_database(IIN_database, nedges_coupled, nedges_coupled_loc, &
+ subroutine write_fluidsolid_edges_database(IIN_database, nedges_coupled, nedges_coupled_loc, &
edges_coupled, glob2loc_elmnts, part, iproc, num_phase)
implicit none
@@ -1805,20 +1594,20 @@
do i = 1, nedges_coupled
if ( part(edges_coupled(1,i)) == iproc ) then
nedges_coupled_loc = nedges_coupled_loc + 1
- end if
- end do
+ endif
+ enddo
else
do i = 1, nedges_coupled
if ( part(edges_coupled(1,i)) == iproc ) then
write(IIN_database,*) glob2loc_elmnts(edges_coupled(1,i))+1, glob2loc_elmnts(edges_coupled(2,i))+1
- end if
+ endif
- end do
- end if
+ enddo
+ endif
-end subroutine write_fluidsolid_edges_database
+ end subroutine write_fluidsolid_edges_database
end module part_unstruct
Modified: seismo/2D/SPECFEM2D/branches/BIOT/plotgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/plotgll.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/plotgll.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/plotpost.F90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -4,12 +4,10 @@
! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -45,14 +43,36 @@
subroutine plotpost(displ,coord,vpext,x_source,z_source,st_xval,st_zval,it,dt,coorg, &
xinterp,zinterp,shapeint,Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
poroelastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs,&
- nelem_acoustic_surface, acoustic_edges, &
+ numabs,codeabs,anyabs,nelem_acoustic_surface, acoustic_edges, &
simulation_title,npoin,npgeo,vpmin,vpmax,nrec,NSOURCE, &
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, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poroelastic,coupled_elastic_poroelastic, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
- myrank, nproc)
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier, &
+ d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
+ d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
+ coorg_send_ps_velocity_model,RGB_send_ps_velocity_model, &
+ coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model,&
+ d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
+ d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
+ coorg_send_ps_element_mesh,color_send_ps_element_mesh, &
+ coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
+ d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs, &
+ d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
+ coorg_send_ps_abs,coorg_recv_ps_abs, &
+ d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface, &
+ d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
+ coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
+ d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field, &
+ d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
+ coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
!
! PostScript display routine
@@ -91,11 +111,14 @@
double precision, dimension(nrec) :: st_xval,st_zval
integer numabs(nelemabs),codeabs(4,nelemabs)
- logical anyabs,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only
+ logical anyabs,coupled_acoustic_elastic,coupled_acoustic_poroelastic,coupled_elastic_poroelastic, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only
! for fluid/solid edge detection
- integer :: num_fluid_solid_edges
+ integer :: num_fluid_solid_edges,num_fluid_poro_edges,num_solid_poro_edges
integer, dimension(num_fluid_solid_edges) :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge
+ integer, dimension(num_fluid_poro_edges) :: fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge
+ integer, dimension(num_solid_poro_edges) :: solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge
double precision xmax,zmax,height,xw,zw,usoffset,sizex,sizez,vpmin,vpmax
@@ -108,8 +131,7 @@
equivalence (postscript_line,ch1)
logical :: first
- double precision convert,x1,cpIloc,xa,za,xb,zb
-! double precision convert,x1,rlamda,rmu,denst,rKvol,cploc,xa,za,xb,zb
+ double precision convert,x1,rlamda,rmu,denst,rKvol,cpIloc,xa,za,xb,zb
double precision z1,x2,z2,d,d1,d2,dummy,theta,thetaup,thetadown
double precision :: mul_s,kappal_s,rhol_s
@@ -141,35 +163,81 @@
double precision, dimension(:,:), allocatable :: coorg_send
double precision, dimension(:,:), allocatable :: coorg_recv
- integer, dimension(:), allocatable :: color_send
- integer, dimension(:), allocatable :: color_recv
- double precision, dimension(:,:), allocatable :: RGB_send
- double precision, dimension(:,:), allocatable :: RGB_recv
integer :: nspec_recv
integer :: buffer_offset, RGB_offset
integer :: nb_coorg_per_elem, nb_color_per_elem
integer :: iproc, num_spec
integer :: ier
- logical :: anyabs_glob, coupled_acoustic_elastic_glob
+ logical :: anyabs_glob, coupled_acoustic_elastic_glob, coupled_acoustic_poroelastic_glob, &
+ coupled_elastic_poroelastic_glob
#ifdef USE_MPI
integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
#endif
integer :: myrank, nproc
+! plotpost arrays for postscript output
+ integer :: d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
+ d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model
+ double precision, dimension(d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model) :: &
+coorg_send_ps_velocity_model
+ double precision, dimension(d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model) :: &
+coorg_recv_ps_velocity_model
+ double precision, dimension(d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model) :: &
+RGB_send_ps_velocity_model
+ double precision, dimension(d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model) :: &
+RGB_recv_ps_velocity_model
+ integer :: d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
+ d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh, &
+ d1_color_recv_ps_element_mesh
+ double precision, dimension(d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh) :: &
+coorg_send_ps_element_mesh
+ double precision, dimension(d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh) :: &
+coorg_recv_ps_element_mesh
+ integer, dimension(d1_color_send_ps_element_mesh) :: &
+color_send_ps_element_mesh
+ integer, dimension(d1_color_recv_ps_element_mesh) :: &
+color_recv_ps_element_mesh
+ integer :: d1_coorg_send_ps_abs, d1_coorg_recv_ps_abs, &
+ d2_coorg_send_ps_abs, d2_coorg_recv_ps_abs
+ double precision, dimension(d1_coorg_send_ps_abs,d2_coorg_send_ps_abs) :: &
+coorg_send_ps_abs
+ double precision, dimension(d1_coorg_recv_ps_abs,d2_coorg_recv_ps_abs) :: &
+coorg_recv_ps_abs
+ integer :: d1_coorg_send_ps_free_surface, d1_coorg_recv_ps_free_surface, &
+ d2_coorg_send_ps_free_surface, d2_coorg_recv_ps_free_surface
+ double precision, dimension(d1_coorg_send_ps_free_surface,d2_coorg_send_ps_free_surface) :: &
+coorg_send_ps_free_surface
+ double precision, dimension(d1_coorg_recv_ps_free_surface,d2_coorg_recv_ps_free_surface) :: &
+coorg_recv_ps_free_surface
+ integer :: d1_coorg_send_ps_vector_field, d1_coorg_recv_ps_vector_field, &
+ d2_coorg_send_ps_vector_field, d2_coorg_recv_ps_vector_field
+ double precision, dimension(d1_coorg_send_ps_vector_field,d2_coorg_send_ps_vector_field) :: &
+coorg_send_ps_vector_field
+ double precision, dimension(d1_coorg_recv_ps_vector_field,d2_coorg_recv_ps_vector_field) :: &
+coorg_recv_ps_vector_field
+
#ifndef USE_MPI
- allocate(coorg_recv(1,1))
- allocate(color_recv(1))
- allocate(RGB_recv(1,1))
+! this to avoid warnings by the compiler about unused variables in the case
+! of a serial code, therefore use them once and do nothing: just set them to zero
nspec_recv = 0
nb_coorg_per_elem = 0
nb_color_per_elem = 0
ier = 0
num_spec = 0
iproc = nproc
+ coorg_recv_ps_velocity_model = 0
+ RGB_recv_ps_velocity_model = 0
+ coorg_recv_ps_element_mesh = 0
+ color_recv_ps_element_mesh = 0
+ coorg_recv_ps_abs = 0
+ coorg_recv_ps_free_surface = 0
+ coorg_recv_ps_vector_field = 0
+ allocate(coorg_recv(1,1))
deallocate(coorg_recv)
- deallocate(color_recv)
- deallocate(RGB_recv)
#endif
! A4 or US letter paper
@@ -1388,7 +1456,7 @@
if ( myrank == 0 ) then
write(IOUT,*) 'X min, max = ',xmin,xmax
write(IOUT,*) 'Z min, max = ',zmin,zmax
- end if
+ endif
! ratio of physical page size/size of the domain meshed
ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
@@ -1401,7 +1469,7 @@
#endif
if ( myrank == 0 ) then
write(IOUT,*) 'Max norm = ',dispmax
- end if
+ endif
!
!---- open PostScript file
@@ -1547,8 +1615,14 @@
if(coupled_acoustic_elastic) then
write(24,*) '(Coupled Acoustic/Elastic Wave 2D - SEM) show'
+ else if(coupled_acoustic_poroelastic) then
+ write(24,*) '(Coupled Acoustic/Poroelastic Wave 2D - SEM) show'
+ else if(coupled_elastic_poroelastic) then
+ write(24,*) '(Coupled Elastic/Poroelastic Wave 2D - SEM) show'
else if(any_acoustic) then
write(24,*) '(Acoustic Wave 2D - Spectral Element Method) show'
+ else if(any_poroelastic) then
+ write(24,*) '(Poroelastic Wave 2D - Spectral Element Method) show'
else
write(24,*) '(Elastic Wave 2D - Spectral Element Method) show'
endif
@@ -1563,8 +1637,7 @@
!---- print the spectral elements mesh in PostScript
!
- write(IOUT,*) 'Shape functions based on ',ngnod,' control nodes'
- end if
+ endif
convert = PI / 180.d0
@@ -1574,10 +1647,6 @@
!
if(modelvect) then
- if ( myrank /= 0 ) then
- allocate(coorg_send(2,nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4))
- allocate(RGB_send(1,nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)))
- end if
buffer_offset = 0
RGB_offset = 0
@@ -1598,7 +1667,7 @@
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))
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
rhol_f = density(2,kmato(ispec))
!frame properties
mul_fr = poroelastcoef(2,3,kmato(ispec))
@@ -1638,9 +1707,9 @@
write(24,500) xw,zw
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = xw
- coorg_send(2,buffer_offset) = zw
- end if
+ coorg_send_ps_velocity_model(1,buffer_offset) = xw
+ coorg_send_ps_velocity_model(2,buffer_offset) = zw
+ endif
xw = coord(1,ibool(i+subsamp,j,ispec))
zw = coord(2,ibool(i+subsamp,j,ispec))
@@ -1652,9 +1721,9 @@
write(24,499) xw,zw
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = xw
- coorg_send(2,buffer_offset) = zw
- end if
+ coorg_send_ps_velocity_model(1,buffer_offset) = xw
+ coorg_send_ps_velocity_model(2,buffer_offset) = zw
+ endif
xw = coord(1,ibool(i+subsamp,j+subsamp,ispec))
zw = coord(2,ibool(i+subsamp,j+subsamp,ispec))
@@ -1666,9 +1735,9 @@
write(24,499) xw,zw
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = xw
- coorg_send(2,buffer_offset) = zw
- end if
+ coorg_send_ps_velocity_model(1,buffer_offset) = xw
+ coorg_send_ps_velocity_model(2,buffer_offset) = zw
+ endif
xw = coord(1,ibool(i,j+subsamp,ispec))
zw = coord(2,ibool(i,j+subsamp,ispec))
@@ -1680,33 +1749,31 @@
write(24,499) xw,zw
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = xw
- coorg_send(2,buffer_offset) = zw
- end if
+ coorg_send_ps_velocity_model(1,buffer_offset) = xw
+ coorg_send_ps_velocity_model(2,buffer_offset) = zw
+ endif
! display P-velocity model using gray levels
if ( myrank == 0 ) then
write(24,604) x1
else
RGB_offset = RGB_offset + 1
- RGB_send(1,RGB_offset) = x1
- end if
+ RGB_send_ps_velocity_model(1,RGB_offset) = x1
+ endif
enddo
enddo
enddo
-
#ifdef USE_MPI
if (myrank == 0 ) then
do iproc = 1, nproc-1
call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- allocate(coorg_recv(2,nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4))
- allocate(RGB_recv(1,nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)))
- call MPI_RECV (coorg_recv(1,1), 2*nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4, &
+ call MPI_RECV (coorg_recv_ps_velocity_model(1,1), &
+ 2*nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4, &
MPI_DOUBLE_PRECISION, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (RGB_recv(1,1), nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
+ call MPI_RECV (RGB_recv_ps_velocity_model(1,1), nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
MPI_DOUBLE_PRECISION, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
buffer_offset = 0
@@ -1715,36 +1782,33 @@
do i=1,NGLLX-subsamp,subsamp
do j=1,NGLLX-subsamp,subsamp
buffer_offset = buffer_offset + 1
- write(24,500) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
+ write(24,500) coorg_recv_ps_velocity_model(1,buffer_offset), &
+ coorg_recv_ps_velocity_model(2,buffer_offset)
buffer_offset = buffer_offset + 1
- write(24,499) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
+ write(24,499) coorg_recv_ps_velocity_model(1,buffer_offset), &
+ coorg_recv_ps_velocity_model(2,buffer_offset)
buffer_offset = buffer_offset + 1
- write(24,499) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
+ write(24,499) coorg_recv_ps_velocity_model(1,buffer_offset), &
+ coorg_recv_ps_velocity_model(2,buffer_offset)
buffer_offset = buffer_offset + 1
- write(24,499) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
+ write(24,499) coorg_recv_ps_velocity_model(1,buffer_offset), &
+ coorg_recv_ps_velocity_model(2,buffer_offset)
RGB_offset = RGB_offset + 1
- write(24,604) RGB_recv(1,RGB_offset)
- end do
- end do
- end do
+ write(24,604) RGB_recv_ps_velocity_model(1,RGB_offset)
+ enddo
+ enddo
+ enddo
- deallocate(coorg_recv)
- deallocate(RGB_recv)
-
- end do
+ enddo
else
call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (coorg_send(1,1), 2*nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4, &
+ call MPI_SEND (coorg_send_ps_velocity_model(1,1), 2*nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4, &
MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (RGB_send(1,1), nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
+ call MPI_SEND (RGB_send_ps_velocity_model(1,1), nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
+ endif
- deallocate(coorg_send)
- deallocate(RGB_send)
- end if
-
-
#endif
@@ -1758,49 +1822,14 @@
write(24,*) '%'
write(24,*) '% spectral element mesh'
write(24,*) '%'
- end if
+ endif
- if ( myrank /= 0 ) then
-
- if ( ngnod == 4 ) then
- if ( numbers == 1 ) then
- allocate(coorg_send(2,nspec*5))
- if ( colors == 1 ) then
- allocate(color_send(2*nspec))
- else
- allocate(color_send(1*nspec))
- end if
- else
- allocate(coorg_send(2,nspec*6))
- if ( colors == 1 ) then
- allocate(color_send(1*nspec))
- end if
- end if
- else
- if ( numbers == 1 ) then
- allocate(coorg_send(2,nspec*((pointsdisp-1)*3+max(0,pointsdisp-2)+1+1)))
- if ( colors == 1 ) then
- allocate(color_send(2*nspec))
- else
- allocate(color_send(1*nspec))
- end if
- else
- allocate(coorg_send(2,nspec*((pointsdisp-1)*3+max(0,pointsdisp-2)+1)))
- if ( colors == 1 ) then
- allocate(color_send(1*nspec))
- end if
- end if
- end if
-
- end if
buffer_offset = 0
RGB_offset = 0
do ispec=1,nspec
- if ( myrank == 0 ) then
- write(24,*) '% elem ',ispec
- end if
+ if ( myrank == 0 ) write(24,*) '% elem ',ispec
do i=1,pointsdisp
do j=1,pointsdisp
@@ -1825,9 +1854,9 @@
write(24,681) x1,z1
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x1
- coorg_send(2,buffer_offset) = z1
- end if
+ coorg_send_ps_element_mesh(1,buffer_offset) = x1
+ coorg_send_ps_element_mesh(2,buffer_offset) = z1
+ endif
if(ngnod == 4) then
@@ -1842,9 +1871,9 @@
write(24,681) x2,z2
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x2
- coorg_send(2,buffer_offset) = z2
- end if
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
ir=pointsdisp
is=pointsdisp
@@ -1856,9 +1885,9 @@
write(24,681) x2,z2
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x2
- coorg_send(2,buffer_offset) = z2
- end if
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
is=pointsdisp
ir=1
@@ -1870,9 +1899,9 @@
write(24,681) x2,z2
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x2
- coorg_send(2,buffer_offset) = z2
- end if
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
ir=1
is=2
@@ -1884,9 +1913,9 @@
write(24,681) x2,z2
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x2
- coorg_send(2,buffer_offset) = z2
- end if
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
else
@@ -1900,9 +1929,9 @@
write(24,681) x2,z2
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x2
- coorg_send(2,buffer_offset) = z2
- end if
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
enddo
ir=pointsdisp
@@ -1915,9 +1944,9 @@
write(24,681) x2,z2
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x2
- coorg_send(2,buffer_offset) = z2
- end if
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
enddo
is=pointsdisp
@@ -1930,9 +1959,9 @@
write(24,681) x2,z2
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x2
- coorg_send(2,buffer_offset) = z2
- end if
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
enddo
ir=1
@@ -1945,16 +1974,16 @@
write(24,681) x2,z2
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x2
- coorg_send(2,buffer_offset) = z2
- end if
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
enddo
endif
if ( myrank == 0 ) then
write(24,*) 'CO'
- end if
+ endif
if(colors == 1) then
@@ -1970,8 +1999,8 @@
endif
else
RGB_offset = RGB_offset + 1
- color_send(RGB_offset) = icol
- end if
+ color_send_ps_element_mesh(RGB_offset) = icol
+ endif
endif
@@ -1983,7 +2012,7 @@
write(24,*) '0 setgray ST'
endif
endif
- end if
+ endif
! write the element number, the group number and the material number inside the element
if(numbers == 1) then
@@ -1997,29 +2026,28 @@
if ( myrank == 0 ) then
if(colors == 1) write(24,*) '1 setgray'
- end if
+ endif
if ( myrank == 0 ) then
write(24,500) xw,zw
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x2
- coorg_send(2,buffer_offset) = z2
- end if
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
! write spectral element number
if ( myrank == 0 ) then
write(24,502) ispec
else
RGB_offset = RGB_offset + 1
- color_send(RGB_offset) = ispec
- end if
+ color_send_ps_element_mesh(RGB_offset) = ispec
+ endif
endif
enddo
-
#ifdef USE_MPI
if (myrank == 0 ) then
@@ -2028,27 +2056,23 @@
nb_coorg_per_elem = 1
if ( numbers == 1 ) then
nb_coorg_per_elem = nb_coorg_per_elem + 1
- end if
+ endif
if ( ngnod == 4 ) then
nb_coorg_per_elem = nb_coorg_per_elem + 4
else
nb_coorg_per_elem = nb_coorg_per_elem + 3*(pointsdisp-1)+(pointsdisp-2)
- end if
+ endif
nb_color_per_elem = 0
if ( colors == 1 ) then
nb_color_per_elem = nb_color_per_elem + 1
- end if
+ endif
if ( numbers == 1 ) then
nb_color_per_elem = nb_color_per_elem + 1
- end if
+ endif
- allocate(coorg_recv(2,nspec_recv*nb_coorg_per_elem))
- if ( nb_color_per_elem > 0 ) then
- allocate(color_recv(nspec_recv*nb_color_per_elem))
- end if
- call MPI_RECV (coorg_recv(1,1), 2*nspec_recv*nb_coorg_per_elem, &
+ call MPI_RECV (coorg_recv_ps_element_mesh(1,1), 2*nspec_recv*nb_coorg_per_elem, &
MPI_DOUBLE_PRECISION, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (color_recv(1), nspec_recv*nb_coorg_per_elem, &
+ call MPI_RECV (color_recv_ps_element_mesh(1), nspec_recv*nb_coorg_per_elem, &
MPI_INTEGER, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
buffer_offset = 0
@@ -2059,47 +2083,51 @@
write(24,*) '% elem ',num_spec
buffer_offset = buffer_offset + 1
write(24,*) 'mark'
- write(24,681) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
if ( ngnod == 4 ) then
buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
else
do ir=2,pointsdisp
buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
- end do
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ enddo
do is=2,pointsdisp
buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
- end do
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ enddo
do ir=pointsdisp-1,1,-1
buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
- end do
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ enddo
do is=pointsdisp-1,2,-1
buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
- end do
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ enddo
- end if
+ endif
write(24,*) 'CO'
if ( colors == 1 ) then
if(meshvect) then
RGB_offset = RGB_offset + 1
- write(24,680) red(color_recv(RGB_offset)), green(color_recv(RGB_offset)), blue(color_recv(RGB_offset))
+ write(24,680) red(color_recv_ps_element_mesh(RGB_offset)),&
+ green(color_recv_ps_element_mesh(RGB_offset)),&
+ blue(color_recv_ps_element_mesh(RGB_offset))
else
RGB_offset = RGB_offset + 1
- write(24,679) red(color_recv(RGB_offset)), green(color_recv(RGB_offset)), blue(color_recv(RGB_offset))
+ write(24,679) red(color_recv_ps_element_mesh(RGB_offset)),&
+ green(color_recv_ps_element_mesh(RGB_offset)),&
+ blue(color_recv_ps_element_mesh(RGB_offset))
endif
- end if
+ endif
if(meshvect) then
if(modelvect) then
write(24,*) 'Colmesh ST'
@@ -2110,51 +2138,43 @@
if(numbers == 1) then
if(colors == 1) write(24,*) '1 setgray'
buffer_offset = buffer_offset + 1
- write(24,500) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset)
+ write(24,500) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
RGB_offset = RGB_offset + 1
- write(24,502) color_recv(RGB_offset)
- end if
+ write(24,502) color_recv_ps_element_mesh(RGB_offset)
+ endif
- end do
+ enddo
- deallocate(coorg_recv)
- deallocate(color_recv)
-
- end do
+ enddo
else
call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 43, MPI_COMM_WORLD, ier)
nb_coorg_per_elem = 1
if ( numbers == 1 ) then
nb_coorg_per_elem = nb_coorg_per_elem + 1
- end if
+ endif
if ( ngnod == 4 ) then
nb_coorg_per_elem = nb_coorg_per_elem + 4
else
nb_coorg_per_elem = nb_coorg_per_elem + 3*(pointsdisp-1)+(pointsdisp-2)
- end if
+ endif
nb_color_per_elem = 0
if ( colors == 1 ) then
nb_color_per_elem = nb_color_per_elem + 1
- end if
+ endif
if ( numbers == 1 ) then
nb_color_per_elem = nb_color_per_elem + 1
- end if
- call MPI_SEND (coorg_send(1,1), 2*nspec*nb_coorg_per_elem, &
+ endif
+ call MPI_SEND (coorg_send_ps_element_mesh(1,1), 2*nspec*nb_coorg_per_elem, &
MPI_DOUBLE_PRECISION, 0, 43, MPI_COMM_WORLD, ier)
if ( nb_color_per_elem > 0 ) then
- call MPI_SEND (color_send(1), nspec*nb_color_per_elem, &
+ call MPI_SEND (color_send_ps_element_mesh(1), nspec*nb_color_per_elem, &
MPI_INTEGER, 0, 43, MPI_COMM_WORLD, ier)
- end if
+ endif
- deallocate(coorg_send)
- deallocate(color_send)
+ endif
- end if
-
-
#endif
-
!
!--- draw absorbing boundaries with a thick color line
!
@@ -2175,11 +2195,8 @@
write(24,*) '0.10 CM setlinewidth'
write(24,*) '% uncomment this when zooming on parts of the mesh'
write(24,*) '% 0.02 CM setlinewidth'
- end if
+ endif
- if ( myrank /= 0 .and. anyabs ) then
- allocate(coorg_send(4,4*nelemabs))
- end if
buffer_offset = 0
if ( anyabs ) then
@@ -2218,59 +2235,53 @@
write(24,602) x1,z1,x2,z2
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x1
- coorg_send(2,buffer_offset) = z1
- coorg_send(3,buffer_offset) = x2
- coorg_send(4,buffer_offset) = z2
- end if
+ coorg_send_ps_abs(1,buffer_offset) = x1
+ coorg_send_ps_abs(2,buffer_offset) = z1
+ coorg_send_ps_abs(3,buffer_offset) = x2
+ coorg_send_ps_abs(4,buffer_offset) = z2
+ endif
endif
enddo
enddo
- end if
+ endif
-
#ifdef USE_MPI
if (myrank == 0 ) then
do iproc = 1, nproc-1
call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
if ( nspec_recv > 0 ) then
- allocate(coorg_recv(4,nspec_recv))
- call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
+ call MPI_RECV (coorg_recv_ps_abs(1,1), 4*nspec_recv, &
MPI_DOUBLE_PRECISION, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
buffer_offset = 0
do ispec = 1, nspec_recv
buffer_offset = buffer_offset + 1
- write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
- coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
- end do
- deallocate(coorg_recv)
- end if
- end do
+ write(24,602) coorg_recv_ps_abs(1,buffer_offset), coorg_recv_ps_abs(2,buffer_offset), &
+ coorg_recv_ps_abs(3,buffer_offset), coorg_recv_ps_abs(4,buffer_offset)
+ enddo
+ endif
+ enddo
else
call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 44, MPI_COMM_WORLD, ier)
if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
+ call MPI_SEND (coorg_send_ps_abs(1,1), 4*buffer_offset, &
MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
- deallocate(coorg_send)
- end if
+ endif
- end if
+ endif
#endif
-
if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0.01 CM setlinewidth'
- end if
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM setlinewidth'
+ endif
endif
-
!
!--- draw free surface with a thick color line
!
@@ -2286,11 +2297,8 @@
write(24,*) '0.10 CM setlinewidth'
write(24,*) '% uncomment this when zooming on parts of the mesh'
write(24,*) '% 0.02 CM setlinewidth'
- end if
+ endif
- if ( myrank /= 0 .and. nelem_acoustic_surface > 0 ) then
- allocate(coorg_send(4,4*nelem_acoustic_surface))
- end if
buffer_offset = 0
if ( nelem_acoustic_surface > 0 ) then
@@ -2309,55 +2317,48 @@
write(24,602) x1,z1,x2,z2
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x1
- coorg_send(2,buffer_offset) = z1
- coorg_send(3,buffer_offset) = x2
- coorg_send(4,buffer_offset) = z2
- end if
+ coorg_send_ps_free_surface(1,buffer_offset) = x1
+ coorg_send_ps_free_surface(2,buffer_offset) = z1
+ coorg_send_ps_free_surface(3,buffer_offset) = x2
+ coorg_send_ps_free_surface(4,buffer_offset) = z2
+ endif
enddo
- end if
+ endif
-
#ifdef USE_MPI
if (myrank == 0 ) then
do iproc = 1, nproc-1
call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
if ( nspec_recv > 0 ) then
- allocate(coorg_recv(4,nspec_recv))
- call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
+ call MPI_RECV (coorg_recv_ps_free_surface(1,1), 4*nspec_recv, &
MPI_DOUBLE_PRECISION, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
buffer_offset = 0
do ispec = 1, nspec_recv
buffer_offset = buffer_offset + 1
- write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
- coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
- end do
- deallocate(coorg_recv)
- end if
- end do
+ write(24,602) coorg_recv_ps_free_surface(1,buffer_offset), coorg_recv_ps_free_surface(2,buffer_offset), &
+ coorg_recv_ps_free_surface(3,buffer_offset), coorg_recv_ps_free_surface(4,buffer_offset)
+ enddo
+ endif
+ enddo
else
call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 44, MPI_COMM_WORLD, ier)
if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
+ call MPI_SEND (coorg_send_ps_free_surface(1,1), 4*buffer_offset, &
MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
- deallocate(coorg_send)
- end if
+ endif
- end if
+ endif
#endif
-
if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0.01 CM setlinewidth'
- end if
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM setlinewidth'
+ endif
-
-
!
!---- draw the fluid-solid coupling edges with a thick color line
!
@@ -2376,11 +2377,9 @@
write(24,*) '0.10 CM setlinewidth'
write(24,*) '% uncomment this when zooming on parts of the mesh'
write(24,*) '% 0.02 CM setlinewidth'
- end if
+ endif
- if ( myrank /= 0 .and. num_fluid_solid_edges > 0 ) then
- allocate(coorg_send(4,num_fluid_solid_edges))
- end if
+ if ( myrank /= 0 .and. num_fluid_solid_edges > 0 ) allocate(coorg_send(4,num_fluid_solid_edges))
buffer_offset = 0
! loop on all the coupling edges
@@ -2391,9 +2390,7 @@
iedge = fluid_solid_acoustic_iedge(inum)
! use pink color
- if ( myrank == 0 ) then
- write(24,*) '1 0.75 0.8 RG'
- end if
+ if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
if(iedge == ITOP) then
ideb = 3
@@ -2427,12 +2424,118 @@
coorg_send(2,buffer_offset) = z1
coorg_send(3,buffer_offset) = x2
coorg_send(4,buffer_offset) = z2
- end if
+ endif
enddo
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ allocate(coorg_recv(4,nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(24,*) '1 0.75 0.8 RG'
+ write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
+ coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
+ enddo
+ deallocate(coorg_recv)
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
+ deallocate(coorg_send)
+ endif
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM setlinewidth'
+ endif
+
+ endif
+
+!
+!---- draw the fluid-porous coupling edges with a thick color line
+!
+ coupled_acoustic_poroelastic_glob = coupled_acoustic_poroelastic
#ifdef USE_MPI
+ call MPI_ALLREDUCE(coupled_acoustic_poroelastic, coupled_acoustic_poroelastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(coupled_acoustic_poroelastic_glob .and. boundvect) then
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% fluid-porous coupling edges in the mesh'
+ write(24,*) '%'
+
+ write(24,*) '0.10 CM setlinewidth'
+ write(24,*) '% uncomment this when zooming on parts of the mesh'
+ write(24,*) '% 0.02 CM setlinewidth'
+ endif
+
+ if ( myrank /= 0 .and. num_fluid_poro_edges > 0 ) allocate(coorg_send(4,num_fluid_poro_edges))
+ buffer_offset = 0
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec = fluid_poro_acoustic_ispec(inum)
+ iedge = fluid_poro_acoustic_iedge(inum)
+
+! use pink color
+ if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
+
+ if(iedge == ITOP) then
+ ideb = 3
+ ifin = 4
+ else if(iedge == IBOTTOM) then
+ ideb = 1
+ ifin = 2
+ else if(iedge == ILEFT) then
+ ideb = 4
+ ifin = 1
+ else if(iedge == IRIGHT) then
+ ideb = 2
+ ifin = 3
+ else
+ call exit_MPI('Wrong fluid-solid coupling edge code')
+ endif
+
+ x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
+ z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
+ x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
+ z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,602) x1,z1,x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send(1,buffer_offset) = x1
+ coorg_send(2,buffer_offset) = z1
+ coorg_send(3,buffer_offset) = x2
+ coorg_send(4,buffer_offset) = z2
+ endif
+
+ enddo
+
+#ifdef USE_MPI
if (myrank == 0 ) then
do iproc = 1, nproc-1
@@ -2448,30 +2551,135 @@
write(24,*) '1 0.75 0.8 RG'
write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
- end do
+ enddo
deallocate(coorg_recv)
- end if
- end do
+ endif
+ enddo
else
call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
if ( buffer_offset > 0 ) then
call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
deallocate(coorg_send)
- end if
- end if
+ endif
+ endif
#endif
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM setlinewidth'
+ endif
+ endif
+
+!
+!---- draw the solid-porous coupling edges with a thick color line
+!
+ coupled_elastic_poroelastic_glob = coupled_elastic_poroelastic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(coupled_elastic_poroelastic, coupled_elastic_poroelastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(coupled_elastic_poroelastic_glob .and. boundvect) then
+
if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0.01 CM setlinewidth'
- end if
+ write(24,*) '%'
+ write(24,*) '% solid-porous coupling edges in the mesh'
+ write(24,*) '%'
+ write(24,*) '0.10 CM setlinewidth'
+ write(24,*) '% uncomment this when zooming on parts of the mesh'
+ write(24,*) '% 0.02 CM setlinewidth'
endif
+ if ( myrank /= 0 .and. num_solid_poro_edges > 0 ) allocate(coorg_send(4,num_solid_poro_edges))
+ buffer_offset = 0
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the poroelastic element
+ ispec = solid_poro_poroelastic_ispec(inum)
+ iedge = solid_poro_poroelastic_iedge(inum)
+
+! use pink color
+ if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
+
+ if(iedge == ITOP) then
+ ideb = 3
+ ifin = 4
+ else if(iedge == IBOTTOM) then
+ ideb = 1
+ ifin = 2
+ else if(iedge == ILEFT) then
+ ideb = 4
+ ifin = 1
+ else if(iedge == IRIGHT) then
+ ideb = 2
+ ifin = 3
+ else
+ call exit_MPI('Wrong fluid-solid coupling edge code')
+ endif
+
+ x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
+ z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
+ x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
+ z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,602) x1,z1,x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send(1,buffer_offset) = x1
+ coorg_send(2,buffer_offset) = z1
+ coorg_send(3,buffer_offset) = x2
+ coorg_send(4,buffer_offset) = z2
+ endif
+
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ allocate(coorg_recv(4,nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(24,*) '1 0.75 0.8 RG'
+ write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
+ coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
+ enddo
+ deallocate(coorg_recv)
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
+ deallocate(coorg_send)
+ endif
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM setlinewidth'
+ endif
+
+ endif
+
!
!---- draw the normalized vector field
!
@@ -2493,13 +2701,11 @@
else
write(24,*) '0 setgray'
endif
- end if
+ endif
if(interpol) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'Interpolating the vector field...'
- end if
+ if (myrank == 0) write(IOUT,*) 'Interpolating the vector field...'
! option to plot only lowerleft corner value to avoid very large files if dense meshes
if(plot_lowerleft_corner_only) then
@@ -2508,16 +2714,16 @@
pointsdisp_loop = pointsdisp
endif
- if ( myrank /= 0 ) then
- allocate(coorg_send(8,nspec*pointsdisp_loop*pointsdisp_loop))
-
- end if
buffer_offset = 0
do ispec=1,nspec
! interpolation on a uniform grid
- if(mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec, myrank
+#ifdef USE_MPI
+ if(myrank == 0 .and. mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec,' on processor 0'
+#else
+ if(mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec
+#endif
do i=1,pointsdisp_loop
do j=1,pointsdisp_loop
@@ -2582,7 +2788,6 @@
write(postscript_line,700) xb,zb,xa,za,x2,z2,x1,z1
! suppress useless white spaces to make PostScript file smaller
-
! suppress leading white spaces again, if any
postscript_line = adjustl(postscript_line)
@@ -2603,15 +2808,15 @@
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = xb
- coorg_send(2,buffer_offset) = zb
- coorg_send(3,buffer_offset) = xa
- coorg_send(4,buffer_offset) = za
- coorg_send(5,buffer_offset) = x2
- coorg_send(6,buffer_offset) = z2
- coorg_send(7,buffer_offset) = x1
- coorg_send(8,buffer_offset) = z1
- end if
+ coorg_send_ps_vector_field(1,buffer_offset) = xb
+ coorg_send_ps_vector_field(2,buffer_offset) = zb
+ coorg_send_ps_vector_field(3,buffer_offset) = xa
+ coorg_send_ps_vector_field(4,buffer_offset) = za
+ coorg_send_ps_vector_field(5,buffer_offset) = x2
+ coorg_send_ps_vector_field(6,buffer_offset) = z2
+ coorg_send_ps_vector_field(7,buffer_offset) = x1
+ coorg_send_ps_vector_field(8,buffer_offset) = z1
+ endif
endif
@@ -2619,26 +2824,25 @@
enddo
enddo
-
#ifdef USE_MPI
if (myrank == 0 ) then
do iproc = 1, nproc-1
call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 46, MPI_COMM_WORLD, request_mpi_status, ier)
if ( nspec_recv > 0 ) then
- allocate(coorg_recv(8,nspec_recv))
- call MPI_RECV (coorg_recv(1,1), 8*nspec_recv, &
+ call MPI_RECV (coorg_recv_ps_vector_field(1,1), 8*nspec_recv, &
MPI_DOUBLE_PRECISION, iproc, 46, MPI_COMM_WORLD, request_mpi_status, ier)
buffer_offset = 0
do ispec = 1, nspec_recv
buffer_offset = buffer_offset + 1
- write(postscript_line,700) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
- coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset), &
- coorg_recv(5,buffer_offset), coorg_recv(6,buffer_offset), &
- coorg_recv(7,buffer_offset), coorg_recv(8,buffer_offset)
+ write(postscript_line,700) coorg_recv_ps_vector_field(1,buffer_offset), &
+ coorg_recv_ps_vector_field(2,buffer_offset), &
+ coorg_recv_ps_vector_field(3,buffer_offset), coorg_recv_ps_vector_field(4,buffer_offset), &
+ coorg_recv_ps_vector_field(5,buffer_offset), coorg_recv_ps_vector_field(6,buffer_offset), &
+ coorg_recv_ps_vector_field(7,buffer_offset), coorg_recv_ps_vector_field(8,buffer_offset)
+
! suppress useless white spaces to make PostScript file smaller
-
! suppress leading white spaces again, if any
postscript_line = adjustl(postscript_line)
@@ -2656,19 +2860,17 @@
enddo
ch2(index_char) = ch1(line_length)
write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
- end do
- deallocate(coorg_recv)
- end if
- end do
+ enddo
+ endif
+ enddo
else
call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 46, MPI_COMM_WORLD, ier)
if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send(1,1), 8*buffer_offset, &
+ call MPI_SEND (coorg_send_ps_vector_field(1,1), 8*buffer_offset, &
MPI_DOUBLE_PRECISION, 0, 46, MPI_COMM_WORLD, ier)
- deallocate(coorg_send)
- end if
+ endif
- end if
+ endif
#endif
@@ -2676,10 +2878,6 @@
! draw the vectors at the nodes of the mesh if we do not interpolate the display on a regular grid
else
- if ( myrank /= 0 ) then
- allocate(coorg_send(8,npoin))
-
- end if
buffer_offset = 0
do ipoin=1,npoin
@@ -2724,7 +2922,6 @@
write(postscript_line,700) xb,zb,xa,za,x2,z2,x1,z1
! suppress useless white spaces to make PostScript file smaller
-
! suppress leading white spaces again, if any
postscript_line = adjustl(postscript_line)
@@ -2745,39 +2942,38 @@
else
buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = xb
- coorg_send(2,buffer_offset) = zb
- coorg_send(3,buffer_offset) = xa
- coorg_send(4,buffer_offset) = za
- coorg_send(5,buffer_offset) = x2
- coorg_send(6,buffer_offset) = z2
- coorg_send(7,buffer_offset) = x1
- coorg_send(8,buffer_offset) = z1
- end if
+ coorg_send_ps_vector_field(1,buffer_offset) = xb
+ coorg_send_ps_vector_field(2,buffer_offset) = zb
+ coorg_send_ps_vector_field(3,buffer_offset) = xa
+ coorg_send_ps_vector_field(4,buffer_offset) = za
+ coorg_send_ps_vector_field(5,buffer_offset) = x2
+ coorg_send_ps_vector_field(6,buffer_offset) = z2
+ coorg_send_ps_vector_field(7,buffer_offset) = x1
+ coorg_send_ps_vector_field(8,buffer_offset) = z1
endif
+ endif
enddo
-
#ifdef USE_MPI
if (myrank == 0 ) then
do iproc = 1, nproc-1
call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 47, MPI_COMM_WORLD, request_mpi_status, ier)
if ( nspec_recv > 0 ) then
- allocate(coorg_recv(8,nspec_recv))
- call MPI_RECV (coorg_recv(1,1), 8*nspec_recv, &
+ call MPI_RECV (coorg_recv_ps_vector_field(1,1), 8*nspec_recv, &
MPI_DOUBLE_PRECISION, iproc, 47, MPI_COMM_WORLD, request_mpi_status, ier)
buffer_offset = 0
do ispec = 1, nspec_recv
buffer_offset = buffer_offset + 1
- write(postscript_line,700) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
- coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset), &
- coorg_recv(5,buffer_offset), coorg_recv(6,buffer_offset), &
- coorg_recv(7,buffer_offset), coorg_recv(8,buffer_offset)
+ write(postscript_line,700) coorg_recv_ps_vector_field(1,buffer_offset), &
+ coorg_recv_ps_vector_field(2,buffer_offset), &
+ coorg_recv_ps_vector_field(3,buffer_offset), coorg_recv_ps_vector_field(4,buffer_offset), &
+ coorg_recv_ps_vector_field(5,buffer_offset), coorg_recv_ps_vector_field(6,buffer_offset), &
+ coorg_recv_ps_vector_field(7,buffer_offset), coorg_recv_ps_vector_field(8,buffer_offset)
+
! suppress useless white spaces to make PostScript file smaller
-
! suppress leading white spaces again, if any
postscript_line = adjustl(postscript_line)
@@ -2795,22 +2991,19 @@
enddo
ch2(index_char) = ch1(line_length)
write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
- end do
- deallocate(coorg_recv)
- end if
- end do
+ enddo
+ endif
+ enddo
else
call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 47, MPI_COMM_WORLD, ier)
if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send(1,1), 8*buffer_offset, &
+ call MPI_SEND (coorg_send_ps_vector_field(1,1), 8*buffer_offset, &
MPI_DOUBLE_PRECISION, 0, 47, MPI_COMM_WORLD, ier)
- deallocate(coorg_send)
- end if
- end if
+ endif
+ endif
#endif
-
endif
if ( myrank == 0 ) then
@@ -2862,7 +3055,7 @@
write(24,*) 'showpage'
close(24)
- end if
+ endif
10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
600 format(f6.3,' neg CM 0 MR (Time =',f8.3,' s) show')
Modified: seismo/2D/SPECFEM2D/branches/BIOT/read_value_parameters.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/read_value_parameters.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/read_value_parameters.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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,22 +139,25 @@
!--------------------
- subroutine read_material_parameters(iin,ignore_junk,i,icodematread,rhosread,rhofread,phiread,tortuosityread,&
- permxxread,permxzread,permzzread,kappasread,kappafread,kappafrread,musread,etafread,mufrread)
+ subroutine read_material_parameters(iin,ignore_junk,i,icodematread,val0read,val1read,val2read,val3read, &
+ val4read,val5read,val6read,val7read,val8read,val9read,val10read,val11read,val12read)
+
implicit none
integer iin
logical ignore_junk
integer i,icodematread
- double precision rhosread,rhofread,phiread,tortuosityread,permxxread,permxzread,permzzread
- double precision kappasread,kappafread,kappafrread,musread,etafread,mufrread
+ double precision val0read,val1read,val2read,val3read,val4read,val5read,val6read,val7read,&
+ val8read,val9read,val10read,val11read,val12read
+
character(len=100) string_read
call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) i,icodematread,rhosread,rhofread,phiread,tortuosityread,permxxread,permxzread,&
- permzzread,kappasread,kappafread,kappafrread,musread,etafread,mufrread
+ read(string_read,*) i,icodematread,val0read,val1read,val2read,val3read,val4read,val5read,&
+ val6read,val7read,val8read,val9read,val10read,val11read,val12read
+
end subroutine read_material_parameters
!--------------------
Modified: seismo/2D/SPECFEM2D/branches/BIOT/recompute_jacobian.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/recompute_jacobian.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/recompute_jacobian.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/specfem2D.F90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,15 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 6.3
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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
@@ -69,30 +67,28 @@
! volume=88,
! number=2,
! pages={368-392}}
-
-! version 6.4, Christina Morency 2009
-! - visco attenuation (poroelastic) added [see Morency & Tromp, GJI 2008]
-! version 6.3, Christina Morency & Yang Luo 2008
-! - adjoint method: attenuation is not taken into account yet
-! - multiple sources
!
-! 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
+! If you use the METIS / SCOTCH / CUBIT non-structured version, please also cite:
!
-! version 6.1, Christina Morency, July 2007:
-! - Solve Biot poroelastic equations
-! - Acoustic/poroelastic coupling
-! - Energy calculation available (flag in constants.h)
+! @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.0, Christina Morency, May 2007:
-! - Solve Biot poroelastic equations
-!
-! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, November 2007:
+! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, February 2008:
! - 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)
@@ -128,14 +124,21 @@
! Institut de Physique du Globe de Paris, France
!
-! in case of an acoustic medium, a displacement potential Chi is used as in Chaljub and Valette,
+! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
! This permits acoustic-elastic coupling based on a non-iterative time scheme.
-! Displacement is then: u = grad(Chi)
-! 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).
+! Displacement is then: u = grad(Chi) / rho
+! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
! The source in an acoustic element is a pressure source.
+! First-order acoustic-acoustic discontinuities are also handled automatically
+! because pressure is continuous at such an interface, therefore Chi_dot_dot
+! is continuous, therefore Chi is also continuous, which is consistent with
+! the spectral-element basis functions and with the assembling process.
+! This is the reason why a simple displacement potential u = grad(Chi) would
+! not work because it would be discontinuous at such an interface and would
+! therefore not be consistent with the basis functions.
program specfem2D
@@ -147,10 +150,11 @@
#endif
character(len=80) datlin
+
integer NSOURCE,i_source
integer, dimension(:), allocatable :: source_type,time_function_type
- double precision, dimension(:), allocatable :: x_source,z_source,xi_source,gamma_source, aval
- double precision, dimension(:), allocatable :: Mxx,Mzz,Mxz,f0,t0,factor,angleforce,hdur,hdur_gauss
+ double precision, dimension(:), allocatable :: x_source,z_source,xi_source,gamma_source,&
+ Mxx,Mzz,Mxz,f0,t0,factor,angleforce,hdur,hdur_gauss
real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: sourcearray
double precision, dimension(:,:), allocatable :: coorg
@@ -163,7 +167,7 @@
character(len=150) dummystring
! for seismograms
- double precision, dimension(:,:), allocatable :: sisux,sisuz
+ double precision, dimension(:,:), allocatable :: sisux,sisuz,siscurl
integer :: seismo_offset, seismo_current
! vector field in an element
@@ -172,9 +176,12 @@
! pressure in an element
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
- integer :: i,j,k,l,it,irec,ipoin,ip,id,nbpoin,inump,n,ispec,npoin,npgeo,iglob
+! 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
logical :: anyabs
- double precision :: dxd,dzd,valux,valuz,hlagrange,cosrot,sinrot,xi,gamma,x,z
+ double precision :: dxd,dzd,dcurld,valux,valuz,valcurl,hlagrange,rhol,cosrot,sinrot,xi,gamma,x,z
! coefficients of the explicit Newmark time scheme
integer NSTEP
@@ -194,7 +201,7 @@
double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
! material properties of the elastic medium
- double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal,cpsquare
+ double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_elastic,veloc_elastic,displ_elastic
double precision, dimension(:,:), allocatable :: coord, flagrange,xinterp,zinterp,Uxinterp,Uzinterp,vector_field_display
@@ -202,17 +209,21 @@
! 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
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: velocs_poroelastic_smooth,displs_poroelastic_smooth
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: velocw_poroelastic_smooth,displw_poroelastic_smooth
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
+! for acoustic medium
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
+
+! inverse mass matrices
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_inverse_elastic,rmass_inverse_acoustic
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
+
+! to evaluate cpI, cpII, and cs, and rI (poroelastic medium)
+ real(kind=CUSTOM_REAL) :: 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
@@ -221,36 +232,32 @@
real(kind=CUSTOM_REAL) :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,B_biot,cpIsquare,cpIIsquare,cssquare
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 :: displread,velocread,accelread
-
double precision, dimension(:), allocatable :: vp_display
double precision, dimension(:,:,:), allocatable :: vpext,vsext,rhoext
- double precision :: previous_vsext
+ double precision :: previous_vsext,rho_at_source_location
double precision, dimension(:,:,:), allocatable :: shape2D,shape2D_display
real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: xix,xiz,gammax,gammaz,jacobian
double precision, dimension(:,:,:,:), allocatable :: dershape2D,dershape2D_display
- integer, dimension(:,:,:), allocatable :: ibool
+ integer, dimension(:,:,:), allocatable :: ibool,ibool_outer,ibool_inner
integer, dimension(:,:), allocatable :: knods
- 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, dimension(:), allocatable :: kmato,numabs, &
+ ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
- integer, dimension(:), allocatable :: ispec_selected_source,iglob_source,ix_source,iz_source,is_proc_source,nb_proc_source
- double precision displnorm_all,displnorm_all_glob,displnormw_all,displnormw_all_glob
+ integer, dimension(:), allocatable :: ispec_selected_source,iglob_source,ix_source,iz_source,&
+ is_proc_source,nb_proc_source
+ double precision displnorm_all,displnorm_all_glob
+ double precision, dimension(:), allocatable :: aval
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: source_time_function
double precision, external :: netlib_specfun_erf
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
+ integer :: numat,ngnod,nspec,pointsdisp,nelemabs,nelem_acoustic_surface,ispecabs,UPPER_LIMIT_DISPLAY
logical interpol,meshvect,modelvect,boundvect,assign_external_model,initialfield, &
outputgrid,gnuplot,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,output_postscript_snapshot,output_color_image, &
@@ -265,20 +272,19 @@
logical, dimension(:,:), allocatable :: codeabs
-! for detection elastic and acoustic valences
- integer, dimension(:), allocatable :: valence_elastic,valence_acoustic,valence_poroelastic
-
! for attenuation
integer :: N_SLS
- double precision :: Qp_attenuation
- double precision :: Qs_attenuation
+ double precision, dimension(:), allocatable :: Qp_attenuation
+ double precision, dimension(:), allocatable :: Qs_attenuation
double precision :: f0_attenuation
integer nspec_allocate
double precision :: deltatsquare,deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: e1,e11,e13
- double precision, dimension(:), allocatable :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
- double precision :: Mu_nu1,Mu_nu2
+ double precision, dimension(:,:,:,:), allocatable :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
+ double precision, dimension(:), allocatable :: inv_tau_sigma_nu1_sent,phi_nu1_sent,inv_tau_sigma_nu2_sent,phi_nu2_sent
+ double precision, dimension(:,:,:) , allocatable :: Mu_nu1,Mu_nu2
+ double precision :: Mu_nu1_sent,Mu_nu2_sent
real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
@@ -303,17 +309,19 @@
integer, dimension(NGLLX,NEDGES) :: ivalue,jvalue,ivalue_inverse,jvalue_inverse
integer, dimension(:), allocatable :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge, &
fluid_solid_elastic_ispec,fluid_solid_elastic_iedge
+ integer :: fluid_solid_acoustic_ispec_read, fluid_solid_elastic_ispec_read
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,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
+ real(kind=CUSTOM_REAL) :: displ_x,displ_z,displ_n,displw_x,displw_z,zxi,xgamma,jacobian1D,pressure
+ real(kind=CUSTOM_REAL) :: b_displ_x,b_displ_z,b_displw_x,b_displw_z,b_pressure
! 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 :: fluid_poro_acoustic_ispec_read, fluid_poro_poroelastic_ispec_read
integer :: num_fluid_poro_edges,num_fluid_poro_edges_alloc,iedge_poroelastic
logical :: coupled_acoustic_poroelastic
double precision :: mul_G,lambdal_G,lambdalplus2mul_G
@@ -329,6 +337,7 @@
! 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 :: solid_poro_elastic_ispec_read, solid_poro_poroelastic_ispec_read
integer :: num_solid_poro_edges,num_solid_poro_edges_alloc,ispec_poroelastic,ii2,jj2
logical :: coupled_elastic_poroelastic
double precision, dimension(:,:), allocatable :: displ,veloc
@@ -355,7 +364,7 @@
real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhop_ac_kl, alpha_ac_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, ratio_kl
+ rhobb_kl, rhofbb_kl, phib_kl, cpI_kl, cpII_kl, cs_kl, ratio_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, &
@@ -424,7 +433,7 @@
integer ihours,iminutes,iseconds,int_tCPU
double precision :: time_start,time_end,tCPU
-! for MPI and partitionning
+! for MPI and partitioning
integer :: ier
integer :: nproc
integer :: myrank
@@ -449,12 +458,9 @@
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
- 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
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_pos,buffer_send_faces_vector_pow
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_pos,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
@@ -464,6 +470,7 @@
logical, dimension(:), allocatable :: mask_ispec_inner_outer
integer, dimension(:,:), allocatable :: acoustic_surface
+ integer :: acoustic_edges_read
integer, dimension(:,:), allocatable :: acoustic_edges
integer :: ixmin, ixmax, izmin, izmax
@@ -484,7 +491,68 @@
double precision :: angleforce_refl, c_inc, c_refl, cploc, csloc, denst, lambdaplus2mu, mu, p
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
+#ifdef USE_MPI
+ double precision :: xmax_glob, xmin_glob, zmax_glob, zmin_glob
+#endif
+! 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,kmato_read,my_interfaces_read
+ integer :: npoin_outer,npoin_inner
+ integer, dimension(:), allocatable :: knods_read
+ integer, dimension(:), allocatable :: perm,antecedent_list,check_perm
+
+! arrays for plotpost
+ integer :: d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
+ d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model
+ double precision, dimension(:,:), allocatable :: coorg_send_ps_velocity_model
+ double precision, dimension(:,:), allocatable :: coorg_recv_ps_velocity_model
+ double precision, dimension(:,:), allocatable :: RGB_send_ps_velocity_model
+ double precision, dimension(:,:), allocatable :: RGB_recv_ps_velocity_model
+ integer :: d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
+ d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh, &
+ d1_color_recv_ps_element_mesh
+ double precision, dimension(:,:), allocatable :: coorg_send_ps_element_mesh
+ double precision, dimension(:,:), allocatable :: coorg_recv_ps_element_mesh
+ integer, dimension(:), allocatable :: color_send_ps_element_mesh
+ integer, dimension(:), allocatable :: color_recv_ps_element_mesh
+ integer :: d1_coorg_send_ps_abs, d2_coorg_send_ps_abs, &
+ d1_coorg_recv_ps_abs, d2_coorg_recv_ps_abs
+ double precision, dimension(:,:), allocatable :: coorg_send_ps_abs
+ double precision, dimension(:,:), allocatable :: coorg_recv_ps_abs
+ integer :: d1_coorg_send_ps_free_surface, d2_coorg_send_ps_free_surface, &
+ d1_coorg_recv_ps_free_surface, d2_coorg_recv_ps_free_surface
+ double precision, dimension(:,:), allocatable :: coorg_send_ps_free_surface
+ double precision, dimension(:,:), allocatable :: coorg_recv_ps_free_surface
+ integer :: d1_coorg_send_ps_vector_field, d2_coorg_send_ps_vector_field, &
+ d1_coorg_recv_ps_vector_field, d2_coorg_recv_ps_vector_field
+ double precision, dimension(:,:), allocatable :: coorg_send_ps_vector_field
+ double precision, dimension(:,:), allocatable :: coorg_recv_ps_vector_field
+
+! tangential detection
+ double precision, dimension(:), allocatable :: anglerec_irec
+ double precision, dimension(:), allocatable :: cosrot_irec, sinrot_irec
+ double precision, dimension(:), allocatable :: x_final_receiver, z_final_receiver
+ logical :: force_normal_to_surface,rec_normal_to_surface
+ integer :: nnodes_tangential_curve
+ integer, dimension(:), allocatable :: source_courbe_eros
+ double precision, dimension(:,:), allocatable :: nodes_tangential_curve
+ integer :: n1_tangential_detection_curve
+ integer, dimension(4) :: n_tangential_detection_curve
+ integer, dimension(:), allocatable :: rec_tangential_detection_curve
+ double precision :: distmin, dist_current, angleforce_recv
+ double precision, dimension(:), allocatable :: dist_tangential_detection_curve
+ double precision :: x_final_receiver_dummy, z_final_receiver_dummy
+
!***********************************************************************
!
! i n i t i a l i z a t i o n p h a s e
@@ -496,6 +564,14 @@
call MPI_COMM_SIZE(MPI_COMM_WORLD,nproc,ier)
call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+! this is only used in the case of MPI because it distinguishes between inner and outer element
+! in the MPI partitions, which is meaningless in the serial case
+ if(FURTHER_REDUCE_CACHE_MISSES) then
+ NUMBER_OF_PASSES = 2
+ else
+ NUMBER_OF_PASSES = 1
+ endif
+
#else
nproc = 1
myrank = 0
@@ -504,18 +580,34 @@
ninterface_elastic = 0
ninterface_poroelastic = 0
iproc = 0
+ ispec_inner = 0
+ ispec_outer = 0
+ if(PERFORM_CUTHILL_MCKEE) then
+ NUMBER_OF_PASSES = 2
+ else
+ NUMBER_OF_PASSES = 1
+ endif
#endif
- write(prname,230)myrank
-230 format('./OUTPUT_FILES/Database',i5.5)
+! determine if we write to file instead of standard output
+ if(IOUT /= ISTANDARD_OUTPUT) then
+#ifdef USE_MPI
+ write(prname,240) myrank
+ 240 format('simulation_results',i5.5,'.txt')
+#else
+ prname = 'simulation_results.txt'
+#endif
+ open(IOUT,file=prname,status='unknown',action='write')
+ endif
+! reduction of cache misses inner/outer in two passes
+ do ipass = 1,NUMBER_OF_PASSES
+
+ 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')
-
!
!--- read job title and skip remaining titles of the input file
!
@@ -529,18 +621,16 @@
!
!---- print the date, time and start-up banner
!
- if ( myrank == 0 ) then
- call datim(simulation_title)
- endif
+ if (myrank == 0 .and. ipass == 1) call datim(simulation_title)
- if ( myrank == 0 ) then
- write(IOUT,*)
- write(IOUT,*)
- write(IOUT,*) '*********************'
- write(IOUT,*) '**** ****'
- write(IOUT,*) '**** SPECFEM2D ****'
- write(IOUT,*) '**** ****'
- write(IOUT,*) '*********************'
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,*) '*********************'
+ write(IOUT,*) '**** ****'
+ write(IOUT,*) '**** SPECFEM2D ****'
+ write(IOUT,*) '**** ****'
+ write(IOUT,*) '*********************'
endif
!
@@ -572,13 +662,14 @@
read(IIN,"(a80)") datlin
read(IIN,*) seismotype,imagetype,save_forward
- if(seismotype < 1 .or. seismotype > 5) call exit_MPI('Wrong type for seismogram output')
+ if(seismotype < 1 .or. seismotype > 6) 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 .and. seismotype /= 5)) then
+
+ if(save_forward .and. (seismotype /= 1 .and. seismotype /= 6)) then
print*, '***** WARNING *****'
print*, 'seismotype =',seismotype
- print*, 'Save forward wavefield => seismogram must be in displacement or potential'
- print*, 'Seismotype must be changed to 1 (elastic/poroelastic adjoint source) or 5 (acoustic iadjoint source)'
+ print*, 'Save forward wavefield => seismogram must be in displacement for (poro)elastic or potential for acoustic'
+ print*, 'Seismotype must be changed to 1 (elastic/poroelastic adjoint source) or 6 (acoustic adjoint source)'
stop
endif
@@ -589,42 +680,33 @@
read(IIN,*) TURN_VISCATTENUATION_ON,Q0,freq0
!---- check parameters read
- write(IOUT,200) npgeo,NDIM
- write(IOUT,600) NTSTEP_BETWEEN_OUTPUT_INFO,colors,numbers
- write(IOUT,700) seismotype,anglerec
- write(IOUT,750) initialfield,add_Bielak_conditions,assign_external_model,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,outputgrid
- write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,200) npgeo,NDIM
+ write(IOUT,600) NTSTEP_BETWEEN_OUTPUT_INFO,colors,numbers
+ write(IOUT,700) seismotype,anglerec
+ write(IOUT,750) initialfield,add_Bielak_conditions,assign_external_model,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,outputgrid
+ write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
+ endif
!---- read time step
read(IIN,"(a80)") datlin
read(IIN,*) NSTEP,deltat,isolver
- if ( myrank == 0 ) then
- write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+ if (myrank == 0 .and. ipass == 1) write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+
+ if(isolver == 1 .and. save_forward .and. (TURN_ANISOTROPY_ON .or. TURN_ATTENUATION_ON .or. TURN_VISCATTENUATION_ON)) then
+ print*, '*************** WARNING ***************'
+ print*, 'Anisotropy & Attenuation & Viscous damping are not presently implemented for adjoint calculations'
+ stop
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
!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!yang
read(IIN,"(a80)") datlin
read(IIN,*) NSOURCE
+ if(ipass == 1) then
allocate( source_type(NSOURCE) )
allocate( time_function_type(NSOURCE) )
allocate( x_source(NSOURCE) )
@@ -641,6 +723,7 @@
allocate( aval(NSOURCE) )
allocate( ispec_selected_source(NSOURCE) )
allocate( iglob_source(NSOURCE) )
+ allocate( source_courbe_eros(NSOURCE) )
allocate( ix_source(NSOURCE) )
allocate( iz_source(NSOURCE) )
allocate( xi_source(NSOURCE) )
@@ -648,6 +731,8 @@
allocate( is_proc_source(NSOURCE) )
allocate( nb_proc_source(NSOURCE) )
allocate( sourcearray(NSOURCE,NDIM,NGLLX,NGLLZ) )
+ endif
+
do i_source=1,NSOURCE
read(IIN,"(a80)") datlin
read(IIN,*) source_type(i_source),time_function_type(i_source),x_source(i_source),z_source(i_source), &
@@ -659,12 +744,13 @@
!---- read attenuation information
!
read(IIN,"(a80)") datlin
- read(IIN,*) N_SLS, Qp_attenuation, Qs_attenuation, f0_attenuation
+ read(IIN,*) N_SLS, f0_attenuation
!
!----- check the input
!
-do i_source=1,NSOURCE
+ do i_source=1,NSOURCE
+
if(.not. initialfield) then
if (source_type(i_source) == 1) then
if ( myrank == 0 ) then
@@ -680,17 +766,30 @@
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(i_source) == 4 .or. time_function_type(i_source) == 5) then
+ f0(i_source) = 1.d0 / (10.d0 * deltat)
+ if(time_function_type(i_source) == 5) then
+ t0(i_source) = 2.0d0 / f0(i_source)
+ else
+ t0(i_source) = 1.20d0 / f0(i_source)
+ endif
+ endif
! for the source time function
aval(i_source) = pi*pi*f0(i_source)*f0(i_source)
!----- convert angle from degrees to radians
angleforce(i_source) = angleforce(i_source) * pi / 180.d0
-enddo
+
+ enddo ! do i_source=1,NSOURCE
+
!
!---- read the spectral macrobloc nodal coordinates
!
- allocate(coorg(NDIM,npgeo))
+ if(ipass == 1) allocate(coorg(NDIM,npgeo))
ipoin = 0
read(IIN,"(a80)") datlin
@@ -708,10 +807,14 @@
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,num_fluid_poro_edges,num_solid_poro_edges
+ read(IIN,"(a80)") datlin
+ read(IIN,*) nelemabs,nelem_acoustic_surface,num_fluid_solid_edges,num_fluid_poro_edges,&
+ num_solid_poro_edges,nnodes_tangential_curve
+
!
!---- allocate arrays
!
+if(ipass == 1) then
allocate(shape2D(ngnod,NGLLX,NGLLZ))
allocate(dershape2D(NDIM,ngnod,NGLLX,NGLLZ))
allocate(shape2D_display(ngnod,pointsdisp,pointsdisp))
@@ -731,15 +834,22 @@
allocate(tortuosity(numat))
allocate(permeability(3,numat))
allocate(poroelastcoef(4,3,numat))
+ allocate(Qp_attenuation(numat))
+ allocate(Qs_attenuation(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))
- allocate(phi_nu2(N_SLS))
+ allocate(inv_tau_sigma_nu1(NGLLX,NGLLZ,nspec,N_SLS))
+ allocate(inv_tau_sigma_nu2(NGLLX,NGLLZ,nspec,N_SLS))
+ allocate(phi_nu1(NGLLX,NGLLZ,nspec,N_SLS))
+ allocate(phi_nu2(NGLLX,NGLLZ,nspec,N_SLS))
+ allocate(inv_tau_sigma_nu1_sent(N_SLS))
+ allocate(inv_tau_sigma_nu2_sent(N_SLS))
+ allocate(phi_nu1_sent(N_SLS))
+ allocate(phi_nu2_sent(N_SLS))
+endif
! --- allocate arrays for absorbing boundary conditions
if(nelemabs <= 0) then
@@ -748,6 +858,7 @@
else
anyabs = .true.
endif
+if(ipass == 1) then
allocate(numabs(nelemabs))
allocate(codeabs(4,nelemabs))
@@ -770,12 +881,15 @@
allocate(jend_left_poro(nelemabs))
allocate(jbegin_right_poro(nelemabs))
allocate(jend_right_poro(nelemabs))
+endif
!
!---- print element group main parameters
!
- write(IOUT,107)
- write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,107)
+ write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
+ endif
! set up Gauss-Lobatto-Legendre derivation matrices
call define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
@@ -783,24 +897,38 @@
!
!---- read the material properties
!
- call gmat01(density,porosity,tortuosity,permeability,poroelastcoef,numat)
+ call gmat01(density,porosity,tortuosity,permeability,poroelastcoef,numat,&
+ myrank,ipass,Qp_attenuation,Qs_attenuation)
+
!
!---- read spectral macrobloc data
!
n = 0
read(IIN,"(a80)") datlin
+ allocate(knods_read(ngnod))
do ispec = 1,nspec
- read(IIN,*) n,kmato(n),(knods(k,n), k=1,ngnod)
+ read(IIN,*) n,kmato_read,(knods_read(k), k=1,ngnod)
+if(ipass == 1) then
+ kmato(n) = kmato_read
+ knods(:,n)= knods_read(:)
+else if(ipass == 2) then
+ kmato(perm(antecedent_list(n))) = kmato_read
+ knods(:,perm(antecedent_list(n)))= knods_read(:)
+else
+ stop 'error: maximum is 2 passes'
+endif
enddo
+ deallocate(knods_read)
!-------------------------------------------------------------------------------
!---- determine if each spectral element is elastic, poroelastic, or acoustic
!-------------------------------------------------------------------------------
- any_acoustic = .false.
- any_elastic = .false.
- any_poroelastic = .false.
+ any_acoustic = .false.
+ any_elastic = .false.
+ any_poroelastic = .false.
do ispec = 1,nspec
- if(porosity(kmato(ispec)) >= 1.d0) then ! acoustic domain
+
+ if(porosity(kmato(ispec)) == 1.d0) then ! acoustic domain
elastic(ispec) = .false.
poroelastic(ispec) = .false.
any_acoustic = .true.
@@ -813,8 +941,9 @@
poroelastic(ispec) = .true.
any_poroelastic = .true.
endif
- enddo
+ enddo !do ispec = 1,nspec
+
if(TURN_ATTENUATION_ON) then
nspec_allocate = nspec
else
@@ -822,6 +951,7 @@
endif
! allocate memory variables for attenuation
+if(ipass == 1) then
allocate(e1(NGLLX,NGLLZ,nspec_allocate,N_SLS))
allocate(e11(NGLLX,NGLLZ,nspec_allocate,N_SLS))
allocate(e13(NGLLX,NGLLZ,nspec_allocate,N_SLS))
@@ -837,12 +967,30 @@
allocate(duz_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
allocate(duz_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
allocate(dux_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(Mu_nu1(NGLLX,NGLLZ,nspec))
+ allocate(Mu_nu2(NGLLX,NGLLZ,nspec))
+endif
-! define the attenuation constants
- call attenuation_model(N_SLS,Qp_attenuation,Qs_attenuation,f0_attenuation, &
- inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2)
+! define the attenuation quality factors.
+! they can be different for each element.
+!! DK DK if needed in the future, here the quality factor could be different for each point
+ do ispec = 1,nspec
+ call attenuation_model(N_SLS,Qp_attenuation(kmato(ispec)),Qs_attenuation(kmato(ispec)), &
+ f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent,inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent)
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ inv_tau_sigma_nu1(i,j,ispec,:) = inv_tau_sigma_nu1_sent(:)
+ phi_nu1(i,j,ispec,:) = phi_nu1_sent(:)
+ inv_tau_sigma_nu2(i,j,ispec,:) = inv_tau_sigma_nu2_sent(:)
+ phi_nu2(i,j,ispec,:) = phi_nu2_sent(:)
+ Mu_nu1(i,j,ispec) = Mu_nu1_sent
+ Mu_nu2(i,j,ispec) = Mu_nu2_sent
+ enddo
+ enddo
+ enddo
! allocate memory variables for viscous attenuation (poroelastic media)
+ if(ipass == 1) then
if(TURN_VISCATTENUATION_ON) then
allocate(rx_viscous(NGLLX,NGLLZ,nspec))
allocate(rz_viscous(NGLLX,NGLLZ,nspec))
@@ -854,21 +1002,16 @@
allocate(viscox(NGLLX,NGLLZ,1))
allocate(viscoz(NGLLX,NGLLZ,1))
endif
+ endif
!
!---- read interfaces data
!
- print *, 'read the interfaces', myrank
+
read(IIN,"(a80)") datlin
read(IIN,*) ninterface, max_interface_size
- 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
+ if ( ninterface > 0 ) then
+if(ipass == 1) then
allocate(my_neighbours(ninterface))
allocate(my_nelmnts_neighbours(ninterface))
allocate(my_interfaces(4,max_interface_size,ninterface))
@@ -881,76 +1024,89 @@
allocate(inum_interfaces_acoustic(ninterface))
allocate(inum_interfaces_elastic(ninterface))
allocate(inum_interfaces_poroelastic(ninterface))
+endif
do num_interface = 1, ninterface
read(IIN,*) my_neighbours(num_interface), my_nelmnts_neighbours(num_interface)
do ie = 1, my_nelmnts_neighbours(num_interface)
- read(IIN,*) my_interfaces(1,ie,num_interface), my_interfaces(2,ie,num_interface), &
+ read(IIN,*) my_interfaces_read, my_interfaces(2,ie,num_interface), &
my_interfaces(3,ie,num_interface), my_interfaces(4,ie,num_interface)
- end do
- end do
- print *, 'end read the interfaces', myrank
+ if(ipass == 1) then
+ my_interfaces(1,ie,num_interface) = my_interfaces_read
+ else if(ipass == 2) then
+ my_interfaces(1,ie,num_interface) = perm(antecedent_list(my_interfaces_read))
+ else
+ stop 'error: maximum number of passes is 2'
+ endif
- end if
+ enddo
+ enddo
+ endif
-
!
!---- read absorbing boundary data
!
read(IIN,"(a80)") datlin
if(anyabs) then
do inum = 1,nelemabs
-!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)
+ 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)
if(numabsread < 1 .or. numabsread > nspec) call exit_MPI('Wrong absorbing element number')
- numabs(inum) = numabsread
+ if(ipass == 1) then
+ numabs(inum) = numabsread
+ else if(ipass == 2) then
+ numabs(inum) = perm(antecedent_list(numabsread))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
codeabs(IBOTTOM,inum) = codeabsread(1)
codeabs(IRIGHT,inum) = codeabsread(2)
codeabs(ITOP,inum) = codeabsread(3)
codeabs(ILEFT,inum) = codeabsread(4)
enddo
- write(IOUT,*)
- write(IOUT,*) 'Number of absorbing elements: ',nelemabs
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Number of absorbing elements: ',nelemabs
+ endif
nspec_xmin = ZERO
nspec_xmax = ZERO
nspec_zmin = ZERO
nspec_zmax = ZERO
+ if(ipass == 1) then
allocate(ib_xmin(nelemabs))
allocate(ib_xmax(nelemabs))
allocate(ib_zmin(nelemabs))
allocate(ib_zmax(nelemabs))
+ endif
do inum = 1,nelemabs
if (codeabs(IBOTTOM,inum)) then
nspec_zmin = nspec_zmin + 1
- ib_zmin(nspec_zmin) = numabs(inum)
+ ib_zmin(inum) = nspec_zmin
endif
if (codeabs(IRIGHT,inum)) then
nspec_xmax = nspec_xmax + 1
- ib_xmax(nspec_xmax) = numabs(inum)
+ ib_xmax(inum) = nspec_xmax
endif
if (codeabs(ITOP,inum)) then
nspec_zmax = nspec_zmax + 1
- ib_zmax(nspec_zmax) = numabs(inum)
+ ib_zmax(inum) = nspec_zmax
endif
if (codeabs(ILEFT,inum)) then
nspec_xmin = nspec_xmin + 1
- ib_xmin(nspec_xmin) = numabs(inum)
+ ib_xmin(inum) = nspec_xmin
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
+ if(ipass == 1) then
+ 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
+ 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))
@@ -960,12 +1116,13 @@
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
+ 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
+ endif
write(IOUT,*)
write(IOUT,*) 'nspec_xmin = ',nspec_xmin
@@ -974,25 +1131,36 @@
write(IOUT,*) 'nspec_zmax = ',nspec_zmax
endif
-
!
!---- read acoustic free surface data
!
read(IIN,"(a80)") datlin
if(nelem_acoustic_surface > 0) then
- allocate(acoustic_edges(4,nelem_acoustic_surface))
+ if(ipass == 1) allocate(acoustic_edges(4,nelem_acoustic_surface))
do inum = 1,nelem_acoustic_surface
- read(IIN,*) acoustic_edges(1,inum), acoustic_edges(2,inum), acoustic_edges(3,inum), &
+ read(IIN,*) acoustic_edges_read, acoustic_edges(2,inum), acoustic_edges(3,inum), &
acoustic_edges(4,inum)
- end do
- allocate(acoustic_surface(5,nelem_acoustic_surface))
+ if(ipass == 1) then
+ acoustic_edges(1,inum) = acoustic_edges_read
+ else if(ipass == 2) then
+ acoustic_edges(1,inum) = perm(antecedent_list(acoustic_edges_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+
+ enddo
+ if(ipass == 1) allocate(acoustic_surface(5,nelem_acoustic_surface))
call construct_acoustic_surface ( nspec, ngnod, knods, nelem_acoustic_surface, &
acoustic_edges, acoustic_surface)
- write(IOUT,*)
- write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
+ endif
else
- allocate(acoustic_edges(4,1))
- allocate(acoustic_surface(5,1))
+ if(ipass == 1) then
+ allocate(acoustic_edges(4,1))
+ allocate(acoustic_surface(5,1))
+ endif
endif
!
@@ -1000,60 +1168,119 @@
!
read(IIN,"(a80)") datlin
if ( num_fluid_solid_edges > 0 ) then
+if(ipass == 1) then
allocate(fluid_solid_acoustic_ispec(num_fluid_solid_edges))
allocate(fluid_solid_acoustic_iedge(num_fluid_solid_edges))
allocate(fluid_solid_elastic_ispec(num_fluid_solid_edges))
allocate(fluid_solid_elastic_iedge(num_fluid_solid_edges))
+endif
do inum = 1, num_fluid_solid_edges
- read(IIN,*) fluid_solid_acoustic_ispec(inum), fluid_solid_elastic_ispec(inum)
- end do
+ read(IIN,*) fluid_solid_acoustic_ispec_read,fluid_solid_elastic_ispec_read
+ if(ipass == 1) then
+ fluid_solid_acoustic_ispec(inum) = fluid_solid_acoustic_ispec_read
+ fluid_solid_elastic_ispec(inum) = fluid_solid_elastic_ispec_read
+ else if(ipass == 2) then
+ fluid_solid_acoustic_ispec(inum) = perm(antecedent_list(fluid_solid_acoustic_ispec_read))
+ fluid_solid_elastic_ispec(inum) = perm(antecedent_list(fluid_solid_elastic_ispec_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+ enddo
else
+if(ipass == 1) then
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
+ endif
- end if
-
!
!---- read acoustic poroelastic coupled edges
!
read(IIN,"(a80)") datlin
if ( num_fluid_poro_edges > 0 ) then
+if(ipass == 1) 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))
+endif
do inum = 1, num_fluid_poro_edges
- read(IIN,*) fluid_poro_acoustic_ispec(inum), fluid_poro_poroelastic_ispec(inum)
- end do
+ read(IIN,*) fluid_poro_acoustic_ispec_read,fluid_poro_poroelastic_ispec_read
+ if(ipass == 1) then
+ fluid_poro_acoustic_ispec(inum) = fluid_poro_acoustic_ispec_read
+ fluid_poro_poroelastic_ispec(inum) = fluid_poro_poroelastic_ispec_read
+ else if(ipass == 2) then
+ fluid_poro_acoustic_ispec(inum) = perm(antecedent_list(fluid_poro_acoustic_ispec_read))
+ fluid_poro_poroelastic_ispec(inum) = perm(antecedent_list(fluid_poro_poroelastic_ispec_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+ enddo
else
+if(ipass == 1) then
allocate(fluid_poro_acoustic_ispec(1))
allocate(fluid_poro_acoustic_iedge(1))
allocate(fluid_poro_poroelastic_ispec(1))
allocate(fluid_poro_poroelastic_iedge(1))
+endif
+ endif
- end if
-
!
!---- read poroelastic elastic coupled edges
!
read(IIN,"(a80)") datlin
if ( num_solid_poro_edges > 0 ) then
+if(ipass == 1) 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))
+endif
do inum = 1, num_solid_poro_edges
- read(IIN,*) solid_poro_poroelastic_ispec(inum), solid_poro_elastic_ispec(inum)
- end do
+ read(IIN,*) solid_poro_poroelastic_ispec_read,solid_poro_elastic_ispec_read
+ if(ipass == 1) then
+ solid_poro_elastic_ispec(inum) = solid_poro_elastic_ispec_read
+ solid_poro_poroelastic_ispec(inum) = solid_poro_poroelastic_ispec_read
+ else if(ipass == 2) then
+ solid_poro_elastic_ispec(inum) = perm(antecedent_list(solid_poro_elastic_ispec_read))
+ solid_poro_poroelastic_ispec(inum) = perm(antecedent_list(solid_poro_poroelastic_ispec_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+ enddo
else
+if(ipass == 1) then
allocate(solid_poro_elastic_ispec(1))
allocate(solid_poro_elastic_iedge(1))
allocate(solid_poro_poroelastic_ispec(1))
allocate(solid_poro_poroelastic_iedge(1))
+endif
+ endif
- end if
+!
+!---- read tangential detection curve
+!
+ read(IIN,"(a80)") datlin
+ read(IIN,*) force_normal_to_surface,rec_normal_to_surface
+ if (nnodes_tangential_curve > 0) then
+if (ipass == 1) then
+ allocate(nodes_tangential_curve(2,nnodes_tangential_curve))
+ allocate(dist_tangential_detection_curve(nnodes_tangential_curve))
+endif
+ do i = 1, nnodes_tangential_curve
+ read(IIN,*) nodes_tangential_curve(1,i),nodes_tangential_curve(2,i)
+ enddo
+ else
+ force_normal_to_surface = .false.
+ rec_normal_to_surface = .false.
+ nnodes_tangential_curve = 0
+if (ipass == 1) then
+ allocate(nodes_tangential_curve(2,1))
+ allocate(dist_tangential_detection_curve(1))
+endif
+ endif
!
!---- close input file
@@ -1075,20 +1302,29 @@
! "slow and clean" or "quick and dirty" version
if(FAST_NUMBERING) then
- call createnum_fast(knods,ibool,shape2D,coorg,npoin,npgeo,nspec,ngnod)
+ call createnum_fast(knods,ibool,shape2D,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
else
- call createnum_slow(knods,ibool,npoin,nspec,ngnod)
+ call createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
endif
-! create a new indirect addressing array instead, to reduce cache misses
-! in memory access in the solver
+! create a new indirect addressing array to reduce cache misses in memory access in the solver
+ if(ipass == 2) then
+
+ deallocate(perm)
+
allocate(copy_ibool_ori(NGLLX,NGLLZ,nspec))
allocate(mask_ibool(npoin))
+
mask_ibool(:) = -1
copy_ibool_ori(:,:,:) = ibool(:,:,:)
inumber = 0
- do ispec=1,nspec
+
+ if(.not. ACTUALLY_IMPLEMENT_PERM_WHOLE) then
+
+! first reduce cache misses in outer elements, since they are taken first
+! loop over spectral elements
+ do ispec = 1,nspec_outer
do j=1,NGLLZ
do i=1,NGLLX
if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
@@ -1103,9 +1339,54 @@
enddo
enddo
enddo
+
+! then reduce cache misses in inner elements, since they are taken second
+! loop over spectral elements
+ do ispec = nspec_outer+1,nspec
+ 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
+
+ else ! if ACTUALLY_IMPLEMENT_PERM_WHOLE
+
+! reduce cache misses in all the elements
+! loop over spectral elements
+ do ispec = 1,nspec
+ 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
+
+ endif
+
deallocate(copy_ibool_ori)
deallocate(mask_ibool)
+ else if(ipass /= 1) then
+ 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
@@ -1133,7 +1414,7 @@
enddo
close(IIN)
- if (myrank == 0) then
+ if (myrank == 0 .and. ipass == 1) then
write(IOUT,*)
write(IOUT,*) 'Total number of receivers = ',nrec
write(IOUT,*)
@@ -1142,6 +1423,8 @@
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))
@@ -1151,6 +1434,8 @@
allocate(network_name(nrec))
allocate(recloc(nrec))
allocate(which_proc_receiver(nrec))
+ allocate(x_final_receiver(nrec))
+ allocate(z_final_receiver(nrec))
! allocate 1-D Lagrange interpolators and derivatives
allocate(hxir(NGLLX))
@@ -1178,6 +1463,8 @@
allocate(rhoext(1,1,1))
endif
+ endif
+
!
!---- set the coordinates of the points of the global grid
!
@@ -1206,35 +1493,37 @@
!
!--- 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')
- write(55,*) npoin
- do n = 1,npoin
- write(55,*) (coord(i,n), i=1,NDIM)
- enddo
- close(55)
+ if(outputgrid .and. myrank == 0 .and. ipass == 1) 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)
endif
!
!----- plot the GLL mesh in a Gnuplot file
!
- if(gnuplot) call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
+ if(gnuplot .and. myrank == 0 .and. ipass == 1) call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
!
!---- assign external velocity and density model if needed
!
if(assign_external_model) then
- write(IOUT,*)
- write(IOUT,*) 'Assigning external velocity and density model (elastic and/or acoustic)...'
- write(IOUT,*)
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Assigning external velocity and density model...'
+ write(IOUT,*)
+ endif
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
@@ -1252,8 +1541,8 @@
poroelastic(ispec) = .false.
any_acoustic = .true.
else
+ elastic(ispec) = .true.
poroelastic(ispec) = .false.
- elastic(ispec) = .true.
any_elastic = .true.
endif
previous_vsext = vsext(i,j,ispec)
@@ -1265,37 +1554,39 @@
!
!---- 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_poroelastic_glob = any_poroelastic
+
+ 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
+
+ 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
! for acoustic
if(TURN_ANISOTROPY_ON .and. .not. any_elastic_glob) &
- call exit_MPI('cannot have anisotropy if acoustic simulation only')
+ call exit_MPI('cannot have anisotropy if acoustic/poroelastic simulation only')
if(TURN_ATTENUATION_ON .and. .not. any_elastic_glob) &
- call exit_MPI('currently cannot have attenuation if acoustic simulation only')
+ call exit_MPI('currently cannot have attenuation if acoustic/poroelastic simulation only')
! for attenuation
- if(TURN_ANISOTROPY_ON .and. TURN_ATTENUATION_ON) then
+ if(TURN_ANISOTROPY_ON .and. TURN_ATTENUATION_ON) &
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
+ if(isolver == 2) then
! define coefficients of the Newmark time scheme for the backward wavefield
b_deltat = - deltat
b_deltatover2 = HALF*b_deltat
@@ -1303,15 +1594,26 @@
endif
!---- define actual location of source and receivers
-do i_source=1,NSOURCE !yang
+ do i_source=1,NSOURCE
+
if(source_type(i_source) == 1) then
+
! collocated force source
- call locate_source_force(coord,ibool,npoin,nspec,x_source(i_source),z_source(i_source),source_type(i_source), &
- ix_source(i_source),iz_source(i_source),ispec_selected_source(i_source),iglob_source(i_source),&
- is_proc_source(i_source),nb_proc_source(i_source))
+ call locate_source_force(coord,ibool,npoin,nspec,x_source(i_source),z_source(i_source), &
+ ix_source(i_source),iz_source(i_source),ispec_selected_source(i_source),iglob_source(i_source), &
+ is_proc_source(i_source),nb_proc_source(i_source),ipass)
+! get density at the source in order to implement collocated force with the right
+! amplitude later
+ if(is_proc_source(i_source) == 1) then
+ rho_at_source_location = density(1,kmato(ispec_selected_source(i_source)))
+! external velocity model
+ if(assign_external_model) rho_at_source_location = &
+ rhoext(ix_source(i_source),iz_source(i_source),ispec_selected_source(i_source))
+ endif
+
! check that acoustic source is not exactly on the free surface because pressure is zero there
- if ( is_proc_source(i_source) == 1 ) then
+ if(is_proc_source(i_source) == 1) then
do ispec_acoustic_surface = 1,nelem_acoustic_surface
ispec = acoustic_surface(1,ispec_acoustic_surface)
if( .not. elastic(ispec) .and. .not. poroelastic(ispec) .and. ispec == ispec_selected_source(i_source) ) then
@@ -1320,36 +1622,39 @@
iglob = ibool(i,j,ispec)
if ( iglob_source(i_source) == iglob ) then
call exit_MPI('an acoustic source cannot be located exactly on the free surface because pressure is zero there')
- end if
- end do
- end do
+ endif
+ enddo
+ enddo
endif
enddo
- end if
+ endif
- else if(source_type(i_source)== 2) then
+ else if(source_type(i_source) == 2) then
! moment-tensor source
call locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source(i_source),z_source(i_source), &
- ispec_selected_source(i_source),is_proc_source(i_source),nb_proc_source(i_source),nproc,myrank,xi_source(i_source),&
- gamma_source(i_source),coorg,knods,ngnod,npgeo)
+ ispec_selected_source(i_source),is_proc_source(i_source),nb_proc_source(i_source),&
+ nproc,myrank,xi_source(i_source),gamma_source(i_source),coorg,knods,ngnod,npgeo,ipass)
! compute source array for moment-tensor source
call compute_arrays_source(ispec_selected_source(i_source),xi_source(i_source),gamma_source(i_source),&
- sourcearray(i_source,:,:,:), &
- Mxx(i_source),Mzz(i_source),Mxz(i_source),xix,xiz,gammax,gammaz,xigll,zigll,nspec)
+ sourcearray(i_source,:,:,:), &
+ Mxx(i_source),Mzz(i_source),Mxz(i_source),xix,xiz,gammax,gammaz,xigll,zigll,nspec)
- else
+ else if(.not.initialfield) then
call exit_MPI('incorrect source type')
endif
-enddo
+
! 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)
+ xi_receiver,gamma_receiver,station_name,network_name,x_source(i_source),z_source(i_source),coorg,knods,ngnod,npgeo,ipass, &
+ x_final_receiver, z_final_receiver)
+ enddo ! do i_source=1,NSOURCE
+
! compute source array for adjoint source
- if(isolver == 2) then ! adjoint calculation
+ if(isolver == 2 .and. ipass == 1) then ! adjoint calculation
nadj_rec_local = 0
do irec = 1,nrec
if(myrank == which_proc_receiver(irec))then
@@ -1375,9 +1680,215 @@
enddo
endif
+
+if (ipass == 1) then
+ if (nrecloc > 0) then
+ allocate(anglerec_irec(nrecloc))
+ allocate(cosrot_irec(nrecloc))
+ allocate(sinrot_irec(nrecloc))
+ allocate(rec_tangential_detection_curve(nrecloc))
+ else
+ allocate(anglerec_irec(1))
+ allocate(cosrot_irec(1))
+ allocate(sinrot_irec(1))
+ allocate(rec_tangential_detection_curve(1))
+ endif
+ anglerec_irec(:) = anglerec * pi / 180.d0
+ cosrot_irec(:) = cos(anglerec)
+ sinrot_irec(:) = sin(anglerec)
+endif
+
+!
+!--- tangential computation
+!
+if (ipass == NUMBER_OF_PASSES) then
+
+! for receivers
+ if (rec_normal_to_surface) then
+ irecloc = 0
+ do irec = 1, nrec
+ if (which_proc_receiver(irec) == myrank) then
+ irecloc = irecloc + 1
+ distmin = HUGEVAL
+ do i = 1, nnodes_tangential_curve
+ dist_current = sqrt((x_final_receiver(irec)-nodes_tangential_curve(1,i))**2 + &
+ (z_final_receiver(irec)-nodes_tangential_curve(2,i))**2)
+ if ( dist_current < distmin ) then
+ n1_tangential_detection_curve = i
+ distmin = dist_current
+ endif
+ enddo
+
+ rec_tangential_detection_curve(irecloc) = n1_tangential_detection_curve
+ call tri_quad(n_tangential_detection_curve, n1_tangential_detection_curve, nnodes_tangential_curve)
+
+ call calcul_normale( anglerec_irec(irecloc), nodes_tangential_curve(1,n_tangential_detection_curve(1)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(2)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(3)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(4)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(1)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(2)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(3)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(4)) )
+ endif
+
+ enddo
+ cosrot_irec(:) = cos(anglerec_irec(:))
+ sinrot_irec(:) = sin(anglerec_irec(:))
+ endif
+! for the source
+ if (force_normal_to_surface) then
+
+ do i_source=1,NSOURCE
+ if (is_proc_source(i_source) == 1) then
+ distmin = HUGEVAL
+ do i = 1, nnodes_tangential_curve
+ dist_current = sqrt((coord(1,iglob_source(i_source))-nodes_tangential_curve(1,i))**2 + &
+ (coord(2,iglob_source(i_source))-nodes_tangential_curve(2,i))**2)
+ if ( dist_current < distmin ) then
+ n1_tangential_detection_curve = i
+ distmin = dist_current
+
+ endif
+ enddo
+
+ call tri_quad(n_tangential_detection_curve, n1_tangential_detection_curve, nnodes_tangential_curve)
+
+ call calcul_normale( angleforce(i_source), nodes_tangential_curve(1,n_tangential_detection_curve(1)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(2)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(3)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(4)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(1)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(2)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(3)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(4)) )
+
+ source_courbe_eros(i_source) = n1_tangential_detection_curve
+ if ( myrank == 0 .and. is_proc_source(i_source) == 1 .and. nb_proc_source(i_source) == 1 ) then
+ source_courbe_eros(i_source) = n1_tangential_detection_curve
+ angleforce_recv = angleforce(i_source)
+#ifdef USE_MPI
+ else if ( myrank == 0 ) then
+ do i = 1, nb_proc_source(i_source) - is_proc_source(i_source)
+ call MPI_recv(source_courbe_eros(i_source),1,MPI_INTEGER,MPI_ANY_SOURCE,42,MPI_COMM_WORLD,request_mpi_status,ier)
+ call MPI_recv(angleforce_recv,1,MPI_DOUBLE_PRECISION,MPI_ANY_SOURCE,43,MPI_COMM_WORLD,request_mpi_status,ier)
+ enddo
+ else if ( is_proc_source(i_source) == 1 ) then
+ call MPI_send(n1_tangential_detection_curve,1,MPI_INTEGER,0,42,MPI_COMM_WORLD,ier)
+ call MPI_send(angleforce(i_source),1,MPI_DOUBLE_PRECISION,0,43,MPI_COMM_WORLD,ier)
+#endif
+ endif
+
+#ifdef USE_MPI
+ call MPI_bcast(angleforce_recv,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ angleforce(i_source) = angleforce_recv
+#endif
+ endif ! if (is_proc_source(i_source) == 1)
+ enddo ! do i_source=1,NSOURCE
+ endif ! if (force_normal_to_surface)
+
+! CHRIS --- how to deal with multiple source. Use first source now. ---
+! compute distance from source to receivers following the curve
+ if (force_normal_to_surface .and. rec_normal_to_surface) then
+ dist_tangential_detection_curve(source_courbe_eros(1)) = 0
+ do i = source_courbe_eros(1)+1, nnodes_tangential_curve
+ dist_tangential_detection_curve(i) = dist_tangential_detection_curve(i-1) + &
+ sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i-1))**2 + &
+ (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i-1))**2)
+ enddo
+ dist_tangential_detection_curve(1) = dist_tangential_detection_curve(nnodes_tangential_curve) + &
+ sqrt((nodes_tangential_curve(1,1)-nodes_tangential_curve(1,nnodes_tangential_curve))**2 + &
+ (nodes_tangential_curve(2,1)-nodes_tangential_curve(2,nnodes_tangential_curve))**2)
+ do i = 2, source_courbe_eros(1)-1
+ dist_tangential_detection_curve(i) = dist_tangential_detection_curve(i-1) + &
+ sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i-1))**2 + &
+ (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i-1))**2)
+ enddo
+ do i = source_courbe_eros(1)-1, 1, -1
+ dist_current = dist_tangential_detection_curve(i+1) + &
+ sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i+1))**2 + &
+ (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i+1))**2)
+ if ( dist_current < dist_tangential_detection_curve(i) ) then
+ dist_tangential_detection_curve(i) = dist_current
+ endif
+ enddo
+ dist_current = dist_tangential_detection_curve(1) + &
+ sqrt((nodes_tangential_curve(1,1)-nodes_tangential_curve(1,nnodes_tangential_curve))**2 + &
+ (nodes_tangential_curve(2,1)-nodes_tangential_curve(2,nnodes_tangential_curve))**2)
+ if ( dist_current < dist_tangential_detection_curve(nnodes_tangential_curve) ) then
+ dist_tangential_detection_curve(nnodes_tangential_curve) = dist_current
+ endif
+ do i = nnodes_tangential_curve-1, source_courbe_eros(1)+1, -1
+ dist_current = dist_tangential_detection_curve(i+1) + &
+ sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i+1))**2 + &
+ (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i+1))**2)
+ if ( dist_current < dist_tangential_detection_curve(i) ) then
+ dist_tangential_detection_curve(i) = dist_current
+ endif
+ enddo
+
+ if ( myrank == 0 ) then
+ open(unit=11,file='OUTPUT_FILES/dist_rec_tangential_detection_curve', form='formatted', status='unknown')
+ endif
+ irecloc = 0
+ do irec = 1,nrec
+
+ if ( myrank == 0 ) then
+ if ( which_proc_receiver(irec) == myrank ) then
+ irecloc = irecloc + 1
+ n1_tangential_detection_curve = rec_tangential_detection_curve(irecloc)
+ x_final_receiver_dummy = x_final_receiver(irec)
+ z_final_receiver_dummy = z_final_receiver(irec)
+#ifdef USE_MPI
+ else
+
+ call MPI_RECV(n1_tangential_detection_curve,1,MPI_INTEGER,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,request_mpi_status,ier)
+ call MPI_RECV(x_final_receiver_dummy,1,MPI_DOUBLE_PRECISION,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,request_mpi_status,ier)
+ call MPI_RECV(z_final_receiver_dummy,1,MPI_DOUBLE_PRECISION,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,request_mpi_status,ier)
+
+#endif
+ endif
+
+#ifdef USE_MPI
+ else
+ if ( which_proc_receiver(irec) == myrank ) then
+ irecloc = irecloc + 1
+ call MPI_SEND(rec_tangential_detection_curve(irecloc),1,MPI_INTEGER,0,irec,MPI_COMM_WORLD,ier)
+ call MPI_SEND(x_final_receiver(irec),1,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ier)
+ call MPI_SEND(z_final_receiver(irec),1,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ier)
+ endif
+#endif
+
+ endif
+ if ( myrank == 0 ) then
+ write(11,*) dist_tangential_detection_curve(n1_tangential_detection_curve)
+ write(12,*) x_final_receiver_dummy
+ write(13,*) z_final_receiver_dummy
+ endif
+ enddo
+
+ if ( myrank == 0 ) then
+ close(11)
+ close(12)
+ close(13)
+ endif
+
+ endif
+endif
+
+!
+!---
+!
+
! allocate seismogram arrays
- allocate(sisux(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
- allocate(sisuz(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
+ 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))
+ endif
! check if acoustic receiver is exactly on the free surface because pressure is zero there
do ispec_acoustic_surface = 1,nelem_acoustic_surface
@@ -1428,6 +1939,8 @@
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))
@@ -1484,10 +1997,6 @@
allocate(velocw_poroelastic(NDIM,npoin))
allocate(accelw_poroelastic(NDIM,npoin))
allocate(rmass_w_inverse_poroelastic(npoin))
- allocate(displs_poroelastic_smooth(NDIM,npoin))
- allocate(velocs_poroelastic_smooth(NDIM,npoin))
- allocate(displw_poroelastic_smooth(NDIM,npoin))
- allocate(velocw_poroelastic_smooth(NDIM,npoin))
else
! allocate unused arrays with fictitious size
allocate(displs_poroelastic(1,1))
@@ -1644,21 +2153,31 @@
allocate(alpha_ac_kl(1))
endif
+ 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 external density model (elastic or acoustic)
+ if(assign_external_model) then
+ rhol = rhoext(i,j,ispec)
+ kappal = rhol * vpext(i,j,ispec)**2
+ else
+ rhol = density(1,kmato(ispec))
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ kappal = lambdal_relaxed + 2.d0*mul_relaxed
+ endif
+
if(poroelastic(ispec)) then ! material is poroelastic
rhol_s = density(1,kmato(ispec))
rhol_f = density(2,kmato(ispec))
@@ -1672,55 +2191,39 @@
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)
- else
- rhol = density(1,kmato(ispec))
- endif
+ elseif(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
- rhol = density(2,kmato(ispec))
- kappal = poroelastcoef(1,2,kmato(ispec))
- cpsquare = kappal / rhol
+ else ! for acoustic medium
+ rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / kappal
endif
- rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / cpsquare
- endif
+
enddo
enddo
- enddo
+ enddo ! do ispec = 1,nspec
#ifdef USE_MPI
if ( nproc > 1 ) then
! preparing for MPI communications
- allocate(mask_ispec_inner_outer(nspec))
+ if(ipass == 1) allocate(mask_ispec_inner_outer(nspec))
mask_ispec_inner_outer(:) = .false.
- call prepare_assemble_MPI (nspec,ibool, &
- knods, ngnod, &
- npoin, elastic,poroelastic, &
- ninterface, max_interface_size, &
- my_nelmnts_neighbours, my_interfaces, &
+ call prepare_assemble_MPI (nspec,ibool,knods,ngnod,npoin,elastic,poroelastic, &
+ ninterface, max_interface_size,my_nelmnts_neighbours, my_interfaces, &
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 &
- )
+ ninterface_acoustic, ninterface_elastic, ninterface_poroelastic,mask_ispec_inner_outer)
nspec_outer = count(mask_ispec_inner_outer)
nspec_inner = nspec - nspec_outer
- allocate(ispec_outer_to_glob(nspec_outer))
- allocate(ispec_inner_to_glob(nspec_inner))
+ if(ipass == 1) then
+ allocate(ispec_outer_to_glob(nspec_outer))
+ allocate(ispec_inner_to_glob(nspec_inner))
+ endif
! building of corresponding arrays between inner/outer elements and their global number
+if(ipass == 1) then
num_ispec_outer = 0
num_ispec_inner = 0
do ispec = 1, nspec
@@ -1730,68 +2233,34 @@
else
num_ispec_inner = num_ispec_inner + 1
ispec_inner_to_glob(num_ispec_inner) = ispec
-
endif
enddo
+endif
max_ibool_interfaces_size_ac = maxval(nibool_interfaces_acoustic(:))
max_ibool_interfaces_size_el = NDIM*maxval(nibool_interfaces_elastic(:))
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))
+ 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))
+ allocate(tab_requests_send_recv_poroelastic(ninterface_poroelastic*4))
+ 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))
+ endif
-
-! creating mpi non-blocking persistent communications for acoustic elements
- 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 &
- )
-
-! creating mpi non-blocking persistent communications for elastic elements
- 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 &
- )
-
-! creating mpi non-blocking persistent communications for poroelastic elements
- call create_MPI_req_SEND_RECV_po( &
- ninterface, ninterface_poroelastic, &
- nibool_interfaces_poroelastic, &
- my_neighbours, &
+! assembling the mass matrix
+ call assemble_MPI_scalar(rmass_inverse_acoustic,rmass_inverse_elastic,rmass_s_inverse_poroelastic, &
+ rmass_w_inverse_poroelastic,npoin, &
+ ninterface, max_interface_size, max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, &
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, 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)
+ nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic,my_neighbours)
else
ninterface_acoustic = 0
@@ -1800,34 +2269,192 @@
num_ispec_outer = 0
num_ispec_inner = 0
- allocate(mask_ispec_inner_outer(1))
+ if(ipass == 1) allocate(mask_ispec_inner_outer(1))
nspec_outer = 0
nspec_inner = nspec
- allocate(ispec_inner_to_glob(nspec_inner))
+ if(ipass == 1) allocate(ispec_inner_to_glob(nspec_inner))
do ispec = 1, nspec
ispec_inner_to_glob(ispec) = ispec
enddo
- end if ! end of test on wether there is more than one process ( nproc>1 )
+ endif ! end of test on wether there is more than one process (nproc > 1)
#else
num_ispec_outer = 0
num_ispec_inner = 0
- allocate(mask_ispec_inner_outer(1))
+ if(ipass == 1) allocate(mask_ispec_inner_outer(1))
nspec_outer = 0
nspec_inner = nspec
- allocate(ispec_outer_to_glob(1))
- allocate(ispec_inner_to_glob(nspec_inner))
+ if(ipass == 1) then
+ allocate(ispec_outer_to_glob(1))
+ allocate(ispec_inner_to_glob(nspec_inner))
+ endif
do ispec = 1, nspec
ispec_inner_to_glob(ispec) = ispec
enddo
#endif
+if(ipass == 1) then
+
+ allocate(antecedent_list(nspec))
+
+! 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)
+ antecedent_list(ispec) = ispec_outer
+ enddo
+
+! 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)
+ antecedent_list(ispec) = nspec_outer + ispec_inner
+ enddo
+
+ allocate(ibool_outer(NGLLX,NGLLZ,nspec_outer))
+ allocate(ibool_inner(NGLLX,NGLLZ,nspec_inner))
+
+! 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)
+ ibool_outer(:,:,ispec_outer) = ibool(:,:,ispec)
+ enddo
+
+! 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)
+ ibool_inner(:,:,ispec_inner) = ibool(:,:,ispec)
+ enddo
+
+ allocate(copy_ibool_ori(NGLLX,NGLLZ,nspec_outer))
+ allocate(mask_ibool(npoin))
+
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:) = ibool_outer(:,:,:)
+
+ inumber = 0
+
+ do ispec = 1,nspec_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_outer(i,j,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
+ else
+! use an existing point created previously
+ ibool_outer(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+
+ deallocate(copy_ibool_ori)
+ deallocate(mask_ibool)
+
+! the total number of points without multiples in this region is now known
+ npoin_outer = maxval(ibool_outer)
+
+ allocate(copy_ibool_ori(NGLLX,NGLLZ,nspec_inner))
+ allocate(mask_ibool(npoin))
+
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:) = ibool_inner(:,:,:)
+
+ inumber = 0
+
+ do ispec = 1,nspec_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_inner(i,j,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
+ else
+! use an existing point created previously
+ ibool_inner(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+
+ deallocate(copy_ibool_ori)
+ deallocate(mask_ibool)
+
+! the total number of points without multiples in this region is now known
+ npoin_inner = maxval(ibool_inner)
+
+ allocate(perm(nspec))
+
+! use identity permutation by default
+ do ispec = 1,nspec
+ perm(ispec) = ispec
+ enddo
+
+ if(ACTUALLY_IMPLEMENT_PERM_WHOLE) then
+
+ allocate(check_perm(nspec))
+ call get_perm(ibool,perm,LIMIT_MULTI_CUTHILL,nspec,npoin)
+! check that the permutation obtained is bijective
+ check_perm(:) = -1
+ do ispec = 1,nspec
+ check_perm(perm(ispec)) = ispec
+ enddo
+ if(minval(check_perm) /= 1) stop 'minval check_perm is incorrect for whole'
+ if(maxval(check_perm) /= nspec) stop 'maxval check_perm is incorrect for whole'
+ deallocate(check_perm)
+ else
+
+ if(ACTUALLY_IMPLEMENT_PERM_OUT) then
+ allocate(check_perm(nspec_outer))
+ call get_perm(ibool_outer,perm(1:nspec_outer),LIMIT_MULTI_CUTHILL,nspec_outer,npoin_outer)
+! check that the permutation obtained is bijective
+ check_perm(:) = -1
+ do ispec = 1,nspec_outer
+ check_perm(perm(ispec)) = ispec
+ enddo
+ if(minval(check_perm) /= 1) stop 'minval check_perm is incorrect for outer'
+ if(maxval(check_perm) /= nspec_outer) stop 'maxval check_perm is incorrect for outer'
+ deallocate(check_perm)
+ deallocate(ibool_outer)
+ endif
+
+ if(ACTUALLY_IMPLEMENT_PERM_INN) then
+ allocate(check_perm(nspec_inner))
+ call get_perm(ibool_inner,perm(nspec_outer+1:nspec),LIMIT_MULTI_CUTHILL,nspec_inner,npoin_inner)
+! check that the permutation obtained is bijective
+ check_perm(:) = -1
+ do ispec = 1,nspec_inner
+ check_perm(perm(nspec_outer+ispec)) = ispec
+ enddo
+ if(minval(check_perm) /= 1) stop 'minval check_perm is incorrect for inner'
+ if(maxval(check_perm) /= nspec_inner) stop 'maxval check_perm is incorrect for inner'
+ deallocate(check_perm)
+! add the right offset
+ perm(nspec_outer+1:nspec) = perm(nspec_outer+1:nspec) + nspec_outer
+ deallocate(ibool_inner)
+ endif
+
+ endif
+
+endif
+
+ enddo ! end of further reduction of cache misses inner/outer in two passes
+
+!---
+!--- end of section performed 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
@@ -1841,17 +2468,26 @@
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,poroelastcoef,porosity,tortuosity,ibool,kmato,&
+ if(DISPLAY_SUBSET_OPTION == 1) then
+ UPPER_LIMIT_DISPLAY = nspec
+ else if(DISPLAY_SUBSET_OPTION == 2) then
+ UPPER_LIMIT_DISPLAY = nspec_inner
+ else if(DISPLAY_SUBSET_OPTION == 3) then
+ UPPER_LIMIT_DISPLAY = nspec_outer
+ else if(DISPLAY_SUBSET_OPTION == 4) then
+ UPPER_LIMIT_DISPLAY = NSPEC_DISPLAY_SUBSET
+ else
+ stop 'incorrect value of DISPLAY_SUBSET_OPTION'
+ endif
+ 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,any_poroelastic,myrank,nproc)
+ assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat,f0,t0,initialfield, &
+ time_function_type,coorg,xinterp,zinterp,shape2D_display,knods,simulation_title, &
+ npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,myrank,nproc,NSOURCE,poroelastic)
! convert receiver angle to radians
anglerec = anglerec * pi / 180.d0
-
-
!
!---- for color images
!
@@ -1896,12 +2532,8 @@
NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
! check that image size is not too big
- 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
+ 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.')
! allocate an array for image data
allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color))
@@ -1912,9 +2544,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)
@@ -1930,7 +2562,7 @@
elmnt_coords(1,k) = coorg(1,knods(k,ispec))
elmnt_coords(2,k) = coorg(2,knods(k,ispec))
- end do
+ enddo
! avoid working on the whole pixel grid
min_i = floor(minval((elmnt_coords(1,:) - xmin_color_image))/size_pixel_horizontal) + 1
@@ -1957,21 +2589,21 @@
dist_min_pixel = dist_pixel
iglob_image_color(i,j) = iglob
- end if
+ endif
- end do
- end do
+ enddo
+ enddo
if ( dist_min_pixel >= HUGEVAL ) then
call exit_MPI('Error in detecting pixel for color image')
- end if
+ endif
nb_pixel_loc = nb_pixel_loc + 1
- end if
+ endif
- end do
- end do
- end do
+ enddo
+ enddo
+ enddo
! creating and filling array num_pixel_loc with the positions of each colored
! pixel owned by the local process (useful for parallel jobs)
@@ -1984,13 +2616,11 @@
nb_pixel_loc = nb_pixel_loc + 1
num_pixel_loc(nb_pixel_loc) = (j-1)*NX_IMAGE_color + i
- end if
+ endif
- end do
- end do
+ enddo
+ enddo
-
-
! filling array iglob_image_color, containing info on which process owns which pixels.
#ifdef USE_MPI
allocate(nb_pixel_per_proc(nproc))
@@ -2000,11 +2630,11 @@
if ( myrank == 0 ) then
allocate(num_pixel_recv(maxval(nb_pixel_per_proc(:)),nproc))
allocate(data_pixel_recv(maxval(nb_pixel_per_proc(:))))
- end if
+ endif
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
@@ -2015,15 +2645,15 @@
i = num_pixel_recv(k,iproc+1) - (j-1)*NX_IMAGE_color
iglob_image_color(i,j) = iproc
- end do
- end do
+ enddo
+ enddo
else
call MPI_SEND(num_pixel_loc(1),nb_pixel_loc,MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- end if
+ endif
- end if
+ endif
#else
allocate(nb_pixel_per_proc(1))
deallocate(nb_pixel_per_proc)
@@ -2035,9 +2665,7 @@
deallocate(data_pixel_send)
#endif
- if ( myrank == 0 ) then
- write(IOUT,*) 'done locating all the pixels of color images'
- endif
+ if (myrank == 0) write(IOUT,*) 'done locating all the pixels of color images'
endif
@@ -2051,61 +2679,22 @@
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
!
-!----- Files where viscous damping are saved during forward wavefield calculation
-!
- if(any_poroelastic .and. (save_forward .or. isolver .eq. 2)) then
- allocate(b_viscodampx(npoin))
- allocate(b_viscodampz(npoin))
- if(isolver == 2) then
- reclen = CUSTOM_REAL * npoin
- open(unit=23,file='OUTPUT_FILES/viscodampingx.bin',status='old',&
- action='read',form='unformatted',access='direct',&
- recl=reclen)
- open(unit=24,file='OUTPUT_FILES/viscodampingz.bin',status='old',&
- action='read',form='unformatted',access='direct',&
- recl=reclen)
- else
- reclen = CUSTOM_REAL * npoin
- open(unit=23,file='OUTPUT_FILES/viscodampingx.bin',status='unknown',&
- form='unformatted',access='direct',&
- recl=reclen)
- open(unit=24,file='OUTPUT_FILES/viscodampingz.bin',status='unknown',&
- form='unformatted',access='direct',&
- recl=reclen)
- endif
- endif
-! if(any_poroelastic .and. isolver .eq. 2) then
-! do it =1, NSTEP
-! do id =1,npoin
-! read(55) b_viscodampx(id,it)
-! read(56) b_viscodampz(id,it)
-! enddo
-! enddo
-! endif
-
-!
!----- Files where absorbing signal are saved during forward wavefield calculation
!
@@ -2158,9 +2747,9 @@
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
@@ -2226,11 +2815,11 @@
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
@@ -2282,11 +2871,11 @@
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 )
@@ -2341,7 +2930,7 @@
endif
- enddo
+ enddo
endif ! if(any_elastic)
@@ -2398,7 +2987,7 @@
endif
- enddo
+ enddo
endif ! if(any_poroelastic)
@@ -2443,7 +3032,7 @@
endif
- enddo
+ enddo
endif ! if(any_acoustic)
@@ -2456,7 +3045,7 @@
!----- Read last frame for backward wavefield calculation
!
- if(isolver == 2) then
+ if(isolver == 2) then
if(any_elastic) then
open(unit=55,file='OUTPUT_FILES/lastframe_elastic.bin',status='old',action='read',form='unformatted')
@@ -2537,85 +3126,53 @@
!
!---- 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
+! if we are looking a plane wave beyond critical angle we use other method
+ over_critical_angle = .false.
- 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)
+ if(initialfield) then
+ if (myrank == 0) then
+ write(IOUT,*)
+!! DK DK reading of an initial field from an external file has been suppressed
+!! DK DK and replaced with the implementation of an analytical plane wave
+!! DK DK write(IOUT,*) 'Reading initial fields from external file...'
+ write(IOUT,*) 'Implementing an analytical initial plane wave...'
+ write(IOUT,*)
+ endif
+ if(any_acoustic .or. any_poroelastic) call exit_MPI('initial field currently implemented for purely elastic simulation only')
- 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
+ ! Calculation of the initial field for a plane wave
!
!=======================================================================
- print *,'Number of grid points: ',npoin
- print *,'*** calculation of initial plane wave ***'
- if (source_type(1) == 1) then
- print *,'initial P wave of', angleforce*180.d0/pi, 'degrees introduced...'
- else if (source_type(1)== 2) then
- print *,'initial SV wave of', angleforce*180.d0/pi, ' degrees introduced...'
- else
- call exit_MPI('Unrecognized source_type: should be 1 for plane P waves, 2 for plane SV waves!')
+ if (myrank == 0) then
+ write(IOUT,*) 'Number of grid points: ',npoin
+ write(IOUT,*)
+ write(IOUT,*) '*** calculation of the initial plane wave ***'
+ write(IOUT,*)
+ write(IOUT,*) 'To change the initial plane wave, change source_type in DATA/Par_file'
+ write(IOUT,*) 'and use 1 for a plane P wave, 2 for a plane SV wave, 3 for a Rayleigh wave'
+ write(IOUT,*)
+
+! only implemented for one source
+ if(NSOURCE > 1) call exit_MPI('calculation of the initial wave is only implemented for one source')
+ if (source_type(1) == 1) then
+ write(IOUT,*) 'initial P wave of', angleforce(1)*180.d0/pi, 'degrees introduced.'
+ else if (source_type(1) == 2) then
+ write(IOUT,*) 'initial SV wave of', angleforce(1)*180.d0/pi, ' degrees introduced.'
+
+ else if (source_type(1) == 3) then
+ write(IOUT,*) 'Rayleigh wave introduced.'
+ else
+ call exit_MPI('Unrecognized source_type: should be 1 for plane P waves, 2 for plane SV waves, 3 for Rayleigh wave')
+ endif
+
+ if ((angleforce(1) < 0.0d0 .or. angleforce(1) >= pi/2.d0) .and. source_type(1) /= 3) then
+ call exit_MPI("incorrect angleforce: must have 0 <= angleforce < 90")
+ endif
endif
-
! only implemented for homogeneous media therefore only 1 material supported
if (numat==1) then
@@ -2625,7 +3182,7 @@
cploc = sqrt(lambdaplus2mu/denst)
csloc = sqrt(mu/denst)
-
+
! P wave case
if (source_type(1) == 1) then
@@ -2633,7 +3190,7 @@
c_inc = cploc
c_refl = csloc
- angleforce_refl = asin(p*csloc)
+ angleforce_refl = asin(p*c_refl)
! 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(1))*cos(angleforce_refl)/cploc) / &
@@ -2643,48 +3200,65 @@
(csloc**2*(cos(2.d0*angleforce_refl)**2/csloc**3 &
+4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc))
- print *,'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi, '\n'
+ if (myrank == 0) then
+ write(IOUT,*) 'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi
+ endif
! from Table 5.1 p141 in Aki & Richards (1980)
! we put the opposite sign on z coefficients because z axis is oriented from bottom to top
A_plane(1) = sin(angleforce(1)); A_plane(2) = cos(angleforce(1))
B_plane(1) = PP * sin(angleforce(1)); B_plane(2) = - PP * cos(angleforce(1))
- C_plane(1) = PS * cos(angleforce_refl); C_plane(2) = PS * sin(angleforce_refl)
+ C_plane(1) = PS * cos(angleforce_refl); C_plane(2) = PS * sin(angleforce_refl)
! SV wave case
- else
+ else if (source_type(1) == 2) then
p=sin(angleforce(1))/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*cploc<=1.d0) then
- angleforce_refl = asin(p*cploc)
+ if (p*c_refl<=1.d0) then
+ angleforce_refl = asin(p*c_refl)
! from formulas (5.30) and (5.31) p 140 in Aki & Richards (1980)
- SS = (cos(2.d0*angleforce_refl)**2/csloc**3 - 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc) / &
- (cos(2.d0*angleforce_refl)**2/csloc**3 + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc)
+ SS = (cos(2.d0*angleforce(1))**2/csloc**3 - 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc) / &
+ (cos(2.d0*angleforce(1))**2/csloc**3 + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc)
SP = 4.d0*p*cos(angleforce(1))*cos(2*angleforce(1)) / &
(cploc*csloc*(cos(2.d0*angleforce(1))**2/csloc**3&
+4.d0*p**2*cos(angleforce_refl)*cos(angleforce(1))/cploc))
- print *,'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi, '\n'
+ if (myrank == 0) then
+ write(IOUT,*) 'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi
+ endif
+ ! SV45 degree incident plane wave is a particular case
+ else if (angleforce(1)>pi/4.d0-1.0d-11 .and. angleforce(1)<pi/4.d0+1.0d-11) then
+ angleforce_refl = 0.d0
+ SS = -1.0d0
+ SP = 0.d0
else
- call exit_MPI('cannot be included for now: SV angle too high, beyond critical angle')
+ over_critical_angle=.true.
+ angleforce_refl = 0.d0
+ SS = 0.0d0
+ SP = 0.d0
endif
! from Table 5.1 p141 in Aki & Richards (1980)
! we put the opposite sign on z coefficients because z axis is oriented from bottom to top
A_plane(1) = cos(angleforce(1)); A_plane(2) = - sin(angleforce(1))
B_plane(1) = SS * cos(angleforce(1)); B_plane(2) = SS * sin(angleforce(1))
- C_plane(1) = SP * sin(angleforce_refl); C_plane(2) = - SP * cos(angleforce_refl)
+ C_plane(1) = SP * sin(angleforce_refl); C_plane(2) = - SP * cos(angleforce_refl)
+ ! Rayleigh case
+ else if (source_type(1) == 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 for now to have several materials with a plane wave (but could be done one day)')
+ call exit_MPI('not possible to have several materials with a plane wave')
endif
! get minimum and maximum values of mesh coordinates
@@ -2693,55 +3267,159 @@
xmax = maxval(coord(1,:))
zmax = maxval(coord(2,:))
- ! initialize the time offset to put the plane wave not too close to the free surface topography
- if (abs(angleforce(1))<20.d0*pi/180.d0) then
- time_offset=-1.d0*zmax/3.d0/c_inc
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (xmin, xmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (zmin, zmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (xmax, xmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (zmax, zmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ xmin = xmin_glob
+ zmin = zmin_glob
+ xmax = xmax_glob
+ zmax = zmax_glob
+#endif
+
+ ! initialize the time offset to put the plane wave not too close to the irregularity on the free surface
+ if (abs(angleforce(1))<1.d0*pi/180.d0 .and. source_type(1)/=3) then
+ time_offset=-1.d0*(zmax-zmin)/2.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
+ x0_source=x_source(1)
+ z0_source=z_source(1)
- do i = 1,npoin
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'You can modify the location of the initial plane wave by changing xs and zs in DATA/Par_File.'
+ write(IOUT,*) ' for instance: xs=',x_source(1),' zs=',z_source(1), ' (zs must be the height of the free surface)'
+ write(IOUT,*)
+ endif
- x = coord(1,i)
- z = coord(2,i)
+ if (.not. over_critical_angle) then
- ! z is from bottom to top therefore we take -z to make parallel with Aki & Richards
- z = z0_source - z
- x = x - x0_source
+ do i = 1,npoin
- t = 0.d0 + time_offset
+ x = coord(1,i)
+ z = coord(2,i)
- ! 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(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*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(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0) &
- + C_plane(2) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ ! 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 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(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*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(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0) &
- + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ t = 0.d0 + time_offset
- ! 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(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*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(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*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 displacement for a plane wave from Aki & Richards (1980)
+ displ_elastic(1,i) = A_plane(1) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(1) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(1) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+ displ_elastic(2,i) = A_plane(2) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(2) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(2) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
- enddo
- endif ! add_Bielak
+ ! 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(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+ veloc_elastic(2,i) = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+ ! 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(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(1) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(1) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+ accel_elastic(2,i) = A_plane(2) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(2) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(2) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+
+ enddo
+
+ else ! beyond critical angle
+
+ if (myrank == 0) then
+ if (source_type(1)/=3) write(IOUT,*) 'You are beyond the critical angle ( > ',asin(c_inc/c_refl)*180d0/pi,')'
+
+ write(IOUT,*) '*************'
+ write(IOUT,*) 'We have to compute the initial field in the frequency domain'
+ write(IOUT,*) 'and then convert it to the time domain (can be long... be patient...)'
+ write(IOUT,*) '*************'
+ endif
+
+ 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(1),&
+ f0(1),cploc,csloc,TURN_ATTENUATION_ON,Qp_attenuation,source_type(1),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)
+
+ if (myrank == 0) then
+ write(IOUT,*) '***********'
+ write(IOUT,*) 'done calculating the initial wave field'
+ write(IOUT,*) '***********'
+ endif
+
+ endif ! beyond critical angle
+
write(IOUT,*) 'Max norm of initial elastic displacement = ',maxval(sqrt(displ_elastic(1,:)**2 + displ_elastic(2,:)**2))
endif ! initialfield
@@ -2757,13 +3435,16 @@
allocate(source_time_function(NSOURCE,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
- do i_source=1,NSOURCE !yang
+
+! loop on all the sources
+ do i_source=1,NSOURCE
+
! loop on all the time steps
do it = 1,NSTEP
@@ -2772,14 +3453,15 @@
! Ricker (second derivative of a Gaussian) source time function
if(time_function_type(i_source) == 1) then
-! source_time_function(it) = - factor * (ONE-TWO*aval*(time-t0)**2) * exp(-aval*(time-t0)**2)
+! source_time_function(i_source,it) = - factor(i_source) * (ONE-TWO*aval(i_source)*(time-t0(i_source))**2) * &
+! exp(-aval(i_source)*(time-t0(i_source))**2)
source_time_function(i_source,it) = - factor(i_source) * TWO*aval(i_source)*sqrt(aval(i_source))*&
(time-t0(i_source))/pi * exp(-aval(i_source)*(time-t0(i_source))**2)
! first derivative of a Gaussian source time function
else if(time_function_type(i_source) == 2) then
- source_time_function(i_source,it) = - factor(i_source) * TWO*aval(i_source)*(time-t0(i_source)) *&
- exp(-aval(i_source)*(time-t0(i_source))**2)
+ source_time_function(i_source,it) = - factor(i_source) * TWO*aval(i_source)*(time-t0(i_source)) * &
+ exp(-aval(i_source)*(time-t0(i_source))**2)
! Gaussian or Dirac (we use a very thin Gaussian instead) source time function
else if(time_function_type(i_source) == 3 .or. time_function_type(i_source) == 4) then
@@ -2790,45 +3472,34 @@
hdur(i_source) = 1.d0 / f0(i_source)
hdur_gauss(i_source) = hdur(i_source) * 5.d0 / 3.d0
source_time_function(i_source,it) = factor(i_source) * 0.5d0*(1.0d0 + &
- netlib_specfun_erf(SOURCE_DECAY_MIMIC_TRIANGLE*(time-t0(i_source))/hdur_gauss(i_source)))
+ netlib_specfun_erf(SOURCE_DECAY_MIMIC_TRIANGLE*(time-t0(i_source))/hdur_gauss(i_source)))
else
call exit_MPI('unknown source time function')
endif
-!!!!!!!!!!!!!!!!!!!!!!yang!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!for comparison with J. Tromp et al(2005)
-! source_time_function(it) = - factor * TWO*(2.0*2.628/4.0)**3*(time-8.0)/pi * exp(-(2.0*2.628/4.0)**2*(time-8.0)**2)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! output absolute time in third column, in case user wants to check it as well
-
-!!!!!!!!!!!yang!!!!!!!!!!!!!!!!!!!
- if ( myrank == 0 .and. i_source == 1) then
- write(55,*) sngl(time),real(source_time_function(i_source,it),4),sngl(time-t0(i_source))
- endif
+ if (myrank == 0 .and. i_source==1 ) write(55,*) sngl(time),real(source_time_function(1,it),4),sngl(time-t0(1))
enddo
- enddo ! i_source=1,NSOURCE !yang
- if ( myrank == 0 ) then
- close(55)
- endif
+ enddo ! i_source=1,NSOURCE
+ if (myrank == 0) close(55)
+
! 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.
! since source contribution is linear, the source_time_function is cut down by that number (it would have been similar
! if we just had elected one of those processes).
- do i_source=1,NSOURCE
- source_time_function(i_source,:) = source_time_function(i_source,:) / nb_proc_source(i_source)
- enddo
+ do i_source=1,NSOURCE
+ source_time_function(i_source,:) = source_time_function(i_source,:) / nb_proc_source(i_source)
+ enddo
+
else
allocate(source_time_function(1,1))
- endif
+ endif
-
-! determine if coupled fluid-solid (elastic or poroelastic) simulation
+! determine if coupled fluid-solid simulation
coupled_acoustic_elastic = any_acoustic .and. any_elastic
coupled_acoustic_poroelastic = any_acoustic .and. any_poroelastic
@@ -2836,11 +3507,12 @@
! 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
@@ -2889,14 +3561,13 @@
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. &
- .not. poroelastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
+ .not. poroelastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
! loop on the four edges of the two elements
do iedge_acoustic = 1,NEDGES
@@ -2920,14 +3591,11 @@
enddo
-
! 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 ) then
- print *,'Checking fluid/solid (elastic) edge topology...'
- endif
+ if(myrank == 0) print *,'Checking fluid/solid edge topology...'
do inum = 1,num_fluid_solid_edges
@@ -2960,15 +3628,11 @@
enddo
- if ( myrank == 0 ) then
- print *,'End of fluid/solid (elastic) edge detection'
- print *
+ if (myrank == 0) then
+ print *,'End of fluid/solid edge detection'
+ print *
endif
- else
-
-
-
endif
! fluid/solid (poroelastic) edge detection
@@ -3028,7 +3692,6 @@
enddo
-
do inum = 1, num_fluid_poro_edges
ispec_acoustic = fluid_poro_acoustic_ispec(inum)
ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
@@ -3102,35 +3765,19 @@
print *
endif
- else
-
-
-
endif
-! default values for acoustic absorbing edges
- ibegin_bottom(:) = 1
- ibegin_top(:) = 1
+! exclude common points between acoustic absorbing edges and acoustic/elastic matching interfaces
+ if(coupled_acoustic_elastic .and. anyabs) then
- iend_bottom(:) = NGLLX
- iend_top(:) = NGLLX
+ if (myrank == 0) &
+ print *,'excluding common points between acoustic absorbing edges and acoustic/elastic matching interfaces, if any'
- jbegin_left(:) = 1
- jbegin_right(:) = 1
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
- jend_left(:) = NGLLZ
- jend_right(:) = NGLLZ
+ ispec = numabs(ispecabs)
-! exclude common points between acoustic absorbing edges and acoustic/(poro)elastic matching interfaces
- if(coupled_acoustic_elastic .and. anyabs) then
-
- if ( myrank == 0 ) then
- print *,'excluding common points between acoustic absorbing edges and acoustic/elastic 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_solid_edges
@@ -3139,7 +3786,7 @@
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(ispec_acoustic == ispec) then
if(iedge_acoustic == IBOTTOM) then
jbegin_left(ispecabs) = 2
@@ -3151,25 +3798,6 @@
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
-
-! 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_zmin(ispecabs) .or. ispec_acoustic == ib_zmax(ispecabs)) then
-
if(iedge_acoustic == ILEFT) then
ibegin_bottom(ispecabs) = 2
ibegin_top(ispecabs) = 2
@@ -3186,18 +3814,19 @@
enddo
-
endif
+! exclude common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces
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
+ if (myrank == 0) &
+ print *,'excluding common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces, if any'
-!--- left and right absorbing boundary
- do ispecabs = 1, nspec_xmin
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+ ispec = numabs(ispecabs)
+
! loop on all the coupling edges
do inum = 1,num_fluid_poro_edges
@@ -3206,7 +3835,7 @@
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(ispec_acoustic == ispec) then
if(iedge_acoustic == IBOTTOM) then
jbegin_left(ispecabs) = 2
@@ -3218,25 +3847,6 @@
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
@@ -3253,9 +3863,9 @@
enddo
-
endif
+
! determine if coupled elastic-poroelastic simulation
coupled_elastic_poroelastic = any_elastic .and. any_poroelastic
@@ -3263,6 +3873,10 @@
! 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(TURN_ATTENUATION_ON .or. TURN_VISCATTENUATION_ON) &
+ stop 'Attenuation not supported for mixed elastic/poroelastic simulations'
+
if ( myrank == 0 ) then
print *
print *,'Mixed elastic/poroelastic simulation'
@@ -3345,7 +3959,6 @@
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
@@ -3390,43 +4003,28 @@
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'
+ if (myrank == 0) &
+ print *,'excluding common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces, if any'
! 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_solid_poro_edges
-! get the edge of the poroelastic element
+! get the edge of the acoustic 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 poroelastic absorbing element and elastic/poroelastic coupled element is the same
+ if(ispec_poroelastic == ispec) then
if(iedge_poroelastic == IBOTTOM) then
jbegin_left_poro(ispecabs) = 2
@@ -3438,24 +4036,6 @@
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
@@ -3472,57 +4052,11 @@
enddo
- endif !(coupled_elastic_poroelastic .and. anyabs)
+ endif
-! detecting poroelastic, elastic and acoustic global points valence
-
- if(coupled_acoustic_elastic .or. coupled_acoustic_poroelastic .or. coupled_elastic_poroelastic)then
-
- allocate(valence_elastic(npoin))
- allocate(valence_poroelastic(npoin))
- allocate(valence_acoustic(npoin))
-
-
- valence_elastic(:) = 0
- valence_poroelastic(:) = 0
- valence_acoustic(:) = 0
- do ispec = 1,nspec
- if(elastic(ispec)) then ! the element is elastic
- do k = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,k,ispec)
- valence_elastic(iglob) = valence_elastic(iglob) + 1
- enddo
- enddo
- elseif(poroelastic(ispec)) then ! the element is poroelastic
- do k = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,k,ispec)
- valence_poroelastic(iglob) = valence_poroelastic(iglob) + 1
- enddo
- enddo
- else ! the element is acoustic
- do k = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,k,ispec)
- valence_acoustic(iglob) = valence_acoustic(iglob) + 1
- enddo
- enddo
- endif
- enddo !do ispec
-
- else
-
- allocate(valence_elastic(1))
- allocate(valence_poroelastic(1))
- allocate(valence_acoustic(1))
-
- endif !(coupled_acoustic_elastic .or. coupled_acoustic_poroelastic .or. coupled_elastic_poroelastic)
-
-
#ifdef USE_MPI
- if(OUTPUT_ENERGY) stop 'energy calculation only serial right now, should add an MPI_REDUCE in parallel'
+ if(OUTPUT_ENERGY) stop 'energy calculation only currently serial only, should add an MPI_REDUCE in parallel'
#endif
! open the file in which we will store the energy curve
if(OUTPUT_ENERGY) open(unit=IENERGY,file='energy.gnu',status='unknown')
@@ -3530,9 +4064,7 @@
!
!---- s t a r t t i m e i t e r a t i o n s
!
- if ( myrank == 0 ) then
- write(IOUT,400)
- endif
+ if (myrank == 0) write(IOUT,400)
! count elapsed wall-clock time
call date_and_time(datein,timein,zone,time_values)
@@ -3545,12 +4077,12 @@
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 .or. isolver == 2) then
+ if(output_color_image) 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
+
+ if(poroelastic(ispec)) then
!get parameters of current spectral element
phil = porosity(kmato(ispec))
tortl = tortuosity(kmato(ispec))
@@ -3559,7 +4091,7 @@
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))
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
rhol_f = density(2,kmato(ispec))
!frame properties
mul_fr = poroelastcoef(2,3,kmato(ispec))
@@ -3577,12 +4109,7 @@
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)
-
- if(phil <= 0.d0) then
- cssquare = mul_s/afactor
- else
cssquare = mul_fr/afactor
- endif
! Approximated ratio r = amplitude "w" field/amplitude "s" field (no viscous dissipation)
! used later for kernels calculation
@@ -3594,17 +4121,26 @@
do j = 1,NGLLZ
do i = 1,NGLLX
+ vp_display(ibool(i,j,ispec)) = sqrt(cpIsquare)
+ enddo
+ enddo
+
+ else
+! get relaxed elastic parameters of current spectral element
+ rhol = density(1,kmato(ispec))
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ 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)
- 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)
+ else
+ vp_display(ibool(i,j,ispec)) = sqrt((lambdal_relaxed + 2.d0*mul_relaxed) / rhol)
endif
enddo
enddo
+ endif !if(poroelastic(ispec)) then
enddo
! getting velocity for each local pixels
@@ -3614,13 +4150,12 @@
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)
@@ -3629,7 +4164,6 @@
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
@@ -3638,7 +4172,6 @@
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)
@@ -3649,6 +4182,25 @@
#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
@@ -3671,12 +4223,8 @@
print*,'beta = ', betaval
print*,'gamma = ', gammaval
print*,'************************************************************'
- endif
-! clear memory variables if attenuation
- if(TURN_VISCATTENUATION_ON) then
-
- ! initialize memory variables for attenuation
+! initialize memory variables for attenuation
viscox(:,:,:) = 0.d0
viscoz(:,:,:) = 0.d0
rx_viscous(:,:,:) = 0.d0
@@ -3684,10 +4232,143 @@
endif
+! allocate arrays for postscript output
+#ifdef USE_MPI
+ if(modelvect) then
+ d1_coorg_recv_ps_velocity_model=2
+ call mpi_allreduce(nspec,d2_coorg_recv_ps_velocity_model,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+ d2_coorg_recv_ps_velocity_model=d2_coorg_recv_ps_velocity_model*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4
+ d1_RGB_recv_ps_velocity_model=1
+ call mpi_allreduce(nspec,d2_RGB_recv_ps_velocity_model,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+ d2_RGB_recv_ps_velocity_model=d2_RGB_recv_ps_velocity_model*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4
+ else
+ d1_coorg_recv_ps_velocity_model=1
+ d2_coorg_recv_ps_velocity_model=1
+ d1_RGB_recv_ps_velocity_model=1
+ d2_RGB_recv_ps_velocity_model=1
+ endif
+
+ d1_coorg_send_ps_element_mesh=2
+ if ( ngnod == 4 ) then
+ if ( numbers == 1 ) then
+ d2_coorg_send_ps_element_mesh=nspec*5
+ if ( colors == 1 ) then
+ d1_color_send_ps_element_mesh=2*nspec
+ else
+ d1_color_send_ps_element_mesh=1*nspec
+ endif
+ else
+ d2_coorg_send_ps_element_mesh=nspec*6
+ if ( colors == 1 ) then
+ d1_color_send_ps_element_mesh=1*nspec
+ endif
+ endif
+ else
+ if ( numbers == 1 ) then
+ d2_coorg_send_ps_element_mesh=nspec*((pointsdisp-1)*3+max(0,pointsdisp-2)+1+1)
+ if ( colors == 1 ) then
+ d1_color_send_ps_element_mesh=2*nspec
+ else
+ d1_color_send_ps_element_mesh=1*nspec
+ endif
+ else
+ d2_coorg_send_ps_element_mesh=nspec*((pointsdisp-1)*3+max(0,pointsdisp-2)+1)
+ if ( colors == 1 ) then
+ d1_color_send_ps_element_mesh=1*nspec
+ endif
+ endif
+ endif
+
+call mpi_allreduce(d1_coorg_send_ps_element_mesh,d1_coorg_recv_ps_element_mesh,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+call mpi_allreduce(d2_coorg_send_ps_element_mesh,d2_coorg_recv_ps_element_mesh,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+call mpi_allreduce(d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+
+ d1_coorg_send_ps_abs=4
+ d2_coorg_send_ps_abs=4*nelemabs
+call mpi_allreduce(d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+call mpi_allreduce(d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+
+ d1_coorg_send_ps_free_surface=4
+ d2_coorg_send_ps_free_surface=4*nelem_acoustic_surface
+call mpi_allreduce(d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+call mpi_allreduce(d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+
+ d1_coorg_send_ps_vector_field=8
+ if(interpol) then
+ if(plot_lowerleft_corner_only) then
+ d2_coorg_send_ps_vector_field=nspec*1*1
+ else
+ d2_coorg_send_ps_vector_field=nspec*pointsdisp*pointsdisp
+ endif
+ else
+ d2_coorg_send_ps_vector_field=npoin
+ endif
+call mpi_allreduce(d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+call mpi_allreduce(d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+
+
+#else
+ d1_coorg_recv_ps_velocity_model=1
+ d2_coorg_recv_ps_velocity_model=1
+ d1_RGB_recv_ps_velocity_model=1
+ d2_RGB_recv_ps_velocity_model=1
+
+ d1_coorg_send_ps_element_mesh=1
+ d2_coorg_send_ps_element_mesh=1
+ d1_coorg_recv_ps_element_mesh=1
+ d2_coorg_recv_ps_element_mesh=1
+ d1_color_send_ps_element_mesh=1
+ d1_color_recv_ps_element_mesh=1
+
+ d1_coorg_send_ps_abs=1
+ d2_coorg_send_ps_abs=1
+ d1_coorg_recv_ps_abs=1
+ d2_coorg_recv_ps_abs=1
+ d1_coorg_send_ps_free_surface=1
+ d2_coorg_send_ps_free_surface=1
+ d1_coorg_recv_ps_free_surface=1
+ d2_coorg_recv_ps_free_surface=1
+
+ d1_coorg_send_ps_vector_field=1
+ d2_coorg_send_ps_vector_field=1
+ d1_coorg_recv_ps_vector_field=1
+ d2_coorg_recv_ps_vector_field=1
+
+#endif
+ d1_coorg_send_ps_velocity_model=2
+ d2_coorg_send_ps_velocity_model=nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4
+ d1_RGB_send_ps_velocity_model=1
+ d2_RGB_send_ps_velocity_model=nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)
+
+ allocate(coorg_send_ps_velocity_model(d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model))
+ allocate(RGB_send_ps_velocity_model(d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model))
+
+ allocate(coorg_recv_ps_velocity_model(d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model))
+ allocate(RGB_recv_ps_velocity_model(d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model))
+
+ allocate(coorg_send_ps_element_mesh(d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh))
+ allocate(coorg_recv_ps_element_mesh(d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh))
+ allocate(color_send_ps_element_mesh(d1_color_send_ps_element_mesh))
+ allocate(color_recv_ps_element_mesh(d1_color_recv_ps_element_mesh))
+
+ allocate(coorg_send_ps_abs(d1_coorg_send_ps_abs,d2_coorg_send_ps_abs))
+ allocate(coorg_recv_ps_abs(d1_coorg_recv_ps_abs,d2_coorg_recv_ps_abs))
+
+ allocate(coorg_send_ps_free_surface(d1_coorg_send_ps_free_surface,d2_coorg_send_ps_free_surface))
+ allocate(coorg_recv_ps_free_surface(d1_coorg_recv_ps_free_surface,d2_coorg_recv_ps_free_surface))
+
+ allocate(coorg_send_ps_vector_field(d1_coorg_send_ps_vector_field,d2_coorg_send_ps_vector_field))
+ allocate(coorg_recv_ps_vector_field(d1_coorg_recv_ps_vector_field,d2_coorg_recv_ps_vector_field))
+
! *********************************************************
! ************* MAIN LOOP OVER THE TIME STEPS *************
! *********************************************************
+#ifdef USE_MPI
+! add a barrier if we generate traces of the run for analysis with "ParaVer"
+ if(GENERATE_PARAVER_TRACES) call MPI_BARRIER(MPI_COMM_WORLD,ier)
+#endif
+
do it = 1,NSTEP
! update position in seismograms
@@ -3701,11 +4382,12 @@
displ_elastic = displ_elastic + deltat*veloc_elastic + deltatsquareover2*accel_elastic
veloc_elastic = veloc_elastic + deltatover2*accel_elastic
accel_elastic = ZERO
- if(isolver == 2) then
+
+ if(isolver == 2) then ! Adjoint calculation
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
endif
if(any_poroelastic) then
@@ -3717,60 +4399,8 @@
displw_poroelastic = displw_poroelastic + deltat*velocw_poroelastic + deltatsquareover2*accelw_poroelastic
velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
accelw_poroelastic = ZERO
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!yang!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! add Gaussian filter to deal with the source noises !!!!!!!!!!!!!!!!!!
-! write(*,*) 'timestep=',it
-!if (it < yang_SourceTimeStep) then
-! displs_poroelastic_smooth = displs_poroelastic
-! velocs_poroelastic_smooth = velocs_poroelastic
-! displw_poroelastic_smooth = displw_poroelastic
-! velocw_poroelastic_smooth = velocw_poroelastic
-! do yang_l=1,NGLLX
-! do yang_m=1,NGLLZ
-! yang_iglob1=ibool(yang_l,yang_m,ispec_selected_source)
-!! write(*,*) 'iglob1=',yang_iglob1
-! yang_x1=coord(1,yang_iglob1)
-! yang_z1=coord(2,yang_iglob1)
-! yang_r1=(yang_x1-x_source)**2+(yang_z1-z_source)**2
-!! if (yang_r1 <= yang_smooth_region**2) then
-! displs_poroelastic_smooth(:,yang_iglob1) = 0.0
-! velocs_poroelastic_smooth(:,yang_iglob1) = 0.0
-! displw_poroelastic_smooth(:,yang_iglob1) = 0.0
-! velocw_poroelastic_smooth(:,yang_iglob1) = 0.0
-! do yang_iglob2 =1,npoin
-! yang_x2=coord(1,yang_iglob2)
-! yang_z2=coord(2,yang_iglob2)
-! yang_r2=(yang_x1-yang_x2)**2+(yang_z1-yang_z2)**2
-!! if (yang_r2 <= yang_gaussian_region**2) then
-! displs_poroelastic_smooth(:,yang_iglob1) = displs_poroelastic_smooth(:,yang_iglob1) + &
-! displs_poroelastic(:,yang_iglob2)*exp(-yang_r2/yang_gaussian_region**2/2)
-! displw_poroelastic_smooth(:,yang_iglob1) = displw_poroelastic_smooth(:,yang_iglob1) + &
-! displw_poroelastic(:,yang_iglob2)*exp(-yang_r2/yang_gaussian_region**2/2)
-! velocs_poroelastic_smooth(:,yang_iglob1) = velocs_poroelastic_smooth(:,yang_iglob1) + &
-! velocs_poroelastic(:,yang_iglob2)*exp(-yang_r2/yang_gaussian_region**2/2)
-! velocw_poroelastic_smooth(:,yang_iglob1) = velocw_poroelastic_smooth(:,yang_iglob1) + &
-! velocw_poroelastic(:,yang_iglob2)*exp(-yang_r2/yang_gaussian_region**2/2)
-!! endif
-! enddo
-!! else
-!! displs_poroelastic_smooth(:,yang_iglob1) = displs_poroelastic(:,yang_iglob1)
-!! velocs_poroelastic_smooth(:,yang_iglob1) = velocs_poroelastic(:,yang_iglob1)
-!! displw_poroelastic_smooth(:,yang_iglob1) = displw_poroelastic(:,yang_iglob1)
-!! velocw_poroelastic_smooth(:,yang_iglob1) = velocw_poroelastic(:,yang_iglob1)
-!! endif
-! enddo
-! enddo
-! displs_poroelastic = displs_poroelastic_smooth
-! velocs_poroelastic = velocs_poroelastic_smooth
-! displw_poroelastic = displw_poroelastic_smooth
-! velocw_poroelastic = velocw_poroelastic_smooth
-!! write(*,*) 'it=',it,'wave_field smoothed!'
-!endif
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- if(isolver == 2) then
+ if(isolver == 2) then ! Adjoint calculation
!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
@@ -3779,7 +4409,7 @@
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
endif
!--------------------------------------------------------------------------------------------
@@ -3842,7 +4472,7 @@
viscoz(:,:,ispec) = viscoz_loc(:,:)
enddo ! end of spectral element loop
- endif ! end of attenuation
+ endif ! end of viscous attenuation for porous media
!-----------------------------------------
@@ -3851,7 +4481,8 @@
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
+
+ if(isolver == 2) then ! Adjoint calculation
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
@@ -3860,13 +4491,12 @@
! 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)
- if(isolver == 2) then
+ call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,acoustic_surface,ibool,nelem_acoustic_surface,npoin,nspec)
+
+ if(isolver == 2) then ! Adjoint calculation
call enforce_acoustic_free_surface(b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
- b_potential_acoustic,acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
+ b_potential_acoustic,acoustic_surface,ibool,nelem_acoustic_surface,npoin,nspec)
endif
endif
@@ -3874,23 +4504,18 @@
! ************* compute forces for the acoustic elements
! *********************************************************
-! first call, computation on outer elements, absorbing conditions and source
- 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,&
+ call compute_forces_acoustic(npoin,nspec,nelemabs,numat,it,NSTEP, &
+ anyabs,assign_external_model,ibool,kmato,numabs, &
+ elastic,poroelastic,codeabs,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, &
+ vpext,rhoext,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., &
- nrec,isolver,save_forward,b_absorb_acoustic_left,&
+ jbegin_left,jend_left,jbegin_right,jend_right,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,kappa_ac_k,NSOURCE)
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,kappa_ac_k)
if(anyabs .and. save_forward .and. isolver == 1) then
@@ -4010,21 +4635,14 @@
! compute dot product
displ_n = displ_x*nx + displ_z*nz
- if(valence_acoustic(iglob) /= valence_elastic(iglob)) then
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + &
- weight*displ_n*valence_acoustic(iglob)/2._CUSTOM_REAL
- else
+! formulation with generalized potential
+ weight = jacobian1D * wxgll(i)
+
potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
- endif
if(isolver == 2) then
- if(valence_acoustic(iglob) /= valence_elastic(iglob)) then
- b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) + &
- weight*(b_displ_x*nx + b_displ_z*nz)*valence_acoustic(iglob)/2._CUSTOM_REAL
- else
b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) +&
weight*(b_displ_x*nx + b_displ_z*nz)
- endif
endif !if(isolver == 2) then
enddo
@@ -4074,6 +4692,7 @@
endif
! get point values for the acoustic side
+! get point values for the acoustic side
i = ivalue(ipoin1D,iedge_acoustic)
j = jvalue(ipoin1D,iedge_acoustic)
iglob = ibool(i,j,ispec_acoustic)
@@ -4116,22 +4735,11 @@
! compute dot product [u_s + w]*n
displ_n = (displ_x + displw_x)*nx + (displ_z + displw_z)*nz
- if(valence_acoustic(iglob) /= valence_poroelastic(iglob)) then
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + &
- weight*displ_n*valence_acoustic(iglob)/2._CUSTOM_REAL
- else
potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
- endif
if(isolver == 2) then
- if(valence_acoustic(iglob) /= valence_poroelastic(iglob)) 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)* &
- valence_acoustic(iglob)/2._CUSTOM_REAL
- else
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
endif !if(isolver == 2) then
enddo
@@ -4140,51 +4748,16 @@
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, &
- max_interface_size, max_ibool_interfaces_size_ac,&
- ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
- 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,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., &
- 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,kappa_ac_k,NSOURCE)
- endif
-
-! assembling potential_dot_dot for acoustic elements (receive)
+! assembling potential_dot_dot for acoustic elements
#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, &
+ call assemble_MPI_vector_ac(potential_dot_dot_acoustic,npoin, &
+ 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_send_faces_vector_ac, &
+ buffer_recv_faces_vector_ac, my_neighbours)
endif
#endif
@@ -4195,32 +4768,76 @@
if(any_acoustic) then
+! --- add the source
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCE
+! if this processor carries the source and the source element is acoustic
+ if (is_proc_source(i_source) == 1 .and. .not. elastic(ispec_selected_source(i_source)) .and. &
+ .not. poroelastic(ispec_selected_source(i_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(i_source) == 1) then
+ if(isolver == 1) then ! forward wavefield
+ potential_dot_dot_acoustic(iglob_source(i_source)) = potential_dot_dot_acoustic(iglob_source(i_source)) &
+ - source_time_function(i_source,it)
+ else ! backward wavefield
+ b_potential_dot_dot_acoustic(iglob_source(i_source)) = b_potential_dot_dot_acoustic(iglob_source(i_source)) &
+ - source_time_function(i_source,NSTEP-it+1)
+ endif
+! moment tensor
+ else if(source_type(i_source) == 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
+ enddo ! do i_source=1,NSOURCE
+
+ 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. .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))
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - &
+ adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
+ enddo
+ enddo
+ endif ! if this processor carries the adjoint source
+ enddo ! irec = 1,nrec
+ endif ! isolver == 2 adjoint wavefield
+
+ 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)
+
if(isolver == 2) then
call enforce_acoustic_free_surface(b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
- b_potential_acoustic,acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
+ b_potential_acoustic,acoustic_surface,ibool,nelem_acoustic_surface,npoin,nspec)
endif
+
endif
endif
if(any_acoustic .and. isolver == 2) then ! kernels calculation
do iglob = 1,npoin
- rho_ac_k(iglob) = potential_dot_dot_acoustic(iglob)*b_potential_acoustic(iglob)
+ rho_ac_k(iglob) = potential_dot_dot_acoustic(iglob)*b_potential_acoustic(iglob)
enddo
endif
+
! ****************************************************************************************
! If coupling elastic/poroelastic domain, average some arrays at the interface first
! ****************************************************************************************
@@ -4305,24 +4922,25 @@
! ************* main solver for the elastic elements
! *********************************************************
-! first call, computation on outer elements, absorbing conditions and source
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,&
+ call compute_forces_elastic(npoin,nspec,myrank,nelemabs,numat, &
+ 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,elastic, &
- accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic,&
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
+ 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,&
- nrec,isolver,save_forward,b_absorb_elastic_left,&
+ deltat,coord,add_Bielak_conditions, x0_source, z0_source, &
+ A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset, f0(1),&
+ v0x_left(1,it),v0z_left(1,it),v0x_right(1,it),v0z_right(1,it),v0x_bot(1,it),v0z_bot(1,it), &
+ t0x_left(1,it),t0z_left(1,it),t0x_right(1,it),t0z_right(1,it),t0x_bot(1,it),t0z_bot(1,it), &
+ count_left,count_right,count_bot,over_critical_angle,NSOURCE,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,NSOURCE)
+ 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
@@ -4373,6 +4991,90 @@
endif !if(any_elastic)
+! *********************************************************
+! ************* add coupling with the acoustic side
+! *********************************************************
+
+ if(coupled_acoustic_elastic) then
+
+! 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)
+
+! get the corresponding edge of the elastic element
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+ iedge_elastic = fluid_solid_elastic_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)
+
+! compute pressure on the fluid/solid edge
+ pressure = - potential_dot_dot_acoustic(iglob)
+ if(isolver == 2) then
+ b_pressure = - b_potential_dot_dot_acoustic(iglob)
+ endif
+! get point values for the elastic side
+ ii2 = ivalue(ipoin1D,iedge_elastic)
+ jj2 = jvalue(ipoin1D,iedge_elastic)
+ iglob = ibool(ii2,jj2,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).
+ if(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
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic == IBOTTOM)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
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic ==ILEFT)then
+ 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
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_acoustic ==IRIGHT)then
+ 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
+ weight = jacobian1D * wzgll(j)
+ endif
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) + weight*nx*pressure
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) + weight*nz*pressure
+
+ if(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + weight*nx*b_pressure
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) + weight*nz*b_pressure
+ endif !if(isolver == 2) then
+
+ enddo
+
+ enddo
+
+ endif
+
! ****************************************************************************
! ************* add coupling with the poroelastic side
! ****************************************************************************
@@ -4405,7 +5107,7 @@
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))
+ 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))
@@ -4421,7 +5123,6 @@
lambdal_G = H_biot - 2._CUSTOM_REAL*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
@@ -4518,318 +5219,194 @@
b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
endif
! 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)
+ ii2 = ivalue(ipoin1D,iedge_elastic)
+ jj2 = jvalue(ipoin1D,iedge_elastic)
+ iglob = ibool(ii2,jj2,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).
- if(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)
+ 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_acoustic == IBOTTOM)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ 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_acoustic ==ILEFT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ 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_acoustic ==IRIGHT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ 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
- if(valence_poroelastic(iglob) /= valence_elastic(iglob)) then
accel_elastic(1,iglob) = accel_elastic(1,iglob) - weight* &
- (sigma_xx*nx + sigma_xz*nz)*&
- valence_elastic(iglob)/2._CUSTOM_REAL
+ (sigma_xx*nx + sigma_xz*nz)
accel_elastic(2,iglob) = accel_elastic(2,iglob) - weight* &
- (sigma_xz*nx + sigma_zz*nz)*&
- valence_elastic(iglob)/2._CUSTOM_REAL
- else
- 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)
- endif
if(isolver == 2) then
- if(valence_poroelastic(iglob) /= valence_elastic(iglob)) then
b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - weight*( &
- b_sigma_xx*nx + b_sigma_xz*nz)*valence_elastic(iglob)/2._CUSTOM_REAL
-
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - weight*( &
- b_sigma_xz*nx + b_sigma_zz*nz)*valence_elastic(iglob)/2._CUSTOM_REAL
- else
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - weight*( &
b_sigma_xx*nx + b_sigma_xz*nz)
b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - weight*( &
b_sigma_xz*nx + b_sigma_zz*nz)
- endif
endif !if(isolver == 2) then
- enddo
-
- enddo
- endif
-
-! *********************************************************
-! ************* add coupling with the acoustic side
-! *********************************************************
-
- if(coupled_acoustic_elastic) then
-
-! 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)
-
-! get the corresponding edge of the elastic element
- ispec_elastic = fluid_solid_elastic_ispec(inum)
- iedge_elastic = fluid_solid_elastic_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 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 = - 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)
- 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).
- if(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
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic == IBOTTOM)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
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic ==ILEFT)then
- 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
- weight = jacobian1D * wzgll(j)
- elseif(iedge_acoustic ==IRIGHT)then
- 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
- weight = jacobian1D * wzgll(j)
- endif
-
- if(valence_acoustic(iglob) /= valence_elastic(iglob)) then
- accel_elastic(1,iglob) = accel_elastic(1,iglob) + weight*nx*pressure*&
- valence_elastic(iglob)/2._CUSTOM_REAL
- accel_elastic(2,iglob) = accel_elastic(2,iglob) + weight*nz*pressure*&
- valence_elastic(iglob)/2._CUSTOM_REAL
- else
- accel_elastic(1,iglob) = accel_elastic(1,iglob) + weight*nx*pressure
- accel_elastic(2,iglob) = accel_elastic(2,iglob) + weight*nz*pressure
- endif
-
- if(isolver == 2) then
- if(valence_acoustic(iglob) /= valence_elastic(iglob)) then
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + weight*nx*b_pressure*&
- valence_elastic(iglob)/2._CUSTOM_REAL
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) + weight*nz*b_pressure*&
- valence_elastic(iglob)/2._CUSTOM_REAL
- else
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + weight*nx*b_pressure
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) + weight*nz*b_pressure
- endif
- endif !if(isolver == 2) then
enddo
enddo
endif
-! assembling accel_elastic for elastic elements (send)
+
+! assembling accel_elastic for elastic elements
#ifdef USE_MPI
- 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 &
- )
+ if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0) then
+ call assemble_MPI_vector_el(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, &
+ buffer_recv_faces_vector_el, my_neighbours)
endif
#endif
-! second call, computation on inner elements and update of
- if(any_elastic) &
- 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,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,&
- 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,NSOURCE)
-! assembling accel_elastic for elastic elements (receive)
-#ifdef USE_MPI
- 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 &
- )
- end if
-#endif
-
-
! ************************************************************************************
! ************* multiply by the inverse of the mass matrix and update velocity
! ************************************************************************************
if(any_elastic) then
+
+! --- add the source if it is a collocated force
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCE
+! if this processor carries the source and the source element is elastic
+ if (is_proc_source(i_source) == 1 .and. elastic(ispec_selected_source(i_source))) then
+
+! collocated force
+ if(source_type(i_source) == 1) then
+ if(isolver == 1) then ! forward wavefield
+ accel_elastic(1,iglob_source(i_source)) = accel_elastic(1,iglob_source(i_source)) &
+ - sin(angleforce(i_source))*source_time_function(i_source,it)
+ accel_elastic(2,iglob_source(i_source)) = accel_elastic(2,iglob_source(i_source)) &
+ + cos(angleforce(i_source))*source_time_function(i_source,it)
+ else ! backward wavefield
+ b_accel_elastic(1,iglob_source(i_source)) = b_accel_elastic(1,iglob_source(i_source)) &
+ - sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ b_accel_elastic(2,iglob_source(i_source)) = b_accel_elastic(2,iglob_source(i_source)) &
+ + cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ endif !endif isolver == 1
+ endif
+
+ endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCE
+
+ endif ! if not using an initial field
+
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
- if(any_elastic .and. isolver == 2) then ! kernels calculation
+ 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)
+ accel_elastic(2,iglob)*b_displ_elastic(2,iglob)
enddo
endif
! ******************************************************************************************************************
-! ******************************************************************************************************************
! ************* main solver for the poroelastic elements: first the solid (u_s) than the fluid (w)
! ******************************************************************************************************************
-! ******************************************************************************************************************
-! first call, computation on outer elements, absorbing conditions and source
if(any_poroelastic) then
if(isolver == 2) then
+! if inviscid fluid, comment the reading and uncomment the zeroing
read(23,rec=NSTEP-it+1) b_viscodampx
read(24,rec=NSTEP-it+1) b_viscodampz
+! b_viscodampx(:) = ZERO
+! b_viscodampz(:) = ZERO
endif
- call compute_forces_solid(npoin,nspec,myrank,numat,iglob_source, &
+ call compute_forces_solid(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,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,poroelastic, &
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
accels_poroelastic,velocs_poroelastic,velocw_poroelastic,displs_poroelastic,displw_poroelastic,&
b_accels_poroelastic,b_displs_poroelastic,b_velocw_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, &
+ jacobian,source_time_function,sourcearray,adj_sourcearrays,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, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu2,N_SLS, &
rx_viscous,rz_viscous,theta_e,theta_s,&
b_viscodampx,b_viscodampz,&
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,&
+ mufr_k,B_k,NSOURCE,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,NSOURCE)
-
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax)
- call compute_forces_fluid(npoin,nspec,myrank,numat,iglob_source, &
+
+ call compute_forces_fluid(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,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,poroelastic, &
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
b_accelw_poroelastic,b_velocw_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, &
+ jacobian,source_time_function,sourcearray,adj_sourcearrays,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, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu2,N_SLS, &
rx_viscous,rz_viscous,theta_e,theta_s,&
b_viscodampx,b_viscodampz,&
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,&
+ C_k,M_k,NSOURCE,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,NSOURCE)
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax)
+
if(save_forward .and. isolver == 1) then
+! if inviscid fluid, comment
write(23,rec=it) b_viscodampx
write(24,rec=it) b_viscodampz
endif
@@ -4886,11 +5463,114 @@
endif ! if(anyabs .and. save_forward .and. isolver == 1)
- endif ! if(any_poroelastic)
+ endif !if(any_poroelastic) then
+! *********************************************************
+! ************* 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 poroelastic parameters
+ 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
+
+! compute pressure on the fluid/porous medium edge
+ pressure = - potential_dot_dot_acoustic(iglob)
+ if(isolver == 2) then
+ b_pressure = - b_potential_dot_dot_acoustic(iglob)
+ endif
+
+! get point values for the poroelastic side
+ ii2 = ivalue(ipoin1D,iedge_poroelastic)
+ jj2 = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(ii2,jj2,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 == 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
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic == IBOTTOM)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
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic ==ILEFT)then
+ 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
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_acoustic ==IRIGHT)then
+ 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
+ weight = jacobian1D * wzgll(j)
+ endif
+
+! 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)
+
+ if(isolver == 2) then
+! contribution to the solid phase
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-phil/tortl)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-phil/tortl)
+
+! contribution to the fluid phase
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+ endif !if(isolver == 2) then
+
+ enddo ! do ipoin1D = 1,NGLLX
+
+ enddo ! do inum = 1,num_fluid_poro_edges
+
+ endif ! if(coupled_acoustic_poroelastic)
+
! ****************************************************************************
! ************* add coupling with the elastic side
! ****************************************************************************
+
if(coupled_elastic_poroelastic) then
! loop on all the coupling edges
@@ -4947,6 +5627,7 @@
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)
+
if(isolver == 2) then
b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
b_duz_dxi = b_duz_dxi + b_displ_elastic(2,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
@@ -4966,6 +5647,7 @@
duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
duz_dzl = duz_dxi*xizl + duz_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
@@ -4973,18 +5655,27 @@
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
+! 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
+! full anisotropy
+ if(TURN_ANISOTROPY_ON) then
+! 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
+ sigma_xz = c15val*dux_dxl + c55val*(duz_dxl + dux_dzl) + c35val*duz_dzl
+ endif
+
if(isolver == 2) then
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 ! if(isolver == 2)
+
! get point values for the poroelastic side
i = ivalue(ipoin1D,iedge_poroelastic)
j = jvalue(ipoin1D,iedge_poroelastic)
@@ -4995,30 +5686,30 @@
! 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 == ITOP)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ 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_acoustic == IBOTTOM)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ 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_acoustic ==ILEFT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ 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_acoustic ==IRIGHT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ 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
@@ -5026,309 +5717,127 @@
endif
! contribution to the solid phase
- if(valence_poroelastic(iglob) /= valence_elastic(iglob)) then
accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + &
- weight*(sigma_xx*nx + sigma_xz*nz)*(1._CUSTOM_REAL - phil/tortl )*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
-
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + &
- weight*(sigma_xz*nx + sigma_zz*nz)*(1._CUSTOM_REAL - phil/tortl )*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- else
- 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 )
- endif
! contribution to the fluid phase
- if(valence_poroelastic(iglob) /= valence_elastic(iglob)) then
accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - &
- weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(sigma_xx*nx+sigma_xz*nz)* &
- valence_poroelastic(iglob)/2._CUSTOM_REAL
-
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - &
- weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(sigma_xz*nx+sigma_zz*nz)* &
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- else
- 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)
- endif
if(isolver == 2) then
! contribution to the solid phase
- if(valence_poroelastic(iglob) /= valence_elastic(iglob)) then
b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + &
- weight*(b_sigma_xx*nx + b_sigma_xz*nz)*(1._CUSTOM_REAL - phil/tortl)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
-
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + &
- weight*(b_sigma_xz*nx + b_sigma_zz*nz)*(1._CUSTOM_REAL - phil/tortl)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- else
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + &
weight*(b_sigma_xx*nx + b_sigma_xz*nz)*(1._CUSTOM_REAL - phil/tortl)
-
b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + &
weight*(b_sigma_xz*nx + b_sigma_zz*nz)*(1._CUSTOM_REAL - phil/tortl)
- endif
! contribution to the fluid phase
- if(valence_poroelastic(iglob) /= valence_elastic(iglob)) then
b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
- weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(b_sigma_xx*nx + b_sigma_xz*nz)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
-
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
- weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(b_sigma_xz*nx + b_sigma_zz*nz)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- else
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(b_sigma_xx*nx + b_sigma_xz*nz)
b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(b_sigma_xz*nx + b_sigma_zz*nz)
- endif
endif !if(isolver == 2) then
+
enddo
-
+
enddo
- endif
+ endif ! if(coupled_elastic_poroelastic)
-! *********************************************************
-! ************* add coupling with the acoustic side
-! *********************************************************
- if(coupled_acoustic_poroelastic) then
+! assembling accels_proelastic & accelw_poroelastic for poroelastic elements
+#ifdef USE_MPI
+ if (nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0) then
+ call assemble_MPI_vector_po(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, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
+ my_neighbours)
+ endif
+#endif
-! 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)
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+ if(any_poroelastic) then
-! 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)
+! --- add the source if it is a collocated force
+ if(.not. initialfield) then
-! 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
+ do i_source=1,NSOURCE
+! if this processor carries the source and the source element is elastic
+ if (is_proc_source(i_source) == 1 .and. poroelastic(ispec_selected_source(i_source))) then
-! 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
+ phil = porosity(kmato(ispec_selected_source(i_source)))
+ tortl = tortuosity(kmato(ispec_selected_source(i_source)))
+ rhol_s = density(1,kmato(ispec_selected_source(i_source)))
+ rhol_f = density(2,kmato(ispec_selected_source(i_source)))
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-! get point values for the poroelastic side
- i = ivalue(ipoin1D,iedge_poroelastic)
- j = jvalue(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
+! collocated force
+ if(source_type(i_source) == 1) then
+ if(isolver == 1) then ! forward wavefield
+! s
+ accels_poroelastic(1,iglob_source(i_source)) = accels_poroelastic(1,iglob_source(i_source)) - &
+ (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,it)
+ accels_poroelastic(2,iglob_source(i_source)) = accels_poroelastic(2,iglob_source(i_source)) + &
+ (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,it)
+! w
+ accelw_poroelastic(1,iglob_source(i_source)) = accelw_poroelastic(1,iglob_source(i_source)) - &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,it)
+ accelw_poroelastic(2,iglob_source(i_source)) = accelw_poroelastic(2,iglob_source(i_source)) + &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,it)
-! 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 == 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
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic == IBOTTOM)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
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic ==ILEFT)then
- 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
- weight = jacobian1D * wzgll(j)
- elseif(iedge_acoustic ==IRIGHT)then
- 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
- weight = jacobian1D * wzgll(j)
- endif
-
-! contribution to the solid phase
- if(valence_acoustic(iglob) /= valence_poroelastic(iglob)) then
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + weight*nx*pressure*(1._CUSTOM_REAL-phil/tortl)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + weight*nz*pressure*(1._CUSTOM_REAL-phil/tortl)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- else
- 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)
+ else ! backward wavefield
+! b_s
+ b_accels_poroelastic(1,iglob_source(i_source)) = b_accels_poroelastic(1,iglob_source(i_source)) - &
+ (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ b_accels_poroelastic(2,iglob_source(i_source)) = b_accels_poroelastic(2,iglob_source(i_source)) + &
+ (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+!b_w
+ b_accelw_poroelastic(1,iglob_source(i_source)) = b_accelw_poroelastic(1,iglob_source(i_source)) - &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob_source(i_source)) = b_accelw_poroelastic(2,iglob_source(i_source)) + &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ endif !endif isolver == 1
endif
-! contribution to the fluid phase
- if(valence_acoustic(iglob) /= valence_poroelastic(iglob)) then
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) + weight*nx*pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + weight*nz*pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- else
- 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)
- endif
+ endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCE
- if(isolver == 2) then
-! contribution to the solid phase
- if(valence_acoustic(iglob) /= valence_poroelastic(iglob)) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-phil/tortl)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-phil/tortl)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- else
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-phil/tortl)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-phil/tortl)
- endif
+ endif ! if not using an initial field
-! contribution to the fluid phase
- if(valence_acoustic(iglob) /= valence_poroelastic(iglob)) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)*&
- valence_poroelastic(iglob)/2._CUSTOM_REAL
- else
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
- endif
- endif !if(isolver == 2) then
- 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,TURN_VISCATTENUATION_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_velocw_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, &
- rx_viscous,rz_viscous,theta_e,theta_s,&
- b_viscodampx,b_viscodampz,&
- 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,NSOURCE)
-
- 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,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,poroelastic, &
- accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
- b_accelw_poroelastic,b_velocw_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, &
- rx_viscous,rz_viscous,theta_e,theta_s,&
- b_viscodampx,b_viscodampz,&
- 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,NSOURCE)
-
- 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
@@ -5338,38 +5847,37 @@
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)
+ 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)
+ 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)
+ 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,poroelastcoef,density, &
- porosity,tortuosity,&
+ call compute_energy(displ_elastic,veloc_elastic,displs_poroelastic,velocs_poroelastic, &
+ displw_poroelastic,velocw_poroelastic, &
+ xix,xiz,gammax,gammaz,jacobian,ibool,elastic,poroelastic,hprime_xx,hprime_zz, &
+ nspec,npoin,assign_external_model,it,deltat,t0(1),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(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) 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
- else
- write(IOUT,"('Time step number ',i7,' t = ',1pe12.6,' s')") it,time
+ 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 out of ',i7)") it,time,NSTEP
+ else
+ write(IOUT,"('Time step number ',i7,' t = ',1pe12.6,' s out of ',i7)") it,time,NSTEP
+ endif
+ write(IOUT,*) 'We have done ',sngl(100.d0*dble(it-1)/dble(NSTEP-1)),'% of the total'
endif
- endif
if(any_elastic_glob) then
if(any_elastic) then
@@ -5381,34 +5889,46 @@
#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 ) then
- write(IOUT,*) 'Max norm of vector field in solid = ',displnorm_all_glob
- endif
+ if (myrank == 0) write(IOUT,*) 'Max norm of vector field in solid (elastic) = ',displnorm_all_glob
! 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')
+! 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')
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
+ if (myrank == 0) write(IOUT,*) 'Max norm of vector field in solid (poroelastic) = ',displnorm_all_glob
+! 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 (poroelastic)')
+
+ if(any_poroelastic) then
+ displnorm_all = maxval(sqrt(displw_poroelastic(1,:)**2 + displw_poroelastic(2,:)**2))
+ else
+ displnorm_all = 0.d0
endif
+ displnorm_all_glob = displnorm_all
+#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 fluid (poroelastic) = ',displnorm_all_glob
! 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)')
+! 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 (poroelastic)')
endif
if(any_acoustic_glob) then
@@ -5421,55 +5941,58 @@
#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 ) then
- write(IOUT,*) 'Max absolute value of scalar field in fluid = ',displnorm_all_glob
- endif
+ if (myrank == 0) write(IOUT,*) 'Max absolute value of scalar field in fluid (acoustic) = ',displnorm_all_glob
! check stability of the code in fluid, exit if unstable
- if(displnorm_all_glob > STABILITY_THRESHOLD) call exit_MPI('code became unstable and blew up in fluid')
+! 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')
endif
- if ( myrank == 0 ) then
- write(IOUT,*)
- endif
- endif !if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5)
+ if (myrank == 0) write(IOUT,*)
+ endif
! 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,&
- 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)
+ 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) .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,&
- 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
+ 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,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,velocs_poroelastic, &
+ elastic,poroelastic,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,accels_poroelastic, &
+ elastic,poroelastic,xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,&
+ density,rhoext,assign_external_model)
+ endif
+ else if(seismotype == 5) then
+ call compute_curl_one_element(curl_element,displ_elastic,displs_poroelastic,elastic,poroelastic, &
+ 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
@@ -5478,19 +6001,19 @@
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) .and. .not. poroelastic(ispec) .and. seismotype /= 5) then
+ else if(.not. elastic(ispec) .and. .not. poroelastic(ispec) .and. seismotype /= 6) then
dxd = vector_field_element(1,i,j)
dzd = vector_field_element(2,i,j)
-! else if(.not. elastic(ispec) .and. .not. poroelastic(ispec) &
-! .and. save_forward) then
- else if(seismotype == 5) then
+ else if(seismotype == 6) then
dxd = potential_acoustic(iglob)
dzd = ZERO
@@ -5525,26 +6048,40 @@
dzd = accel_elastic(2,iglob)
endif
+ else if(seismotype == 5) then
+
+ if(poroelastic(ispec)) then
+ dxd = displs_poroelastic(1,iglob)
+ dzd = displs_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
+ dxd = displ_elastic(1,iglob)
+ dzd = displ_elastic(2,iglob)
+ endif
+ dcurld = curl_element(i,j)
+
endif
! compute interpolated field
valux = valux + dxd*hlagrange
valuz = valuz + dzd*hlagrange
+ valcurl = valcurl + dcurld*hlagrange
enddo
enddo
! rotate seismogram components if needed, except if recording pressure, which is a scalar
- if(seismotype /= 4 .and. seismotype /= 5) then
- sisux(seismo_current,irecloc) = cosrot*valux + sinrot*valuz
- sisuz(seismo_current,irecloc) = - sinrot*valux + cosrot*valuz
+ if(seismotype /= 4 .and. seismotype /= 6) then
+ sisux(seismo_current,irecloc) = cosrot_irec(irecloc)*valux + sinrot_irec(irecloc)*valuz
+ sisuz(seismo_current,irecloc) = - sinrot_irec(irecloc)*valux + cosrot_irec(irecloc)*valuz
else
sisux(seismo_current,irecloc) = valux
sisuz(seismo_current,irecloc) = ZERO
endif
+ siscurl(seismo_current,irecloc) = valcurl
- enddo
+ enddo
+
!
!----- ecriture des kernels
!
@@ -5558,7 +6095,7 @@
do k = 1, NGLLZ
do i = 1, NGLLX
iglob = ibool(i,k,ispec)
- kappal_ac_global(iglob) = poroelastcoef(1,2,kmato(ispec))
+ kappal_ac_global(iglob) = poroelastcoef(1,2,kmato(ispec))
rhol_ac_global(iglob) = density(2,kmato(ispec))
enddo
enddo
@@ -5569,18 +6106,13 @@
rho_ac_kl(iglob) = rho_ac_kl(iglob) - rhol_ac_global(iglob) * rho_ac_k(iglob) * deltat
kappa_ac_kl(iglob) = kappa_ac_kl(iglob) - kappal_ac_global(iglob) * kappa_ac_k(iglob) * deltat
!
- rhop_ac_kl(iglob) = rho_ac_kl(iglob) + kappa_ac_kl(iglob)
+ rhop_ac_kl(iglob) = rho_ac_kl(iglob) + kappa_ac_kl(iglob)
alpha_ac_kl(iglob) = TWO * kappa_ac_kl(iglob)
enddo
+
endif !if(any_acoustic)
if(any_elastic) then
- rhopmin = 99999
- rhopmax = -99999
- alphamin = 99999
- alphamax = -99999
- betamin = 99999
- betamax = -99999
do ispec = 1, nspec
if(elastic(ispec)) then
@@ -5595,9 +6127,6 @@
endif
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
@@ -5608,18 +6137,7 @@
/ (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)
@@ -5646,9 +6164,6 @@
endif
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)
@@ -5768,11 +6283,8 @@
dd1**2 )*Cb_kl(iglob)
enddo
-! enddo
-! enddo
+ endif ! if(any_poroelastic)
- endif ! if(any_poroelastic)
-
endif ! if(isolver == 2)
!
@@ -5791,8 +6303,8 @@
endif
if(any_acoustic) then
- write(filename,'(a,i7.7)') 'OUTPUT_FILES/snapshot_rho_kappa',it
- write(filename2,'(a,i7.7)') 'OUTPUT_FILES/snapshot_rhop_c',it
+ write(filename,'(a,i7.7)') 'OUTPUT_FILES/snapshot_rho_kappa_',it
+ write(filename2,'(a,i7.7)') 'OUTPUT_FILES/snapshot_rhop_c_',it
open(unit = 97, file = trim(filename),status = 'unknown',iostat=ios)
if (ios /= 0) stop 'Error writing snapshot to disk'
@@ -5810,8 +6322,8 @@
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
+ 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'
@@ -5819,20 +6331,19 @@
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,:))
+ 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
+ enddo
close(97)
close(98)
endif
if(any_poroelastic) then
- write(filename,'(a,i7.7)') 'OUTPUT_FILES/snapshot_mu_B_C_',it
-
+! Primary kernels
+ 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)
@@ -5843,16 +6354,13 @@
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
-
+! Wavespeed kernels
+! write(filename,'(a,i7.7)') 'OUTPUT_FILES/snapshot_cpI_cpII_cs_',it
! write(filename2,'(a,i7.7)') 'OUTPUT_FILES/snapshot_rhobb_rhofbb_ratio_',it
-
! write(filename3,'(a,i7.7)') 'OUTPUT_FILES/snapshot_phib_eta_',it
- write(filename,'(a,i7.7)') 'OUTPUT_FILES/snapshot_mub_Bb_Cb_',it
-
+! Density normalized kernels
+ write(filename,'(a,i7.7)') 'OUTPUT_FILES/snapshot_mub_Bb_Cb_',it
write(filename2,'(a,i7.7)') 'OUTPUT_FILES/snapshot_Mb_rhob_rhofb_',it
-
write(filename3,'(a,i7.7)') 'OUTPUT_FILES/snapshot_mb_etab_',it
open(unit = 17, file = trim(filename),status = 'unknown',iostat=ios)
@@ -5865,8 +6373,8 @@
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,:))
+ 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)
@@ -5876,7 +6384,7 @@
! 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),ratio_kl(iglob)
! write(19,'(5e12.3)')xx,zz,phib_kl(iglob),eta_kl(iglob)
- enddo
+ enddo
close(97)
close(98)
close(99)
@@ -5892,138 +6400,164 @@
!
if(output_postscript_snapshot) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'Writing PostScript file'
- endif
+ if (myrank == 0) write(IOUT,*) 'Writing PostScript file'
if(imagetype == 1) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'drawing displacement vector as small arrows...'
- endif
+ if (myrank == 0) write(IOUT,*) 'drawing displacement vector as small arrows...'
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)
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
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,porosity,tortuosity,poroelastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs, &
- nelem_acoustic_surface, acoustic_edges, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCE, &
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)
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poroelastic,coupled_elastic_poroelastic, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,&
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier,&
+ d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model,d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
+ coorg_send_ps_velocity_model,RGB_send_ps_velocity_model,coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model, &
+ d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh,d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
+ coorg_send_ps_element_mesh,color_send_ps_element_mesh,coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
+ d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
+ coorg_send_ps_abs,coorg_recv_ps_abs, &
+ d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface,d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
+ coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
+ d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field,d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
+ coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
else if(imagetype == 2) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'drawing velocity vector as small arrows...'
- endif
+ if (myrank == 0) write(IOUT,*) 'drawing velocity vector as small arrows...'
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)
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
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,porosity,tortuosity,poroelastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs, &
- nelem_acoustic_surface, acoustic_edges, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCE, &
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)
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poroelastic,coupled_elastic_poroelastic, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,&
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier,&
+ d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model,d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
+ coorg_send_ps_velocity_model,RGB_send_ps_velocity_model,coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model, &
+ d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh,d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
+ coorg_send_ps_element_mesh,color_send_ps_element_mesh,coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
+ d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
+ coorg_send_ps_abs,coorg_recv_ps_abs, &
+ d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface,d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
+ coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
+ d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field,d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
+ coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
else if(imagetype == 3) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'drawing acceleration vector as small arrows...'
- endif
+ if (myrank == 0) write(IOUT,*) 'drawing acceleration vector as small arrows...'
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)
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
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,porosity,tortuosity,poroelastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs, &
- nelem_acoustic_surface, acoustic_edges, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCE, &
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, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poroelastic,coupled_elastic_poroelastic, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
- myrank, nproc)
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier,&
+ d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model,d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
+ coorg_send_ps_velocity_model,RGB_send_ps_velocity_model,coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model, &
+ d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh,d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
+ coorg_send_ps_element_mesh,color_send_ps_element_mesh,coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
+ d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
+ coorg_send_ps_abs,coorg_recv_ps_abs, &
+ d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface,d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
+ coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
+ d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field,d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
+ coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
else if(imagetype == 4) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'cannot draw scalar pressure field as a vector plot, skipping...'
- endif
+ if (myrank == 0) write(IOUT,*) 'cannot draw scalar pressure field as a vector plot, skipping...'
else
call exit_MPI('wrong type for snapshots')
endif
- if ( myrank == 0 ) then
- if(imagetype /= 4) write(IOUT,*) 'PostScript file written'
+ if (myrank == 0 .and. imagetype /= 4) write(IOUT,*) 'PostScript file written'
+
endif
- endif ! if(output_postscript_snapshot)
-
!
!---- display color image
!
if(output_color_image) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color
- endif
+ if (myrank == 0) write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color
if(imagetype == 1) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'drawing image of vertical component of displacement vector...'
- endif
+ if (myrank == 0) write(IOUT,*) 'drawing image of vertical component of displacement vector...'
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)
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
else if(imagetype == 2) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'drawing image of vertical component of velocity vector...'
- endif
+ if (myrank == 0) write(IOUT,*) 'drawing image of vertical component of velocity vector...'
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)
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
else if(imagetype == 3) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'drawing image of vertical component of acceleration vector...'
- endif
+ if (myrank == 0) write(IOUT,*) 'drawing image of vertical component of acceleration vector...'
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)
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
else if(imagetype == 4) then
- if ( myrank == 0 ) then
- write(IOUT,*) 'drawing image of pressure field...'
- endif
+ if (myrank == 0) write(IOUT,*) 'drawing image of pressure field...'
- call compute_pressure_whole_medium(b_potential_dot_dot_acoustic,displ_elastic,&
+ 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,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,e1,e11, &
@@ -6039,15 +6573,14 @@
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))
- end do
+ enddo
! 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)
@@ -6055,38 +6588,36 @@
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)
- end if
- end if
+ endif
+ endif
#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 ! if(output_color_image)
+ endif
!---- save temporary or final seismograms
- call write_seismograms(sisux,sisuz,station_name,network_name,NSTEP, &
+! suppress seismograms if we generate traces of the run for analysis with "ParaVer", because time consuming
+ if(.not. GENERATE_PARAVER_TRACES) call write_seismograms(sisux,sisuz,siscurl,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
@@ -6107,18 +6638,29 @@
ihours = int_tCPU / 3600
iminutes = (int_tCPU - 3600*ihours) / 60
iseconds = int_tCPU - 3600*ihours - 60*iminutes
- if ( myrank == 0 ) then
- write(*,*) 'Elapsed time in seconds = ',tCPU
- write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
- write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
- write(*,*)
+ if (myrank == 0) then
+ write(IOUT,*) 'Elapsed time in seconds = ',tCPU
+ write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(IOUT,*)
endif
- endif ! if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP)
+ endif
+#ifdef USE_MPI
+! add a barrier if we generate traces of the run for analysis with "ParaVer"
+ if(GENERATE_PARAVER_TRACES) call MPI_BARRIER(MPI_COMM_WORLD,ier)
+#endif
+
enddo ! end of the main time loop
if((save_forward .and. isolver==1) .or. isolver ==2) then
+ if(any_acoustic) then
+ close(65)
+ close(66)
+ close(67)
+ close(68)
+ endif
if(any_elastic) then
close(35)
close(36)
@@ -6190,8 +6732,24 @@
close(55)
endif
+
+ deallocate(v0x_left)
+ deallocate(v0z_left)
+ deallocate(t0x_left)
+ deallocate(t0z_left)
+
+ deallocate(v0x_right)
+ deallocate(v0z_right)
+ deallocate(t0x_right)
+ deallocate(t0z_right)
+
+ deallocate(v0x_bot)
+ deallocate(v0z_bot)
+ deallocate(t0x_bot)
+ deallocate(t0z_bot)
+
!---- close energy file and create a gnuplot script to display it
- if(OUTPUT_ENERGY) then
+ if(OUTPUT_ENERGY .and. myrank == 0) then
close(IENERGY)
open(unit=IENERGY,file='plotenergy',status='unknown')
write(IENERGY,*) 'set term postscript landscape color solid "Helvetica" 22'
@@ -6203,9 +6761,7 @@
endif
! print exit banner
- if ( myrank == 0 ) then
- call datim(simulation_title)
- endif
+ if (myrank == 0) call datim(simulation_title)
!
!---- close output file
@@ -6289,42 +6845,75 @@
'Mzz. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
'Mxz. . . . . . . . . . . . . . . . . . =',1pe20.10)
-end program specfem2D
+ end program specfem2D
+subroutine tri_quad(n, n1, nnodes)
-subroutine is_in_convex_quadrilateral ( elmnt_coords, x_coord, z_coord, is_in)
+ implicit none
- implicit none
+ integer :: n1, nnodes
+ integer, dimension(4) :: n
- 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
+ n(2) = n1
+ if ( n1 == 1 ) then
+ n(1) = nnodes
+ else
+ n(1) = n1-1
+ endif
- 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)
+ if ( n1 == nnodes ) then
+ n(3) = 1
+ else
+ n(3) = n1+1
+ endif
- 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 ( n(3) == nnodes ) then
+ n(4) = 1
+ else
+ n(4) = n(3)+1
+ endif
- if ( (normal1 < 0) .or. (normal2 < 0) .or. (normal3 < 0) .or. (normal4 < 0) ) then
- is_in = .false.
- else
- is_in = .true.
- end if
+end subroutine tri_quad
-end subroutine is_in_convex_quadrilateral
+subroutine calcul_normale( angle, n1_x, n2_x, n3_x, n4_x, n1_z, n2_z, n3_z, n4_z )
+
+ implicit none
+
+ include 'constants.h'
+
+ double precision :: angle
+ double precision :: n1_x, n2_x, n3_x, n4_x, n1_z, n2_z, n3_z, n4_z
+
+ double precision :: theta1, theta2, theta3
+ double precision :: costheta1, costheta2, costheta3
+
+ if ( abs(n2_z - n1_z) < TINYVAL ) then
+ costheta1 = 0
+ else
+ costheta1 = (n2_z - n1_z) / sqrt((n2_x - n1_x)**2 + (n2_z - n1_z)**2)
+ endif
+ if ( abs(n3_z - n2_z) < TINYVAL ) then
+ costheta2 = 0
+ else
+ costheta2 = (n3_z - n2_z) / sqrt((n3_x - n2_x)**2 + (n3_z - n2_z)**2)
+ endif
+ if ( abs(n4_z - n3_z) < TINYVAL ) then
+ costheta3 = 0
+ else
+ costheta3 = (n4_z - n3_z) / sqrt((n4_x - n3_x)**2 + (n4_z - n3_z)**2)
+ endif
+
+ theta1 = - sign(1.d0,n2_x - n1_x) * acos(costheta1)
+ theta2 = - sign(1.d0,n3_x - n2_x) * acos(costheta2)
+ theta3 = - sign(1.d0,n4_x - n3_x) * acos(costheta3)
+
+
+ angle = angle + ( theta1 + theta2 + theta3 ) / 3.d0 + PI/2.d0
+ !angle = theta2
+
+end subroutine calcul_normale
Modified: seismo/2D/SPECFEM2D/branches/BIOT/spline_routines.f90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/spline_routines.f90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/spline_routines.f90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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/todo_list_please_dont_remove.txt
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/todo_list_please_dont_remove.txt 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/todo_list_please_dont_remove.txt 2009-07-30 21:33:24 UTC (rev 15488)
@@ -1,23 +1,28 @@
-- in the case of MPI runs, we should add a routine to check that the graph sent to Cuthill-McKee is not disconnected; otherwise the routine fails
+The main developers of SPECFEM2D are:
-- in the case of MPI runs, Nicolas's code displays a lot of things coming from
-different processors to the screen; this should be fixed, and only the master
-(myrank == 0) should write to the screen
+ 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
-- in createnum_fast.f90 we should replace the heuristic computation of the minimum
-threshold distance:
-!
-! compute the minimum typical "size" of an element in the mesh
- xtypdist = min(xtypdist,xmaxval-xminval)
- xtypdist = min(xtypdist,ymaxval-yminval)
-!
-with a more general algorithm based on the actual distance (i.e., using sqrt()
-instead of an estimate of the horizontal and vertical sizes only; because otherwise
-very distorted elements may lead to erroneous results)
+For more details on how to use this code, users can also refer to the manuals
+of the 3D versions (SPECFEM3D_SESAME and SPECFEM3D_GLOBE), which contain far
+more detailed descriptions of the spectral-element method.
-- splitting file part_unstruct.F90 in several files for clarity purpose.
+---------------------------
+IMPORTANT KNOWN BUG: in compute_forces_elastic.f90 the calculation of
+attenuation (viscoelasticity) is slightly incorrect because the gradients
+are computed twice but *at the same time step* instead of at different
+(staggered) time steps (t_{n-1} and t_n or something like that).
+That's easy to fix but I have no time for now. Let us fix that in the future.
+It will only make a very small difference in the final seismograms therefore
+the current code with the bug can be used without any major problem.
+
+Dimitri Komatitsch, April 28, 2009.
+
+---------------------------
+
- improving compiling with SCOTCH (issue with header file scotchf.h which is Fortran77 legal). Having our own scotchf.h file (without the comments) is not wise.
- comparing the different partitioning methods for METIS and SCOTCH, and finding a good default for SCOTCH.
@@ -26,22 +31,12 @@
- choosing a way to use assign_external_model?
-- adding comments.
-
- checking for points with different normals for absorbing conditions, when the absorbing edges are not in the same elements (similar to what is done for the corners).
-- scripts for translating GID/CUBIT meshes into files for xmeshfem2D.
+- scripts to translate GID/CUBIT meshes into files for xmeshfem2D.
-- modifying scripts for UPPA cluster (when FS sync issues are solved and remote commands are available).
+- user manual for unstructured meshes.
-- manual for unstructured meshes.
-
-- getting rid of constants_unstruct.h.
-
-- checking use of real or double precision. Gain in elapsed time is ok, but now we have to look for memory consumption.
-
-- checking output on stdout (for data that should be printed only once).
-
- Hi Jeroen, Perfect. I think talking to Jean-Paul Ampuero would be useful
as well because in Utrecht last year he had told us that
he had implemented some nice 4th-order symplectic schemes
@@ -61,3 +56,239 @@
>> simulations (e.g. multi-orbit surface waves).
>> Dimitri.
+------------------------------
+
+SOMETHING THAT COULD BE MADE MORE GENERAL:
+
+at line 770 of specfem2D.F90:
+!! DK DK if needed in the future, here the quality factor could be different for each point
+
+i.e. they could be given at each (i,j,ispec) instead of at each (ispec) only
+in the current version. Very easy to do if needed, just that line to change.
+
+Dimitri Komatitsch, April 28, 2009.
+
+------------------------------
+
+April 2009: here is the list of problems (in particular in the DATA/Par_file format)
+found by Steve Smith below. Pieyre Le Loher will fix them at some point:
+
+-------- Original Message --------
+Subject: Re: let us document the changes
+Date: Tue, 14 Apr 2009 00:11:29 +0200
+From: Nicolas Le Goff
+To: Dimitri Komatitsch
+CC: Steve Smith, Pieyre Le Loher
+
+Hi all,
+
+I will probably not have time to check it out in the next couple of
+days; I will take a look at the bug steve reported the following
+week-end, but I am not familiar with the mesh_canyon case.
+
+Steve, to bypass this bug for the time being, I would suggest generating
+the ./DATA/STATIONS file with the stations you want (with
+generate_STATIONS=true and read_external_mesh=false or else the code
+crashes) and then running the simulation (with generate_STATIONS=false
+and read_external_mesh=true).
+
+Hope this helps,
+ nicolas Le Goff
+
+Dimitri Komatitsch wrote:
+>
+> Hi Pieyre and Nicolas,
+>
+> Before Nicolas leaves could you please document the changes and update
+> all the Par_files on the SVN server? because it seems that, as mentioned
+> by Steve, some of your changes have broken compatibility with older
+> Par_files that are distributed with the SVN code, and also
+> some paragraphs of the README file are not correct anymore
+> and some options are not documented.
+> This makes it difficult for new users to understand how the code
+> should be used.
+>
+> Ronan Madec, could you please meet with Pieyre Le Loher to make sur Par_files
+are compatible with your implementation of Bielak plane waves (which should be
+turned off in the default Par_file of the SVN code)
+>
+>
+> thanks
+>
+> Dimitri.
+>
+> Steve Smith wrote:
+>> Nicolas,
+>>
+>> Thanks for your reply.
+>>
+>> From what you tell me in your previous email (below), I understand
+>> that:
+>>
+>> 1) Of all the Par_files included in the current release, *ONLY*
+>> DATA/Par_file works. None of the other Par_files/examples work
+>> with the code.
+>>
+>> 2) The only/current/functional Par_file uses modeling constructed
+>> from the interface.dat files and does not work with external grids.
+>>
+>> 3) This is due to UNDOCUMENTED CHANGES in the code - or at least
+>> documented changes that were not distributed with the current release.
+>>
+>>
+>>
+>> As you recommended, I have modified the DATA/Par_file to test/execute
+>> the Calcul Mexique Alejandro mesh.
+>>
+>> I am testing the included Calcul Mexique Alejandro mesh because I am
+>> trying to use external meshes.
+>>
+>> After extensive testing, and examination of the mesher source code, I
+>> have found - or had to modify - the following:
+>> ==================
+>> 0) initialfield and add_Bielak_conditions must BOTH be set = .true.
+>> You probably know this, and it is not a bug, but it is not
+>> set/documented in the release, and must occur for the code to run as
+>> given as seen in the publication with this example. I don't have the
+>> exact reference at the moment. Just letting you know.
+>>
+>> 1) One must set generate_STATIONS = .false. to set read_external_mesh
+>> = .true. without crashing xmeshfem2D.
+>>
+>> 2) When using generate_STATIONS = .false., xmeshfem2D runs without
+>> crashing, but specfem2D still generates 11 output seismograms (X,Z).
+>> This is odd behavior.
+>>
+>> 3) When setting read_external_mesh = .true. and generate_STATIONS =
+>> .true., xmeshfem2D crashes with the error:
+>>
+>> "At line 1368 of file meshfem2D.F90
+>> Fortran runtime error: Array reference out of bounds for array
+>> 'xinterface', upper bound of dimension 1 exceeded (1 > -1880941456)"
+>>
+>> I have attempted to trace the npoints_interface variable through
+>> meshfem2D.F90, and it appears to ONLY be set/initialized for the case
+>> where read_external_mesh = .false.
+>>
+>> However, it is used in portions of the code for station placement
+>> with or without external grids.
+>>
+>> npoints_interface is used where the mesher attempts to place any
+>> receiver external to the model at the closest border. The
+>> npoints_interface carries over for external meshes at the spline
+>> interpolation of receiver Z coordinates.
+>>
+>> I initially believed that the crash of xmeshfem2D was due to receiver
+>> line beginning/ending coordinates being outside of the mesh. Since
+>> the mesh in Mesh_canyon runs from 0 to 19 - which really should be
+>> kilometers - but the Par_file dimensions are specified in meters, I
+>> reduced the values of 800 and 900 to 8 and 9. This places them
+>> inside the dimensions of the mesh - assuming that everything is
+>> really in meters. However, this has not solved the problem.
+>> ==================
+>>
+>> I have included the Par_file, which is a modification of the
+>> DATA/Par_file included in the 5.2.2 release - as you recommended.
+>>
+>> I've tested the code on both Mac and Linux platforms.
+>>
+>> Due to the complexity of the mesher code, I believe modifying the
+>> mesher without full knowledge of how it works may lead to additional
+>> errors.
+>>
+>> Given that none of the Par_files in the release work with the
+>> exception of DATA/Par file, can anyone supply a Par_file that works
+>> with the canyon mesh files (Calcul Mexique Alejandro,
+>> DATA/Mesh_canyon/*)?
+>>
+>> Alternatively, is there an older release of the code that works with
+>> the canyon mesh or similar files?
+>>
+>> Thanks for your assistance, and I hope this information is helpful.
+>>
+>> -Steve
+>>
+>>
+>> On Apr 11, 2009, at 1:26 AM, Nicolas Le Goff wrote:
+>>
+>>> Hi Steve,
+>>>
+>>> I took a look at the Par_file you provided me; it is not consistent
+>>> with
+>>> ./DATA/Par_file in trunk.
+>>>
+>>> There were a few changes in specfem2D, and the Par_files in ./DATA are
+>>> no longer consistent with the latest version of specfem2D except for
+>>> ./DATA/Par_file. The changes are about detecting the normal and tangent
+>>> for receivers and source (the tangential_detection_curve_file need not
+>>> be provided if force_normal_to_surface and recv_normal_to_surface are
+>>> both set to false). I suggest modifying the ./DATA/Par_file and see if
+>>> it works.
+>>>
+>>> Kind regards,
+>>> nicolas
+>>>
+>>>
+>>> Steve Smith wrote:
+>>>> Nicolas,
+>>>>
+>>>> I have written code that converts an ELMERGRID translation of a COMSOL
+>>>> mesh to the format of the SPECFEM2D files - following the
+>>>> DATA/Mesh_canyon files. I also have a program that reads the SPECFEM2D
+>>>> format files (like DATA/Mesh_canyon/*) and plots the mesh.
+>>>>
+>>>> However, when trying my mesh files, XMESHFEM2D crashes. I suspect that
+>>>> there are F90 file output formatting specifications I have not
+>>>> reproduced accurately in my mesh file translations.
+>>>>
+>>>> ===== SPECFEM2D-5.2.2 XMESHFEM2D ERRORS
+>>>> =======================================
+>>>> .../SPECFEM2D-5.2.2> rm -rf OUTPUT_FILES/* ; ./xmeshfem2D ;
+>>>> /bin/rm: No match.
+>>>> Reading the parameter file ...
+>>>>
+>>>> Title of the simulation
+>>>> TEST RESERVOIR
+>>>>
+>>>> ./DATA/TEST_MODEL/reservoir_mesh_file
+>>>> forrtl: severe (59): list-directed I/O syntax error, unit -5, file
+>>>> Internal List
+>>>> -Directed Read
+>>>> Image PC Routine Line
+>>>> Source
+>>>>
+>>>> xmeshfem2D 00000000004864F6 Unknown Unknown
+>>>> Unknown
+>>>> xmeshfem2D 0000000000485488 Unknown Unknown
+>>>> Unknown
+>>>> xmeshfem2D 000000000044F9C2 Unknown Unknown
+>>>> Unknown
+>>>> xmeshfem2D 000000000041F4E9 Unknown Unknown
+>>>> Unknown
+>>>> xmeshfem2D 000000000041EDD6 Unknown Unknown
+>>>> Unknown
+>>>> xmeshfem2D 000000000042F4C5 Unknown Unknown
+>>>> Unknown
+>>>> xmeshfem2D 000000000042E539 Unknown Unknown
+>>>> Unknown
+>>>> xmeshfem2D 000000000041C1CE Unknown Unknown
+>>>> Unknown
+>>>> xmeshfem2D 000000000040DFE7 Unknown Unknown
+>>>> Unknown
+>>>> xmeshfem2D 0000000000402A96 Unknown Unknown
+>>>> Unknown
+>>>> ===== SPECFEM2D-5.2.2 XMESHFEM2D ERRORS
+>>>> =======================================
+>>>>
+>>>> Can you advise? Should I send this to the group mailing list?
+>>>>
+>>>> I include my Par_file, define_external_model.f90, my mesh files, and
+>>>> a visualization of the mesh translated so tat the lower left corner is
+>>>> at the origin.
+>>>>
+>>>> Thanks,
+>>>>
+>>>> -Steve Smith
+>>>> CSM/CWP
+>>>>
+
Modified: seismo/2D/SPECFEM2D/branches/BIOT/write_seismograms.F90
===================================================================
--- seismo/2D/SPECFEM2D/branches/BIOT/write_seismograms.F90 2009-07-30 16:49:54 UTC (rev 15487)
+++ seismo/2D/SPECFEM2D/branches/BIOT/write_seismograms.F90 2009-07-30 21:33:24 UTC (rev 15488)
@@ -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 and CNRS, France.
+! Copyright Universite de Pau et des Pays de l'Adour, CNRS and INRIA, 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,station_name,network_name, &
+ subroutine write_seismograms(sisux,sisuz,siscurl,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,11 +58,10 @@
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
+ double precision, dimension(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc), intent(in) :: sisux,sisuz,siscurl
double precision st_xval(nrec)
@@ -100,16 +99,20 @@
component = 'v'
else if(seismotype == 3) then
component = 'a'
- else if(seismotype == 4 .or. seismotype == 5) then
+ 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
! only one seismogram if pressurs
- if(seismotype == 4 .or. seismotype == 5) then
+ if(seismotype == 4) then
number_of_components = 1
+ else if(seismotype == 5) then
+ number_of_components = NDIM+1
else
number_of_components = NDIM
endif
@@ -138,30 +141,43 @@
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
! write the new files
- if(seismotype == 4 .or. seismotype == 5) then
+ if(seismotype == 4) then
open(unit=12,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown',access='direct',recl=4)
else
open(unit=12,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown',access='direct',recl=4)
endif
- if(seismotype == 4 .or. seismotype == 5) then
+ if(seismotype == 4) then
open(unit=13,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown',access='direct',recl=8)
else
open(unit=13,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown',access='direct',recl=8)
endif
! no Z component seismogram if pressure
- if(seismotype /= 4 .and. seismotype /= 5) then
+ 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
@@ -175,6 +191,9 @@
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
@@ -185,6 +204,12 @@
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
@@ -197,12 +222,14 @@
chn = 'BHX'
else if(iorientation == 2) then
chn = 'BHZ'
+ else if(iorientation == 3) then
+ chn = 'cur'
else
call exit_MPI('incorrect channel value')
endif
! in case of pressure, use different abbreviation
- if(seismotype == 4 .or. seismotype == 5) chn = 'PRE'
+ if(seismotype == 4) chn = 'PRE'
! create the name of the seismogram file for each slice
! file name includes the name of the station, the network and the component
@@ -248,10 +275,14 @@
do isample = 1, seismo_current
write(12,rec=(irec-1)*NSTEP+seismo_offset+isample) sngl(buffer_binary(isample,1))
write(13,rec=(irec-1)*NSTEP+seismo_offset+isample) buffer_binary(isample,1)
- if ( seismotype /= 4 .and. seismotype /= 5) then
+ if ( seismotype /= 4 ) then
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
@@ -259,9 +290,12 @@
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
@@ -272,10 +306,14 @@
close(12)
close(13)
- if ( seismotype /= 4 .and. seismotype /= 5) then
+ if ( seismotype /= 4 ) then
close(14)
close(15)
end if
+ if ( seismotype == 5 ) then
+ close(16)
+ close(17)
+ end if
!----
More information about the CIG-COMMITS
mailing list