[cig-commits] r17998 - in seismo/2D/SPECFEM2D/trunk: . DATA UTILS m4 src src/meshfem2D src/shared src/specfem2D
danielpeter at geodynamics.org
danielpeter at geodynamics.org
Tue Mar 1 12:59:46 PST 2011
Author: danielpeter
Date: 2011-03-01 12:59:44 -0800 (Tue, 01 Mar 2011)
New Revision: 17998
Added:
seismo/2D/SPECFEM2D/trunk/UTILS/convolve_source_timefunction.csh
seismo/2D/SPECFEM2D/trunk/configure.ac
seismo/2D/SPECFEM2D/trunk/m4/
seismo/2D/SPECFEM2D/trunk/m4/ac_pkg_swig.m4
seismo/2D/SPECFEM2D/trunk/m4/cit_fortran.m4
seismo/2D/SPECFEM2D/trunk/m4/cit_funcstring.m4
seismo/2D/SPECFEM2D/trunk/m4/cit_hdf.m4
seismo/2D/SPECFEM2D/trunk/m4/cit_mpi.m4
seismo/2D/SPECFEM2D/trunk/m4/cit_numpy.m4
seismo/2D/SPECFEM2D/trunk/m4/cit_petsc.m4
seismo/2D/SPECFEM2D/trunk/m4/cit_python.m4
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/Makefile.in
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/get_node_number.f90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/meshfem2D.F90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/part_unstruct.F90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_interfaces_file.f90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_materials.f90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_parameter_file.F90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_regions.f90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_source_file.f90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_databases.f90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_gnuplot_file.f90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_stations_file.f90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D/spline_routines.f90
seismo/2D/SPECFEM2D/trunk/src/shared/
seismo/2D/SPECFEM2D/trunk/src/shared/adj_seismogram.f90
seismo/2D/SPECFEM2D/trunk/src/shared/check_quality_external_mesh.f90
seismo/2D/SPECFEM2D/trunk/src/shared/convolve_source_timefunction.f90
seismo/2D/SPECFEM2D/trunk/src/shared/read_value_parameters.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/
seismo/2D/SPECFEM2D/trunk/src/specfem2D/Makefile.in
seismo/2D/SPECFEM2D/trunk/src/specfem2D/assemble_MPI.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/attenuation_compute_param.c
seismo/2D/SPECFEM2D/trunk/src/specfem2D/attenuation_model.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/calendar.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/check_stability.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/checkgrid.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_Bielak_conditions.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_arrays_source.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_curl_one_element.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_energy.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_acoustic.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_poro_fluid.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_poro_solid.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_viscoelastic.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_gradient_attenuation.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_normal_vector.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_pressure.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_vector_field.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/construct_acoustic_surface.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/convert_time.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/create_color_image.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/createnum_fast.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/createnum_slow.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/datim.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_derivation_matrices.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_external_model.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_shape_functions.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/enforce_acoustic_free_surface.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/exit_mpi.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_MPI.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_perm_cuthill_mckee.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_poroelastic_velocities.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/gll_library.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/gmat01.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/include_for_periodic_conditions.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/initialize_simulation.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/invert_mass_matrix.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/is_in_convex_quadrilateral.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/lagrange_poly.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_receivers.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_source_force.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_source_moment_tensor.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/netlib_specfun_erf.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/paco_beyond_critical.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/paco_convolve_fft.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/plotgll.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/plotpost.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_absorb.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_assemble_MPI.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_color_image.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_initialfield.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_source_time_function.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/read_databases.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/read_external_model.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/recompute_jacobian.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/save_openDX_jacobian.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/set_sources.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/setup_sources_receivers.f90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/sort_array_coordinates.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/specfem2D.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D/write_seismograms.F90
Removed:
seismo/2D/SPECFEM2D/trunk/DATA/Par_file
seismo/2D/SPECFEM2D/trunk/DATA/SOURCE
seismo/2D/SPECFEM2D/trunk/README_MANUAL.txt
seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.csh
seismo/2D/SPECFEM2D/trunk/obj/
seismo/2D/SPECFEM2D/trunk/src/adj_seismogram.f90
seismo/2D/SPECFEM2D/trunk/src/assemble_MPI.F90
seismo/2D/SPECFEM2D/trunk/src/attenuation_compute_param.c
seismo/2D/SPECFEM2D/trunk/src/attenuation_model.f90
seismo/2D/SPECFEM2D/trunk/src/calendar.f90
seismo/2D/SPECFEM2D/trunk/src/check_quality_external_mesh.f90
seismo/2D/SPECFEM2D/trunk/src/check_stability.F90
seismo/2D/SPECFEM2D/trunk/src/checkgrid.F90
seismo/2D/SPECFEM2D/trunk/src/compute_Bielak_conditions.f90
seismo/2D/SPECFEM2D/trunk/src/compute_arrays_source.f90
seismo/2D/SPECFEM2D/trunk/src/compute_curl_one_element.f90
seismo/2D/SPECFEM2D/trunk/src/compute_energy.f90
seismo/2D/SPECFEM2D/trunk/src/compute_forces_acoustic.f90
seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_fluid.f90
seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_solid.f90
seismo/2D/SPECFEM2D/trunk/src/compute_forces_viscoelastic.f90
seismo/2D/SPECFEM2D/trunk/src/compute_gradient_attenuation.f90
seismo/2D/SPECFEM2D/trunk/src/compute_normal_vector.f90
seismo/2D/SPECFEM2D/trunk/src/compute_pressure.f90
seismo/2D/SPECFEM2D/trunk/src/compute_vector_field.f90
seismo/2D/SPECFEM2D/trunk/src/construct_acoustic_surface.f90
seismo/2D/SPECFEM2D/trunk/src/convert_time.f90
seismo/2D/SPECFEM2D/trunk/src/convolve_source_timefunction.f90
seismo/2D/SPECFEM2D/trunk/src/create_color_image.f90
seismo/2D/SPECFEM2D/trunk/src/createnum_fast.f90
seismo/2D/SPECFEM2D/trunk/src/createnum_slow.f90
seismo/2D/SPECFEM2D/trunk/src/datim.f90
seismo/2D/SPECFEM2D/trunk/src/define_derivation_matrices.f90
seismo/2D/SPECFEM2D/trunk/src/define_external_model.f90
seismo/2D/SPECFEM2D/trunk/src/define_shape_functions.f90
seismo/2D/SPECFEM2D/trunk/src/enforce_acoustic_free_surface.f90
seismo/2D/SPECFEM2D/trunk/src/exit_mpi.F90
seismo/2D/SPECFEM2D/trunk/src/get_MPI.F90
seismo/2D/SPECFEM2D/trunk/src/get_node_number.f90
seismo/2D/SPECFEM2D/trunk/src/get_perm_cuthill_mckee.f90
seismo/2D/SPECFEM2D/trunk/src/get_poroelastic_velocities.f90
seismo/2D/SPECFEM2D/trunk/src/gll_library.f90
seismo/2D/SPECFEM2D/trunk/src/gmat01.f90
seismo/2D/SPECFEM2D/trunk/src/include_for_periodic_conditions.f90
seismo/2D/SPECFEM2D/trunk/src/initialize_simulation.F90
seismo/2D/SPECFEM2D/trunk/src/invert_mass_matrix.f90
seismo/2D/SPECFEM2D/trunk/src/is_in_convex_quadrilateral.f90
seismo/2D/SPECFEM2D/trunk/src/lagrange_poly.f90
seismo/2D/SPECFEM2D/trunk/src/locate_receivers.F90
seismo/2D/SPECFEM2D/trunk/src/locate_source_force.F90
seismo/2D/SPECFEM2D/trunk/src/locate_source_moment_tensor.F90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D.F90
seismo/2D/SPECFEM2D/trunk/src/netlib_specfun_erf.f90
seismo/2D/SPECFEM2D/trunk/src/paco_beyond_critical.f90
seismo/2D/SPECFEM2D/trunk/src/paco_convolve_fft.f90
seismo/2D/SPECFEM2D/trunk/src/part_unstruct.F90
seismo/2D/SPECFEM2D/trunk/src/plotgll.f90
seismo/2D/SPECFEM2D/trunk/src/plotpost.F90
seismo/2D/SPECFEM2D/trunk/src/prepare_absorb.f90
seismo/2D/SPECFEM2D/trunk/src/prepare_assemble_MPI.F90
seismo/2D/SPECFEM2D/trunk/src/prepare_color_image.F90
seismo/2D/SPECFEM2D/trunk/src/prepare_initialfield.F90
seismo/2D/SPECFEM2D/trunk/src/prepare_source_time_function.f90
seismo/2D/SPECFEM2D/trunk/src/read_databases.f90
seismo/2D/SPECFEM2D/trunk/src/read_external_model.f90
seismo/2D/SPECFEM2D/trunk/src/read_interfaces_file.f90
seismo/2D/SPECFEM2D/trunk/src/read_materials.f90
seismo/2D/SPECFEM2D/trunk/src/read_parameter_file.F90
seismo/2D/SPECFEM2D/trunk/src/read_regions.f90
seismo/2D/SPECFEM2D/trunk/src/read_source_file.f90
seismo/2D/SPECFEM2D/trunk/src/read_value_parameters.f90
seismo/2D/SPECFEM2D/trunk/src/recompute_jacobian.f90
seismo/2D/SPECFEM2D/trunk/src/save_databases.f90
seismo/2D/SPECFEM2D/trunk/src/save_gnuplot_file.f90
seismo/2D/SPECFEM2D/trunk/src/save_openDX_jacobian.f90
seismo/2D/SPECFEM2D/trunk/src/save_stations_file.f90
seismo/2D/SPECFEM2D/trunk/src/set_sources.f90
seismo/2D/SPECFEM2D/trunk/src/setup_sources_receivers.f90
seismo/2D/SPECFEM2D/trunk/src/sort_array_coordinates.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D.F90
seismo/2D/SPECFEM2D/trunk/src/spline_routines.f90
seismo/2D/SPECFEM2D/trunk/src/write_seismograms.F90
Modified:
seismo/2D/SPECFEM2D/trunk/Makefile.in
seismo/2D/SPECFEM2D/trunk/configure
Log:
moves source files into corresponding subdirectories for mesher and solver; updates Makefiles and configure
Deleted: seismo/2D/SPECFEM2D/trunk/DATA/Par_file
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/Par_file 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/DATA/Par_file 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,106 +0,0 @@
-
-# title of job, and file that contains interface data
-title = Test for M2 UPPA
-interfacesfile = ../EXAMPLES/M2_UPPA/interfaces_M2_UPPA_curved.dat
-
-# forward or adjoint simulation
-SIMULATION_TYPE = 1 # 1 = forward, 2 = adjoint + kernels
-SAVE_FORWARD = .false. # save the last frame, needed for adjoint simulation
-
-# data concerning mesh, when generated using third-party app (more info in README)
-read_external_mesh = .false.
-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 partitioning
-nproc = 1 # number of processes
-partitioning_method = 3 # SCOTCH = 3, ascending order (very bad idea) = 1
-
-# geometry of the model (origin lower-left corner = 0,0) and mesh description
-xmin = 0.d0 # abscissa of left side of the model
-xmax = 4000.d0 # abscissa of right side of the model
-nx = 80 # number of elements along X
-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
-assign_external_model = .false. # define external earth model or not
-READ_EXTERNAL_SEP_FILE = .false. # Read external SEP file from DATA/model_velocity.dat_input, or use routine
-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
-p_sv = .true. # set the type of calculation (P-SV or SH/membrane waves)
-
-# absorbing boundary parameters
-absorbing_conditions = .true. # absorbing boundary active or not
-absorbbottom = .true.
-absorbright = .true.
-absorbtop = .false.
-absorbleft = .true.
-
-# time step parameters
-nt = 1600 # total number of time steps
-deltat = 1.d-3 # duration of a time step
-
-# source parameters
-NSOURCES = 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
-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 = 1 # record 1=displ 2=veloc 3=accel 4=pressure
-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
-xdeb = 300. # first receiver x in meters
-zdeb = 2200. # 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_same_vertical = .true. # receivers inside the medium or at the surface
-
-# display parameters
-NTSTEP_BETWEEN_OUTPUT_INFO = 100 # display frequency in time steps
-output_postscript_snapshot = .true. # output Postscript snapshot of the results
-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
-modelvect = .false. # display velocity model on vector plots
-boundvect = .true. # display boundary conditions on plots
-interpol = .true. # interpolation of the display or not
-pointsdisp = 6 # points for interpolation of display (set to 1 for lower-left corner only)
-subsamp = 1 # subsampling of color snapshots
-sizemax_arrows = 1.d0 # maximum size of arrows on vector plots in cm
-gnuplot = .false. # generate a GNUPLOT file for the grid
-outputgrid = .false. # save the grid in a text file or not
-OUTPUT_ENERGY = .false. # compute and output acoustic and elastic energy (slows down the code significantly)
-
-# velocity and density models
-nbmodels = 4 # nb of different models
-# define models as
-# I: (model_number 1 rho Vp Vs 0 0 Qp Qs 0 0 0 0 0 0) or
-# II: (model_number 2 rho c11 c13 c15 c33 c35 c55 0 0 0 0 0 0) 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, and poroelastic models simultaneously.
-1 1 2700.d0 3000.d0 1732.051d0 0 0 9999 9999 0 0 0 0 0 0
-2 1 2500.d0 2700.d0 0 0 0 9999 9999 0 0 0 0 0 0
-3 1 2200.d0 2500.d0 1443.375d0 0 0 9999 9999 0 0 0 0 0 0
-4 1 2200.d0 2200.d0 1343.375d0 0 0 9999 9999 0 0 0 0 0 0
-# define the different regions of the model in the (nx,nz) spectral element mesh
-nbregions = 4 # nb of regions and model number for each
-1 80 1 20 1
-1 80 21 40 2
-1 80 41 60 3
-60 70 21 40 4
Deleted: seismo/2D/SPECFEM2D/trunk/DATA/SOURCE
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/SOURCE 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/DATA/SOURCE 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,13 +0,0 @@
-#source 1. The components of a moment tensor source must be given in N.m, not in dyne.cm as in the DATA/CMTSOLUTION source file of the 3D version of the code.
-source_surf = .false. # source inside the medium or at the surface
-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 = 1 # Ricker = 1, first derivative = 2, Gaussian = 3, Dirac = 4, Heaviside = 5
-f0 = 10.0 # dominant source frequency (Hz) if not Dirac or Heaviside
-tshift = 0.0 # time shift when multi sources (if one source, must be zero)
-angleforce = 0.0 # 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
Modified: seismo/2D/SPECFEM2D/trunk/Makefile.in
===================================================================
--- seismo/2D/SPECFEM2D/trunk/Makefile.in 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/Makefile.in 2011-03-01 20:59:44 UTC (rev 17998)
@@ -42,57 +42,6 @@
#
#========================================================================
-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
-
-
-# @configure_input@
-
-FC = @FC@
-FCFLAGS = #@FCFLAGS@
-
-MPIFC = @MPIFC@
-MPILIBS = @MPILIBS@
-
-FLAGS_CHECK = @FLAGS_CHECK@ -Isetup
-FLAGS_NO_CHECK = @FLAGS_NO_CHECK@ -Isetup
-
-CC = @CC@
-CPPFLAGS = @CPPFLAGS@ $(COND_MPI_CPPFLAGS)
-CFLAGS = @CFLAGS@ $(CPPFLAGS) -Isetup
-
-## serial or parallel
- at COND_MPI_TRUE@F90 = $(MPIFC) $(FCFLAGS) -DUSE_MPI -DUSE_SCOTCH -I"@SCOTCH_INCLUDEDIR@" $(MPILIBS)
- at COND_MPI_FALSE@F90 = $(FC) $(FCFLAGS)
-
-## scotch libraries
- at COND_MPI_TRUE@LIB = -L"@SCOTCH_LIBDIR@" -lscotch -lscotcherr
- at COND_MPI_FALSE@LIB =
-
-# optional: uncomment this to use more than one processor core, in which case the SCOTCH graph partitioner is needed
-#LIB = scotch_5.1.10b/lib/libscotch.a scotch_5.1.10b/lib/libscotcherr.a
-
-LINK = $(F90)
-
-## compilation directories
-## E : executables directory
-E = ./bin
-## source file directory
-S_TOP = @srcdir@
-S = @srcdir@/src
-## setup file directory
-SETUP = @srcdir@/setup
-
-
-##.PHONY: clean default all backup bak generate_databases specfem3D meshfem3D
-
####
#### targets
####
@@ -103,91 +52,11 @@
@COND_PYRE_FALSE@ specfem2D \
@COND_PYRE_FALSE@ convolve_source_timefunction \
@COND_PYRE_FALSE@ check_quality_external_mesh \
+ at COND_PYRE_FALSE@ adj_seismogram \
@COND_PYRE_FALSE@ $(EMPTY_MACRO)
+default: $(DEFAULT)
-
-OBJS_MESHFEM2D = \
- $O/get_node_number.o \
- $O/part_unstruct.o \
- $O/read_interfaces_file.o \
- $O/read_materials.o \
- $O/read_parameter_file.o \
- $O/read_regions.o \
- $O/read_source_file.o \
- $O/read_value_parameters.o \
- $O/save_databases.o \
- $O/save_gnuplot_file.o \
- $O/save_stations_file.o \
- $O/spline_routines.o \
- $O/meshfem2D.o
-
-OBJS_SPECFEM2D = \
- $O/assemble_MPI.o \
- $O/attenuation_model.o \
- $O/attenuation_compute_param.o \
- $O/calendar.o \
- $O/checkgrid.o \
- $O/check_stability.o \
- $O/compute_arrays_source.o \
- $O/compute_Bielak_conditions.o \
- $O/compute_curl_one_element.o \
- $O/compute_energy.o \
- $O/compute_forces_acoustic.o \
- $O/compute_forces_viscoelastic.o \
- $O/compute_forces_poro_solid.o \
- $O/compute_forces_poro_fluid.o \
- $O/compute_gradient_attenuation.o \
- $O/compute_normal_vector.o \
- $O/compute_pressure.o \
- $O/compute_vector_field.o \
- $O/construct_acoustic_surface.o \
- $O/convert_time.o \
- $O/create_color_image.o \
- $O/createnum_fast.o \
- $O/createnum_slow.o \
- $O/datim.o \
- $O/define_derivation_matrices.o \
- $O/define_external_model.o \
- $O/define_shape_functions.o \
- $O/enforce_acoustic_free_surface.o \
- $O/exit_mpi.o \
- $O/get_MPI.o \
- $O/get_perm_cuthill_mckee.o \
- $O/get_poroelastic_velocities.o \
- $O/gll_library.o \
- $O/gmat01.o \
- $O/initialize_simulation.o \
- $O/invert_mass_matrix.o \
- $O/is_in_convex_quadrilateral.o \
- $O/lagrange_poly.o \
- $O/locate_receivers.o \
- $O/locate_source_force.o \
- $O/locate_source_moment_tensor.o \
- $O/netlib_specfun_erf.o \
- $O/paco_beyond_critical.o \
- $O/paco_convolve_fft.o \
- $O/plotgll.o \
- $O/plotpost.o \
- $O/prepare_absorb.o \
- $O/prepare_assemble_MPI.o \
- $O/prepare_color_image.o \
- $O/prepare_initialfield.o \
- $O/prepare_source_time_function.o \
- $O/read_databases.o \
- $O/read_external_model.o \
- $O/recompute_jacobian.o \
- $O/save_openDX_jacobian.o \
- $O/set_sources.o \
- $O/setup_sources_receivers.o \
- $O/sort_array_coordinates.o \
- $O/write_seismograms.o \
- $O/specfem2D.o
-
-
-
-default: scotch $(DEFAULT)
-
all: default
required: obj bin
@@ -198,6 +67,7 @@
meshfem2D: xmeshfem2D
convolve_source_timefunction: xconvolve_source_timefunction
check_quality_external_mesh: xcheck_quality_external_mesh
+adj_seismogram: xadj_seismogram
bin:
mkdir -p bin
@@ -205,291 +75,49 @@
obj:
mkdir -p obj
-scotch:
-ifeq (@USE_BUNDLED_SCOTCH@,1)
- (echo "Using bundled Scotch")
- (cd "@SCOTCH_DIR@/src"; make)
-else
- (echo "Not using bundled Scotch")
-endif
-
-
-clean:
- (rm -rf obj bin xmeshfem2D xmeshfem2D.trace \
- xspecfem2D xspecfem2D.trace \
- $O/*.o *.o $O/*.il *.mod core \
- xconvolve_source_timefunction \
- xcheck_quality_external_mesh \
- *.oo *.ipo)
-
-
-help:
- @echo "usage: make [executable]"
- @echo ""
- @echo "supported executables:"
- @echo " xspecfem3D"
- @echo " xmeshfem3D"
- @echo " xconvolve_source_timefunction"
- @echo " xcheck_quality_external_mesh"
- @echo ""
-
##
## mesher
##
-xmeshfem2D: required $(OBJS_MESHFEM2D)
- $(LINK) $(FLAGS_CHECK) -o ${E}/xmeshfem2D $(OBJS_MESHFEM2D) $(LIB)
+xmeshfem2D: required
+ (cd src/meshfem2D; make )
##
-## solver
+## check_quality_external_mesh
##
-### use optimized compilation option for solver only
-xspecfem2D: required $(OBJS_SPECFEM2D)
- $(LINK) $(FLAGS_NO_CHECK) -o ${E}/xspecfem2D $(OBJS_SPECFEM2D)
+xcheck_quality_external_mesh: required
+ (cd src/meshfem2D ; make xcheck_quality_external_mesh)
##
-## convolve_source_timefunction
+## solver
##
-xconvolve_source_timefunction: required $O/convolve_source_timefunction.o
- ${F90} $(FLAGS_CHECK) -o ${E}/xconvolve_source_timefunction $O/convolve_source_timefunction.o
+xspecfem2D: required
+ (cd src/specfem2D; make specfem2D)
##
-## check_quality_external_mesh
+## convolve_source_timefunction
##
-xcheck_quality_external_mesh: required $O/check_quality_external_mesh.o $O/read_value_parameters.o
- ${F90} $(FLAGS_CHECK) -o ${E}/xcheck_quality_external_mesh $O/check_quality_external_mesh.o $O/read_value_parameters.o
+xconvolve_source_timefunction: required
+ (cd src/specfem2D ; make xconvolve_source_timefunction)
+
##
-## object files
+## adj_seismogram
##
-$O/checkgrid.o: ${S}/checkgrid.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/checkgrid.o ${S}/checkgrid.F90
+xadj_seismogram: required
+ (cd src/specfem2D ; make xadj_seismogram)
-$O/meshfem2D.o: ${S}/meshfem2D.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/meshfem2D.o ${S}/meshfem2D.F90
-$O/read_interfaces_file.o: ${S}/read_interfaces_file.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/read_interfaces_file.o ${S}/read_interfaces_file.f90
+clean:
+ (rm -rf obj bin src/meshfem2D/*.mod src/specfem2D/*.mod )
-$O/read_materials.o: ${S}/read_materials.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/read_materials.o ${S}/read_materials.f90
-$O/read_parameter_file.o: ${S}/read_parameter_file.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/read_parameter_file.o ${S}/read_parameter_file.F90
-
-$O/read_regions.o: ${S}/read_regions.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/read_regions.o ${S}/read_regions.f90
-
-$O/read_source_file.o: ${S}/read_source_file.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/read_source_file.o ${S}/read_source_file.f90
-
-$O/get_node_number.o: ${S}/get_node_number.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/get_node_number.o ${S}/get_node_number.f90
-
-$O/createnum_fast.o: ${S}/createnum_fast.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/createnum_fast.o ${S}/createnum_fast.f90
-
-$O/createnum_slow.o: ${S}/createnum_slow.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/createnum_slow.o ${S}/createnum_slow.f90
-
-$O/convolve_source_timefunction.o: ${S}/convolve_source_timefunction.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/convolve_source_timefunction.o ${S}/convolve_source_timefunction.f90
-
-$O/check_quality_external_mesh.o: ${S}/check_quality_external_mesh.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/check_quality_external_mesh.o ${S}/check_quality_external_mesh.f90
-
-$O/read_value_parameters.o: ${S}/read_value_parameters.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/read_value_parameters.o ${S}/read_value_parameters.f90
-
-$O/datim.o: ${S}/datim.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/datim.o ${S}/datim.f90
-
-$O/lagrange_poly.o: ${S}/lagrange_poly.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/lagrange_poly.o ${S}/lagrange_poly.f90
-
-$O/gmat01.o: ${S}/gmat01.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/gmat01.o ${S}/gmat01.f90
-
-$O/gll_library.o: ${S}/gll_library.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/gll_library.o ${S}/gll_library.f90
-
-$O/define_derivation_matrices.o: ${S}/define_derivation_matrices.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/define_derivation_matrices.o ${S}/define_derivation_matrices.f90
-
-$O/plotgll.o: ${S}/plotgll.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/plotgll.o ${S}/plotgll.f90
-
-$O/plotpost.o: ${S}/plotpost.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/plotpost.o ${S}/plotpost.F90
-
-$O/locate_receivers.o: ${S}/locate_receivers.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/locate_receivers.o ${S}/locate_receivers.F90
-
-$O/recompute_jacobian.o: ${S}/recompute_jacobian.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/recompute_jacobian.o ${S}/recompute_jacobian.f90
-
-$O/locate_source_force.o: ${S}/locate_source_force.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/locate_source_force.o ${S}/locate_source_force.F90
-
-$O/locate_source_moment_tensor.o: ${S}/locate_source_moment_tensor.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/locate_source_moment_tensor.o ${S}/locate_source_moment_tensor.F90
-
-$O/define_shape_functions.o: ${S}/define_shape_functions.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/define_shape_functions.o ${S}/define_shape_functions.f90
-
-$O/attenuation_model.o: ${S}/attenuation_model.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/attenuation_model.o ${S}/attenuation_model.f90
-
-$O/get_poroelastic_velocities.o: ${S}/get_poroelastic_velocities.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/get_poroelastic_velocities.o ${S}/get_poroelastic_velocities.f90
-
-### use optimized compilation option for solver only
-$O/specfem2D.o: ${S}/specfem2D.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_NO_CHECK) -c -o $O/specfem2D.o ${S}/specfem2D.F90
-
-### use optimized compilation option for solver only
-$O/enforce_acoustic_free_surface.o: ${S}/enforce_acoustic_free_surface.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_NO_CHECK) -c -o $O/enforce_acoustic_free_surface.o ${S}/enforce_acoustic_free_surface.f90
-
-### use optimized compilation option for solver only
-$O/compute_forces_acoustic.o: ${S}/compute_forces_acoustic.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_forces_acoustic.o ${S}/compute_forces_acoustic.f90
-
-### use optimized compilation option for solver only
-$O/compute_forces_viscoelastic.o: ${S}/compute_forces_viscoelastic.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_forces_viscoelastic.o ${S}/compute_forces_viscoelastic.f90
-
-### use optimized compilation option for solver only
-$O/compute_forces_poro_solid.o: ${S}/compute_forces_poro_solid.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_forces_poro_solid.o ${S}/compute_forces_poro_solid.f90
-
-### use optimized compilation option for solver only
-$O/compute_forces_poro_fluid.o: ${S}/compute_forces_poro_fluid.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_forces_poro_fluid.o ${S}/compute_forces_poro_fluid.f90
-
-### use optimized compilation option for solver only
-$O/compute_gradient_attenuation.o: ${S}/compute_gradient_attenuation.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_gradient_attenuation.o ${S}/compute_gradient_attenuation.f90
-
-$O/check_stability.o: ${S}/check_stability.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_NO_CHECK) -c -o $O/check_stability.o ${S}/check_stability.F90
-
-$O/calendar.o: ${S}/calendar.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/calendar.o ${S}/calendar.f90
-
-$O/convert_time.o: ${S}/convert_time.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/convert_time.o ${S}/convert_time.f90
-
-$O/compute_energy.o: ${S}/compute_energy.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_energy.o ${S}/compute_energy.f90
-
-$O/compute_vector_field.o: ${S}/compute_vector_field.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/compute_vector_field.o ${S}/compute_vector_field.f90
-
-$O/compute_pressure.o: ${S}/compute_pressure.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/compute_pressure.o ${S}/compute_pressure.f90
-
-$O/compute_curl_one_element.o: ${S}/compute_curl_one_element.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/compute_curl_one_element.o ${S}/compute_curl_one_element.f90
-
-$O/compute_Bielak_conditions.o: ${S}/compute_Bielak_conditions.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/compute_Bielak_conditions.o ${S}/compute_Bielak_conditions.f90
-
-$O/compute_arrays_source.o: ${S}/compute_arrays_source.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/compute_arrays_source.o ${S}/compute_arrays_source.f90
-
-$O/create_color_image.o: ${S}/create_color_image.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/create_color_image.o ${S}/create_color_image.f90
-
-$O/save_databases.o: ${S}/save_databases.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/save_databases.o ${S}/save_databases.f90
-
-$O/save_gnuplot_file.o: ${S}/save_gnuplot_file.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/save_gnuplot_file.o ${S}/save_gnuplot_file.f90
-
-$O/save_stations_file.o: ${S}/save_stations_file.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/save_stations_file.o ${S}/save_stations_file.f90
-
-$O/spline_routines.o: ${S}/spline_routines.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/spline_routines.o ${S}/spline_routines.f90
-
-$O/netlib_specfun_erf.o: ${S}/netlib_specfun_erf.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/netlib_specfun_erf.o ${S}/netlib_specfun_erf.f90
-
-$O/define_external_model.o: ${S}/define_external_model.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/define_external_model.o ${S}/define_external_model.f90
-
-$O/write_seismograms.o: ${S}/write_seismograms.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/write_seismograms.o ${S}/write_seismograms.F90
-
-$O/part_unstruct.o: ${S}/part_unstruct.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/part_unstruct.o ${S}/part_unstruct.F90
-
-$O/construct_acoustic_surface.o: ${S}/construct_acoustic_surface.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/construct_acoustic_surface.o ${S}/construct_acoustic_surface.f90
-
-$O/assemble_MPI.o: ${S}/assemble_MPI.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/assemble_MPI.o ${S}/assemble_MPI.F90
-
-$O/exit_mpi.o: ${S}/exit_mpi.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/exit_mpi.o ${S}/exit_mpi.F90
-
-$O/attenuation_compute_param.o: ${S}/attenuation_compute_param.c
- ${CC} $(CFLAGS) -c -o $O/attenuation_compute_param.o ${S}/attenuation_compute_param.c
-
-$O/paco_beyond_critical.o: ${S}/paco_beyond_critical.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/paco_beyond_critical.o ${S}/paco_beyond_critical.f90
-
-$O/paco_convolve_fft.o: ${S}/paco_convolve_fft.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/paco_convolve_fft.o ${S}/paco_convolve_fft.f90
-
-$O/prepare_absorb.o: ${S}/prepare_absorb.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/prepare_absorb.o ${S}/prepare_absorb.f90
-
-$O/prepare_color_image.o: ${S}/prepare_color_image.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/prepare_color_image.o ${S}/prepare_color_image.F90
-
-$O/prepare_initialfield.o: ${S}/prepare_initialfield.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/prepare_initialfield.o ${S}/prepare_initialfield.F90
-
-$O/prepare_source_time_function.o: ${S}/prepare_source_time_function.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/prepare_source_time_function.o ${S}/prepare_source_time_function.f90
-
-$O/is_in_convex_quadrilateral.o: ${S}/is_in_convex_quadrilateral.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/is_in_convex_quadrilateral.o ${S}/is_in_convex_quadrilateral.f90
-
-$O/get_perm_cuthill_mckee.o: ${S}/get_perm_cuthill_mckee.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/get_perm_cuthill_mckee.o ${S}/get_perm_cuthill_mckee.f90
-
-$O/read_external_model.o: ${S}/read_external_model.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/read_external_model.o ${S}/read_external_model.f90
-
-$O/setup_sources_receivers.o: ${S}/setup_sources_receivers.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/setup_sources_receivers.o ${S}/setup_sources_receivers.f90
-
-$O/invert_mass_matrix.o: ${S}/invert_mass_matrix.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/invert_mass_matrix.o ${S}/invert_mass_matrix.f90
-
-$O/initialize_simulation.o: ${S}/initialize_simulation.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/initialize_simulation.o ${S}/initialize_simulation.F90
-
-$O/set_sources.o: ${S}/set_sources.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/set_sources.o ${S}/set_sources.f90
-
-$O/save_openDX_jacobian.o: ${S}/save_openDX_jacobian.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/save_openDX_jacobian.o ${S}/save_openDX_jacobian.f90
-
-$O/compute_normal_vector.o: ${S}/compute_normal_vector.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_normal_vector.o ${S}/compute_normal_vector.f90
-
-$O/read_databases.o: ${S}/read_databases.f90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/read_databases.o ${S}/read_databases.f90
-
-$O/prepare_assemble_MPI.o: ${S}/prepare_assemble_MPI.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/prepare_assemble_MPI.o ${S}/prepare_assemble_MPI.F90
-
-$O/get_MPI.o: ${S}/get_MPI.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/get_MPI.o ${S}/get_MPI.F90
-
-$O/sort_array_coordinates.o: ${S}/sort_array_coordinates.F90 ${SETUP}/constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/sort_array_coordinates.o ${S}/sort_array_coordinates.F90
-
+help:
+ @echo "usage: make [executable]"
+ @echo ""
+ @echo "supported executables:"
+ @echo " xspecfem3D"
+ @echo " xmeshfem3D"
+ @echo " xconvolve_source_timefunction"
+ @echo " xcheck_quality_external_mesh"
+ @echo " xadj_seismogram"
+ @echo ""
Deleted: seismo/2D/SPECFEM2D/trunk/README_MANUAL.txt
===================================================================
--- seismo/2D/SPECFEM2D/trunk/README_MANUAL.txt 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/README_MANUAL.txt 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,550 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Main 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!====================================================================================
-!
-! An explicit 2D parallel MPI spectral element solver
-! for the anelastic anisotropic or poroelastic wave equation.
-!
-!====================================================================================
-
-! If you use this code for your own research, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{VaCaSaKoVi99,
-! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
-! D. Komatitsch and J. P. Vilotte},
-! title = {Elastic wave propagation in an irregularly layered medium},
-! journal = {Soil Dynamics and Earthquake Engineering},
-! year = {1999},
-! volume = {18},
-! pages = {11-18},
-! number = {1},
-! doi = {10.1016/S0267-7261(98)00027-X}}
-!
-! @ARTICLE{LeChKoHuTr09,
-! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
-! Shouh Huang and Jeroen Tromp},
-! title = {Effects of realistic surface topography on seismic ground motion
-! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
-! method and {LiDAR DTM}},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {681-693},
-! number = {2A},
-! doi = {10.1785/0120080264}}
-!
-! @ARTICLE{LeChLiKoHuTr08,
-! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
-! and Bor Shouh Huang and Jeroen Tromp},
-! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
-! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2008},
-! volume = {98},
-! pages = {253-264},
-! number = {1},
-! doi = {10.1785/0120070033}}
-!
-! @ARTICLE{LeKoHuTr09,
-! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
-! title = {Effects of topography on seismic wave propagation: An example from
-! northern {T}aiwan},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {314-325},
-! number = {1},
-! doi = {10.1785/0120080020}}
-!
-! @ARTICLE{KoErGoMi10,
-! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
-! David Mich\'ea},
-! title = {High-order finite-element seismic wave propagation modeling with
-! {MPI} on a large {GPU} cluster},
-! journal = {J. Comput. Phys.},
-! year = {2010},
-! volume = {229},
-! pages = {7692-7714},
-! number = {20},
-! doi = {10.1016/j.jcp.2010.06.024}}
-!
-! @ARTICLE{KoGoErMi10,
-! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
-! David Mich\'ea},
-! title = {Modeling the propagation of elastic waves using spectral elements
-! on a cluster of 192 {GPU}s},
-! journal = {Computer Science Research and Development},
-! year = {2010},
-! volume = {25},
-! pages = {75-82},
-! number = {1-2},
-! doi = {10.1007/s00450-010-0109-1}}
-!
-! @ARTICLE{KoMiEr09,
-! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
-! title = {Porting a high-order finite-element earthquake modeling application
-! to {NVIDIA} graphics cards using {CUDA}},
-! journal = {Journal of Parallel and Distributed Computing},
-! year = {2009},
-! volume = {69},
-! pages = {451-460},
-! number = {5},
-! doi = {10.1016/j.jpdc.2009.01.006}}
-!
-! @ARTICLE{LiPoKoTr04,
-! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
-! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
-! journal={Bull. Seismol. Soc. Am.},
-! year = {2004},
-! volume = {94},
-! pages = {1748-1761},
-! number = {5},
-! doi = {10.1785/012004038}}
-!
-! @INCOLLECTION{ChKoViCaVaFe07,
-! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
-! Yann Capdeville and Bernard Valette and Gaetano Festa},
-! title = {Spectral Element Analysis in Seismology},
-! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
-! publisher = {Elsevier - Academic Press},
-! year = {2007},
-! editor = {Ru-Shan Wu and Val\'erie Maupin},
-! volume = {48},
-! series = {Advances in Geophysics},
-! pages = {365-419}}
-!
-! @ARTICLE{KoVi98,
-! author={D. Komatitsch and J. P. Vilotte},
-! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
-! journal={Bull. Seismol. Soc. Am.},
-! year=1998,
-! volume=88,
-! number=2,
-! pages={368-392}}
-!
-! @ARTICLE{KoTr99,
-! author={D. Komatitsch and J. Tromp},
-! year=1999,
-! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
-! journal={Geophys. J. Int.},
-! volume=139,
-! number=3,
-! pages={806-822},
-! doi={10.1046/j.1365-246x.1999.00967.x}}
-!
-! @ARTICLE{KoLiTrSuStSh04,
-! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
-! and Christiane Stidham and John H. Shaw},
-! year=2004,
-! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
-! based upon the Spectral-Element Method},
-! journal={Bull. Seism. Soc. Am.},
-! volume=94,
-! number=1,
-! pages={187-206}}
-!
-! @ARTICLE{MoTr08,
-! author={C. Morency and J. Tromp},
-! title={Spectral-element simulations of wave propagation in poroelastic media},
-! journal={Geophys. J. Int.},
-! year=2008,
-! volume=175,
-! pages={301-345}}
-!
-! and/or other articles from http://web.univ-pau.fr/~dkomati1/publications.html
-!
-! If you use the kernel capabilities of the code, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{LiTr06,
-! author={Qinya Liu and Jeroen Tromp},
-! title={Finite-frequency kernels based on adjoint methods},
-! journal={Bull. Seismol. Soc. Am.},
-! year=2006,
-! volume=96,
-! number=6,
-! pages={2383-2397},
-! doi={10.1785/0120060041}}
-!
-! @ARTICLE{MoLuTr09,
-! author={C. Morency and Y. Luo and J. Tromp},
-! title={Finite-frequency kernels for wave propagation in porous media based upon adjoint methods},
-! year=2009,
-! journal={Geophys. J. Int.},
-! doi={10.1111/j.1365-246X.2009.04332}}
-!
-! If you use the SCOTCH / CUBIT non-structured capabilities, please also cite:
-!
-! @ARTICLE{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},
-! journal = {Lecture Notes in Computer Science},
-! year = {2008},
-! volume = {5336},
-! pages = {350-363}}
-!
-
-
-SPECFEM2D 6.1: SPECFEM2D facilitates 2D simulations of
- acoustic, (an)elastic, and poroelastic seismic wave propagation.
- With version 6.1, the 2D spectral-element solver accommodates
- regular and unstructured meshes, generated for example by Cubit
- (http://cubit.sandia.gov), Gmsh (http://geuz.org/gmsh)
- or GiD (http://www.gid.cimne.upc.es). Even mesh creation packages that generate triangles, for instance Delaunay-Voronoi triangulation codes, can be used because each triangle can then easily be decomposed into three quadrangles by linking the barycenter to the center of each edge; while this approach does not generate quadrangles of optimal quality, it can ease mesh creation in some situations and it has been shown that the spectral-element method can very accurately handle distorted mesh elements.
-
- The solver has adjoint capabilities and can
- calculate finite-frequency sensitivity kernels for acoustic,
- (an)elastic, and poroelastic media. The package also considers 2D SH
- and P-SV wave propagation. Finally, the solver can run
- both in serial and in parallel. See SPECFEM2D
- <http://www.geodynamics.org/cig/software/packages/seismo/specfem2d>
- for the source code.
-
-The SEM is a continuous Galerkin technique, which can easily be made discontinous;
-it is then a particular case of the discontinuous Galerkin technique,
-with optimized efficiency because of its tensorized basis functions.
-In particular, it can accurately handle very distorted mesh elements.
-Note that in many (most?) geological models in the context of seismic wave propagation studies (except for fault dynamic rupture studies)
-a discontinous mesh is not needed because material property contrasts are not drastic and thus a continuous formulation is sufficient.
-
-The SPECFEM2D package was first developed by Dimitri Komatitsch and Jean-Pierre Vilotte at IPG in Paris, France from 1994 to 1997 and then by Dimitri Komatitsch from 1998 to 2005. Since then it has been developed and maintained by a development team: in alphabetical order, Celine Blitz, Emiljana Jorgji, Dimitri Komatitsch, Nicolas Le Goff, Pieyre Le Loher, Roland Martin, Christina Morency, David Michea, Carl Tape, Jeroen Tromp... (add other developers here in the future, several are currently missing).
-
-
-Caution:
---------
-
-- the units for the components of a moment tensor source are different
-in SPECFEM2D and in SPECFEM3D:
- - in SPECFEM3D the moment tensor components are in dyne*cm
- - in SPECFEM2D the moment tensor components are in N*m
-
-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_SCOTCH enables use of graph partitioner SCOTCH.
-
-- if you want to run in parallel, i.e., using more than one processor core, then you need to compile the SCOTCH graph partitioner. Go to subdirectory scotch_5.1.10b and read INSTALL.txt. You may want to download more recent versions of SCOTCH in the future from http://www.labri.fr/perso/pelegrin/scotch/scotch_en.html . Support for the METIS graph partitioner has been discontinued because SCOTCH is more recent and performs better.
-
-- then go back to the main directory of SPECFEM2D and type "make all"
-
-- edit the input file "DATA/Par_file" which describes the simulation. It contains comments and should be almost self-explanatory, if you need more details we do not have a manual for the 2D version but you can find useful information in the manuals of the 3D versions, since many parameters and the general philosophy is similar. They are available at http://geodynamics.org/wsvn/cig/seismo/3D in subdirectories USER_MANUAL. To create acoustic (fluid) regions, just set the S wave speed to zero and the code will see that these elements are fluid and switch to the right equations there automatically, and automatically match them with the solid regions
-
-- 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 must specify the number of processes.
-
-- then type xmeshfem2D to create the mesh (which will be stored in directory OUTPUT_FILES). xmeshfem2D is serial; it will output several files called Databasexxxxx, one for each process.
-
-- then type xspecfem2D to run the main solver (use mpirun or equivalent if you compiled ). This will output the seismograms and snapshots of the wave fronts at different time steps in directory OUTPUT_FILES. To visualize them, type "gs OUTPUT_FILES/vect*.ps" to see the Postscript files (in which the wave field is represented with small arrows, fluid/solid matching interfaces with a thick pink line, and absorbing edges with a thick green line) and "gimp OUTPUT_FILES/image*.gif" to see the color snapshot showing a pixelized image of one of the two components of the wave field (or pressure, depending on what you have selected for the output in DATA/Par_file).
-
-- the DATA/Par_file given with the code works fine, you can use it without any modification to test the code
-
-- the seismograms OUTPUT_FILES/*.sem* are simple ASCII files with two columns: time in the first colum and amplitude in the second, therefore they can be visualized with any tool you like, for instance "gnuplot"
-
-- 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, 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
-
-- you can find a Fortran code to compute the analytical solution for simple media that we use as a reference in benchmarks in many of our articles at http://www.spice-rtn.org/library/software/EX2DDIR . That code is described in:
-
- at INCOLLECTION{BeIfNiSk94,
- author = {P. Berg and F. If and P. Nielsen and O. Skovegaard},
- title = {Analytic reference solutions},
- booktitle = {Modeling the Earth for oil exploration, Final report of the CEC's GEOSCIENCE~I Program 1990-1993},
- publisher = {Pergamon Press, Oxford, United Kingdom},
- year = {1994},
- editor = {K. Helbig},
- pages = {421-427}}
-
-Controlling the quality of an external mesh:
---------------------------------------------
-
-(README partly in French for now, cut and paste it in Google Translate at http://www.google.com/language_tools?hl=en if you do not understand French)
-
-Type
-
-./xcheck_quality_external_mesh
-
-(and answer "3" to the first question asked).
-
-Ce code vous dit quel est l'élément de tout le maillage qui a la plus mauvaise qualité (maximum skewness, i.e. déformation maximale des angles de l'élément) et il suffit d'aller modifier cet élément-là dans le logiciel de maillage externe utilisé, et de répéter l'opération jusqu'à ce que le maximum skewness de tout le maillage soit inférieur ou égal à environ 0.75 (au delà c'est dangereux : de 0.75 à 0.80 ça peut encore aller "à peu près", mais s'il y a un seul élément au delà de 0.80 alors le maillage est à améliorer a priori).
-
-Le code affiche aussi un histogramme de 20 classes de skewness qui dit combien d'éléments sont au delà de skewness = 0.75, et quel pourcentage du total cela fait. Pour voir cet histogramme à l'écran il faut ensuite taper :
-
-gnuplot plot_mesh_quality_histogram.gnu
-
-Cet outil est pratique pour estimer la qualité du maillage et la voir évoluer dans le bon sens au fur et à mesure des corrections successives.
-
-How to use poroelasticity:
---------------------------
-
----------------------------------
- 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":
-SIMULATION_TYPE defines the type of simulations
-(1) forward simulation
-(2) adjoint method and kernels calculation
-
-In section "# source parameters":
-The code now support multi sources.
-NSOURCES is the number of source.
-Parameters of the sources are displayed in the file SOURCE, which must be
-in the directory DATA. The components of a moment tensor source must be given in N.m,
-not in dyne.cm as in the DATA/CMTSOLUTION source file of the 3D version of the code.
-
-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....":
-There are three possible types of models:
-
- I: (model_number 1 rho Vp Vs 0 0 Qp Qs 0 0 0 0 0 0) or
- II: (model_number 2 rho c11 c13 c15 c33 c35 c55 0 0 0 0 0 0) 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, and poroelastic models simultaneously.
-
-rho_s = solid density
-rho_f = fluid density
-phi = porosity
-tort = tortuosity
-permxx = xx component of permeability tensor
-permxz = xz,zx components of permeability tensor
-permzz = zz component of permeability tensor
-kappa_s = solid bulk modulus
-kappa_f= fluid bulk modulus
-kappa_fr= frame bulk modulus
-eta_f = fluid viscosity
-mu_fr = frame shear modulus
-Qs = shear quality factor
-
-Note: for the poroelastic case, mu_s is irrelevant.
-For details on the poroelastic theory see Morency and Tromp, GJI 2008.
-
-get_poroelastic_velocities.f90 allows to compute cpI, cpII, and cs function of
-the source dominant frequency. Notice that for this calculation we use permxx
-and the dominant frequency of the first source , f0(1). Caution if you use
-several sources with different frequencies and if you consider anistropic
-permeability.
-
---------------------------------------------------
- HOW TO OBTAIN FINITE SENSITIVITY KERNELS
---------------------------------------------------
-
-First: run a forward simulation
-=> SIMULATION_TYPE = 1
-=> SAVE_FORWARD = .true.
-=> seismotype = 1 (we need to save the displacement fields to later on derive the
-adjoint source. Note: if the user forgets it, the program corrects it when reading the proper
-SIMULATION_TYPE/SAVE_FORWARD combination and a warning message appears in the ouput
-file)
-
-Important output files (for example, for the elastic case, P-SV waves)
-absorb_elastic_bottom*****.bin
-absorb_elastic_left*****.bin
-absorb_elastic_right*****.bin
-absorb_elastic_top*****.bin
-lastframe_elastic*****.bin
-S****.AA.BHX.semd
-S****.AA.BHZ.semd
-
-Second: define the adjoint source
-Use adj_seismogram.f90
-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 of adj_seismogram.f90 are S****.AA.BHX.adj and S****.AA.BHZ.adj, for P-SV waves (and
-S****.AA.BHY.adj, for SH (membrane) waves). Note that you will need these three
-files (S****.AA.BHX.adj, S****.AA.BHY.adj and S****.AA.BHZ.adj) to be present in the OUTPUT_FILES directory
-together with the absorb_elastic_****.bin 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 absorbing boundaries and last frame files are
-in the OUTPUT_FILES directory.
-=> SIMULATION_TYPE = 2
-=> SAVE_FORWARD = .false.
-
-Output_files (for example for the elastic case)
-snapshot_rho_kappa_mu*****
-snapshot_rhop_alpha_beta*****
-which are the primary moduli kernels and the phase velocities kernels respectively, in ascii format
-and at the local level, that is as "kernels(i,j,ispec)".
-
-Note1: At the moment, adjoint simulations do not support anisotropy, attenuation, and viscous damping.
-Note2: You will need S****.AA.BHX.adj, S****.AA.BHY.adj and S****.AA.BHZ.adj
-to be present in OUTPUT_FILES even if you are just running an acoustic or
-poroelastic adjoint simulation.
-S****.AA.BHX.adj is the only relevant component for an acoustic case.
-S****.AA.BHX.adj and S****.AA.BHZ.adj are the only relevant components for a
-poroelastic case.
-
---------------------------------------------------
- COUPLED SIMULATIONS
---------------------------------------------------
-
-The code supports acoustic/elastic, acoustic/poroelastic, elastic/poroelastic,
-and acoustic,elastic/poroelastic simulations.
-
-Elastic/poroelastic coupling supports anisotropy, but not attenuation for the
-elastic material.
-
-
-How to run P-SV or SH (membrane) wave simulations :
----------------------------------------------------
-
-To run a P-SV waves calculation propagating in the x-z plane,
-set p_sv = .true. in the Par_file.
-To run a SH (membrane) waves calculation traveling in the x-z plane with a
-y-component of motion, set p_sv = .false.
-
-This feature is only implemented for elastic materials and sensitivity kernels
-can be calculated (see Tape, Liu & Tromp, GJI 2006 for details on membrane
-surface waves).
-
----------------------------------------------------
-
-A useful Python script called SEM_save_dir.py, written by Paul Cristini from
-Laboratoire de Mecanique et d'Acoustique, CNRS, Marseille, France, is provided.
-It allows one to automatically save all the parameters and results of a given simulation.
-
---------------------------
---------------------------
---------------------------
-
-Regarding the structure of some of the database files:
-
-Question: Can anyone tell me what the columns of the SPECFEM2D boundary
-condition files in SPECFEM2D/DATA/Mesh_canyon are?
-
-SPECFEM2D/DATA/Mesh_canyoncanyon_absorbing_surface_file
-SPECFEM2D/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
-
---------------------------------------------------
- ACKNOWLEDGEMENTS
---------------------------------------------------
-
-We thank Paul Cristini from Laboratoire de Mecanique et d'Acoustique of Marseille, France, for very carefully testing version 6.1
-of the package and helping us locate and fix several important bugs.
-
Copied: seismo/2D/SPECFEM2D/trunk/UTILS/convolve_source_timefunction.csh (from rev 17990, seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.csh)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/UTILS/convolve_source_timefunction.csh (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/UTILS/convolve_source_timefunction.csh 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,25 @@
+#!/bin/csh
+
+# we mimic a triangle of half duration equal to half_duration_triangle
+# using a Gaussian having a very close shape, as explained in Figure 4.2
+# of the manual
+
+set half_duration_triangle = 11.2
+
+foreach file ( $* )
+
+set nlines = `wc -l $file `
+echo $nlines > input_convolve_code.txt
+echo $half_duration_triangle >> input_convolve_code.txt
+# use .true. for a triangle and .false. for a Gaussian
+#echo ".true." >> input_convolve_code.txt
+echo ".false." >> input_convolve_code.txt
+
+echo convolving $file with half_duration_triangle = $half_duration_triangle using lines $nlines
+
+../bin/xconvolve_source_timefunction < $file > ${file}.convolved
+
+rm input_convolve_code.txt
+
+end
+
Modified: seismo/2D/SPECFEM2D/trunk/configure
===================================================================
--- seismo/2D/SPECFEM2D/trunk/configure 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/configure 2011-03-01 20:59:44 UTC (rev 17998)
@@ -5541,7 +5541,7 @@
# Checks for library functions.
-ac_config_files="$ac_config_files Makefile DATA/Par_file DATA/SOURCE setup/constants.h setup/precision_mpi.h scotch_5.1.11/src/Makefile.inc"
+ac_config_files="$ac_config_files Makefile src/specfem2D/Makefile src/meshfem2D/Makefile DATA/Par_file DATA/SOURCE setup/constants.h setup/precision_mpi.h scotch_5.1.11/src/Makefile.inc"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
@@ -6242,6 +6242,8 @@
case $ac_config_target in
"setup/config.h") CONFIG_HEADERS="$CONFIG_HEADERS setup/config.h" ;;
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
+ "src/meshfem2D/Makefile") CONFIG_FILES="$CONFIG_FILES src/meshfem2D/Makefile" ;;
+ "src/specfem2D/Makefile") CONFIG_FILES="$CONFIG_FILES src/specfem2D/Makefile" ;;
"DATA/Par_file") CONFIG_FILES="$CONFIG_FILES DATA/Par_file" ;;
"DATA/SOURCE") CONFIG_FILES="$CONFIG_FILES DATA/SOURCE" ;;
"setup/constants.h") CONFIG_FILES="$CONFIG_FILES setup/constants.h" ;;
Added: seismo/2D/SPECFEM2D/trunk/configure.ac
===================================================================
--- seismo/2D/SPECFEM2D/trunk/configure.ac (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/configure.ac 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,433 @@
+dnl -*- Autoconf -*-
+dnl
+dnl Process this file with autoconf to produce the 'configure' script:
+dnl
+dnl ACLOCAL="aclocal -I m4" autoreconf
+dnl
+dnl You must have recent versions of Autoconf and Automake installed.
+
+# $Id: configure.ac,v 1.1 2005/08/24 22:45:51 leif Exp $
+
+
+AC_PREREQ(2.61)
+AC_INIT([Specfem 2D], [6.1.1], [jtromp AT princeton.edu], [Specfem2D])
+AC_CONFIG_SRCDIR([README])
+AC_CONFIG_HEADER([setup/config.h])
+AC_CONFIG_MACRO_DIR([m4])
+
+
+# 'configure' options
+
+AC_ARG_WITH([pyre],
+ [AC_HELP_STRING([--with-pyre],
+ [build Pyrized version @<:@default=no@:>@])],
+ [want_pyre="$withval"],
+ [want_pyre=no])
+AM_CONDITIONAL([COND_PYRE], [test "$want_pyre" = yes])
+
+AC_ARG_WITH([mpi],
+ [AC_HELP_STRING([--with-mpi],
+ [build parallel version @<:@default=yes@:>@])],
+ [want_mpi="$withval"],
+ [want_mpi=no])
+AM_CONDITIONAL([COND_MPI], [test "$want_mpi" = yes])
+
+AC_ARG_ENABLE([double-precision],
+ [AC_HELP_STRING([--enable-double-precision],
+ [solver in double precision @<:@default=no@:>@])],
+ [want_double_precision="$enableval"],
+ [want_double_precision=yes])
+if test "$want_double_precision" = no; then
+ CUSTOM_REAL=SIZE_REAL
+ CUSTOM_MPI_TYPE=MPI_REAL
+else
+ CUSTOM_REAL=SIZE_DOUBLE
+ CUSTOM_MPI_TYPE=MPI_DOUBLE_PRECISION
+fi
+AC_SUBST([CUSTOM_REAL])
+AC_SUBST([CUSTOM_MPI_TYPE])
+
+
+# Checks for programs.
+
+if test "$want_pyre" = yes; then
+ AM_PATH_PYTHON([2.3])
+ CIT_PYTHON_SYSCONFIG
+fi
+
+# a courtesy to the installed base of users
+if test x"$FC" = x && test x"$F90" != x; then
+ FC="$F90"
+fi
+if test x"$MPIFC" = x && test x"$MPIF90" != x; then
+ MPIFC="$MPIF90"
+fi
+
+AC_PROG_FC
+export FC
+export MPIFC
+F77="$FC"
+FFLAGS="$FCFLAGS"
+AC_PROVIDE([AC_PROG_F77])
+AC_SUBST([FCENV])
+
+flags_guess="$SHELL flags.guess"
+AC_MSG_NOTICE([running $flags_guess])
+flags=`$flags_guess` ||
+ AC_MSG_ERROR([$flags_guess failed])
+eval $flags
+
+AC_FC_WRAPPERS
+AC_LANG(Fortran)
+AC_FC_SRCEXT(f90)
+AC_FC_FREEFORM()
+
+AC_PROG_CC
+
+
+#checks for Scotch
+
+export SCOTCH_DIR
+export SCOTCH_LIBDIR
+export SCOTCH_INCLUDEDIR
+export USE_BUNDLED_SCOTCH
+
+AC_ARG_WITH([scotch-dir],
+AC_HELP_STRING([--with-scotch-dir],[define the root path to Scotch (e.g. /opt/scotch/)]),
+[
+ ac_scotch_dir="$withval";
+])
+
+AC_ARG_WITH([scotch-includedir],
+AC_HELP_STRING([--with-scotch-includedir],[define the path to the Scotch headers (e.g. /opt/scotch/include)]),
+[
+ ac_scotch_include_dir="$withval";
+])
+
+AC_ARG_WITH([scotch-libdir],
+AC_HELP_STRING([--with-scotch-libdir],[define the path to the Scotch libraries (e.g. /opt/scotch/lib)]),
+[
+ ac_scotch_lib_dir="$withval";
+])
+
+if test "${USE_BUNDLED_SCOTCH}" != "1"; then
+
+ if test -z "${ac_scotch_lib_dir}"; then
+ if test -n "${ac_scotch_dir}"; then
+ ac_scotch_lib_dir="${ac_scotch_dir}/lib";
+ else
+ ac_scotch_lib_dir="/usr/lib";
+ fi
+ fi
+
+ if test -z "${ac_scotch_include_dir}"; then
+ if test -n "${ac_scotch_dir}"; then
+ ac_scotch_include_dir="${ac_scotch_dir}/include";
+ else
+ ac_scotch_include_dir="/usr/include/scotch";
+ fi
+ fi
+
+ scotch_lib=""
+ ac_save_ldflags=${LDFLAGS}
+ if test -n "${ac_scotch_lib_dir}"; then
+ LDFLAGS="${LDFLAGS} -L${ac_scotch_lib_dir}";
+ fi
+ AC_CHECK_LIB(scotch,scotchfarchinit ,[scotch_lib="yes";],[scotch_lib="no";LDFLAGS=${ac_save_ldflags}], -lscotcherr)
+
+ scotch_include=""
+ ac_save_cppflags=${CPPFLAGS}
+ if test -n "${ac_scotch_include_dir}"; then
+ CPPFLAGS="${CPPFLAGS} -I${ac_scotch_include_dir}";
+ fi
+
+dnl This does not work because we are in Fortran mode, which does not
+dnl handle headers.
+dnl
+dnl AC_CHECK_HEADER(scotchf.h,[scotch_include="yes";],[scotch_include="no";CPPFLAGS=${ac_save_cppflags}])
+
+ scotch_usable="${scotch_lib}"
+
+fi
+
+AC_MSG_CHECKING([whether Scotch is usable])
+if test "x${scotch_usable}" = "xyes"; then
+ AC_DEFINE([HAVE_SCOTCH],[1],[defined if Scotch is installed])
+ USE_BUNDLED_SCOTCH=0
+ SCOTCH_DIR="${ac_scotch_dir}"
+ SCOTCH_LIBDIR="${ac_scotch_lib_dir}"
+ SCOTCH_INCLUDEDIR="${ac_scotch_include_dir}"
+ AC_MSG_RESULT([yes])
+else
+ AC_DEFINE([HAVE_SCOTCH],[1],[defined if Scotch is installed])
+ AC_MSG_RESULT([no, using bundled scotch instead])
+ AC_PROG_LEX
+ if test -z "$LEX" || test "X$LEX" = "Xno"; then
+ AC_MSG_ERROR([No suitable lex found])
+ fi
+ AC_PROG_YACC
+ if test -z "$YACC" || test "X$YACC" = "Xno"; then
+ AC_MSG_ERROR([No suitable yacc or bison found])
+ fi
+
+ # scotch only needed with mpi support
+ if test "$want_mpi" = yes; then
+
+ #daniel: scotch bundle
+ # uses bundled scotch: current version 5.1.11
+ USE_BUNDLED_SCOTCH=1
+
+ SCOTCH_DIR="scotch_5.1.11"
+ SCOTCH_LIBDIR="${SCOTCH_DIR}/lib"
+ SCOTCH_INCLUDEDIR="${SCOTCH_DIR}/include"
+
+ # the following modifies the default scotch Makefile such that the package
+ # will only be compiled once (no recompilation) when calling make
+ #
+ builddir=`pwd`
+
+ if test ! -f "${SCOTCH_DIR}/src/scotch/Makefile.org"; then
+
+ # no Makefile backup files yet
+ # modifies Makefiles once
+
+ # creates backup copies of original Makefiles
+ # src/scotch/
+ cp ${SCOTCH_DIR}/src/scotch/Makefile ${SCOTCH_DIR}/src/scotch/Makefile.org
+ # src/libscotch/
+ cp ${SCOTCH_DIR}/src/libscotch/Makefile ${SCOTCH_DIR}/src/libscotch/Makefile.org
+ # src/libscotchmetis/
+ cp ${SCOTCH_DIR}/src/libscotchmetis/Makefile ${SCOTCH_DIR}/src/libscotchmetis/Makefile.org
+
+ fi
+
+ # replacement text in the default scotch Makefiles
+ cat > conftmp.scotch.cmd <<_ACEOF
+# scotch replacement text for install line
+\$(bindir)/acpl\$(EXE): acpl\$(EXE)
+ -\$(CP) acpl\$(EXE) \$(bindir)/acpl\$(EXE)
+\$(bindir)/amk_ccc\$(EXE): amk_ccc\$(EXE)
+ -\$(CP) amk_ccc\$(EXE) \$(bindir)/amk_ccc\$(EXE)
+\$(bindir)/amk_fft2\$(EXE): amk_fft2\$(EXE)
+ -\$(CP) amk_fft2\$(EXE) \$(bindir)/amk_fft2\$(EXE)
+\$(bindir)/amk_grf\$(EXE): amk_grf\$(EXE)
+ -\$(CP) amk_grf\$(EXE) \$(bindir)/amk_grf\$(EXE)
+\$(bindir)/amk_hy\$(EXE): amk_hy\$(EXE)
+ -\$(CP) amk_hy\$(EXE) \$(bindir)/amk_hy\$(EXE)
+\$(bindir)/amk_m2\$(EXE): amk_m2\$(EXE)
+ -\$(CP) amk_m2\$(EXE) \$(bindir)/amk_m2\$(EXE)
+\$(bindir)/amk_p2\$(EXE): amk_p2\$(EXE)
+ -\$(CP) amk_p2\$(EXE) \$(bindir)/amk_p2\$(EXE)
+\$(bindir)/atst\$(EXE): atst\$(EXE)
+ -\$(CP) atst\$(EXE) \$(bindir)/atst\$(EXE)
+\$(bindir)/gbase\$(EXE): gbase\$(EXE)
+ -\$(CP) gbase\$(EXE) \$(bindir)/gbase\$(EXE)
+\$(bindir)/gcv\$(EXE): gcv\$(EXE)
+ -\$(CP) gcv\$(EXE) \$(bindir)/gcv\$(EXE)
+\$(bindir)/gmap\$(EXE): gmap\$(EXE)
+ -\$(CP) gmap\$(EXE) \$(bindir)/gmap\$(EXE)
+\$(bindir)/gmk_hy\$(EXE): gmk_hy\$(EXE)
+ -\$(CP) gmk_hy\$(EXE) \$(bindir)/gmk_hy\$(EXE)
+\$(bindir)/gmk_m2\$(EXE): gmk_m2\$(EXE)
+ -\$(CP) gmk_m2\$(EXE) \$(bindir)/gmk_m2\$(EXE)
+\$(bindir)/gmk_m3\$(EXE): gmk_m3\$(EXE)
+ -\$(CP) gmk_m3\$(EXE) \$(bindir)/gmk_m3\$(EXE)
+\$(bindir)/gmk_msh\$(EXE): gmk_msh\$(EXE)
+ -\$(CP) gmk_msh\$(EXE) \$(bindir)/gmk_msh\$(EXE)
+\$(bindir)/gmk_ub2\$(EXE): gmk_ub2\$(EXE)
+ -\$(CP) gmk_ub2\$(EXE) \$(bindir)/gmk_ub2\$(EXE)
+\$(bindir)/gmtst\$(EXE): gmtst\$(EXE)
+ -\$(CP) gmtst\$(EXE) \$(bindir)/gmtst\$(EXE)
+\$(bindir)/gord\$(EXE): gord\$(EXE)
+ -\$(CP) gord\$(EXE) \$(bindir)/gord\$(EXE)
+\$(bindir)/gotst\$(EXE): gotst\$(EXE)
+ -\$(CP) gotst\$(EXE) \$(bindir)/gotst\$(EXE)
+\$(bindir)/gout\$(EXE): gout\$(EXE)
+ -\$(CP) gout\$(EXE) \$(bindir)/gout\$(EXE)
+\$(bindir)/gpart\$(EXE): \$(bindir)/gmap\$(EXE)
+ -\$(RM) \$(bindir)/gpart\$(EXE)
+ -\$(LN) \$(bindir)/gmap\$(EXE) \$(bindir)/gpart\$(EXE)
+\$(bindir)/gscat\$(EXE): gscat\$(EXE)
+ -\$(CP) gscat\$(EXE) \$(bindir)/gscat\$(EXE)
+\$(bindir)/gtst\$(EXE): gtst\$(EXE)
+ -\$(CP) gtst\$(EXE) \$(bindir)/gtst\$(EXE)
+\$(bindir)/mcv\$(EXE): mcv\$(EXE)
+ -\$(CP) mcv\$(EXE) \$(bindir)/mcv\$(EXE)
+\$(bindir)/mmk_m2\$(EXE): mmk_m2\$(EXE)
+ -\$(CP) mmk_m2\$(EXE) \$(bindir)/mmk_m2\$(EXE)
+\$(bindir)/mmk_m3\$(EXE): mmk_m3\$(EXE)
+ -\$(CP) mmk_m3\$(EXE) \$(bindir)/mmk_m3\$(EXE)
+\$(bindir)/mord\$(EXE): mord\$(EXE)
+ -\$(CP) mord\$(EXE) \$(bindir)/mord\$(EXE)
+\$(bindir)/mtst\$(EXE): mtst\$(EXE)
+ -\$(CP) mtst\$(EXE) \$(bindir)/mtst\$(EXE)
+
+
+install : \$(bindir)/acpl\$(EXE) \$(bindir)/amk_ccc\$(EXE) \\
+ \$(bindir)/amk_fft2\$(EXE) \$(bindir)/amk_grf\$(EXE) \\
+ \$(bindir)/amk_hy\$(EXE) \$(bindir)/amk_m2\$(EXE) \\
+ \$(bindir)/amk_p2\$(EXE) \$(bindir)/atst\$(EXE) \\
+ \$(bindir)/gbase\$(EXE) \$(bindir)/gcv\$(EXE) \\
+ \$(bindir)/gmap\$(EXE) \$(bindir)/gmk_hy\$(EXE) \\
+ \$(bindir)/gmk_m2\$(EXE) \$(bindir)/gmk_m3\$(EXE) \\
+ \$(bindir)/gmk_msh\$(EXE) \$(bindir)/gmk_ub2\$(EXE) \\
+ \$(bindir)/gmtst\$(EXE) \$(bindir)/gord\$(EXE) \\
+ \$(bindir)/gotst\$(EXE) \$(bindir)/gout\$(EXE) \\
+ \$(bindir)/gpart\$(EXE) \$(bindir)/gscat\$(EXE) \\
+ \$(bindir)/gtst\$(EXE) \$(bindir)/mcv\$(EXE) \\
+ \$(bindir)/mmk_m2\$(EXE) \$(bindir)/mmk_m3\$(EXE) \\
+ \$(bindir)/mord\$(EXE) \$(bindir)/mtst\$(EXE)
+
+_ACEOF
+
+ # avoids lines between 98 to 101, containig install lines, and replaces them
+ awk '{if(NR<98)print $0}' ${SCOTCH_DIR}/src/scotch/Makefile.org > ${SCOTCH_DIR}/src/scotch/Makefile
+ cat conftmp.scotch.cmd >> ${SCOTCH_DIR}/src/scotch/Makefile
+ awk '{if(NR>101)print $0}' ${SCOTCH_DIR}/src/scotch/Makefile.org >> ${SCOTCH_DIR}/src/scotch/Makefile
+ rm -f conftmp.scotch.cmd
+
+ # replacement text in the default libscotch Makefile
+ cat > conftmp.libscotch.cmd <<_ACEOF
+# libscotch replacement text for install line
+\$(libdir)/libscotch\$(LIB): libscotch\$(LIB)
+ -\$(CP) libscotch\$(LIB) \$(libdir)
+\$(libdir)/libscotcherr\$(LIB): libscotcherr\$(LIB)
+ -\$(CP) libscotcherr\$(LIB) \$(libdir)
+\$(libdir)/libscotcherrexit\$(LIB): libscotcherrexit\$(LIB)
+ -\$(CP) libscotcherrexit\$(LIB) \$(libdir)
+\$(includedir)/scotch.h: scotch.h
+ -\$(CP) scotch.h \$(includedir)
+\$(includedir)/scotchf.h: scotchf.h
+ -\$(CP) scotchf.h \$(includedir)
+
+install : \$(libdir)/libscotch\$(LIB) \$(libdir)/libscotcherr\$(LIB) \\
+ \$(libdir)/libscotcherrexit\$(LIB) \\
+ \$(includedir)/scotch.h \$(includedir)/scotchf.h
+
+_ACEOF
+
+ # avoids lines between 71 to 73, containig install lines, and replaces them
+ awk '{if(NR<71)print $0}' ${SCOTCH_DIR}/src/libscotch/Makefile.org > ${SCOTCH_DIR}/src/libscotch/Makefile
+ cat conftmp.libscotch.cmd >> ${SCOTCH_DIR}/src/libscotch/Makefile
+ awk '{if(NR>73)print $0}' ${SCOTCH_DIR}/src/libscotch/Makefile.org >> ${SCOTCH_DIR}/src/libscotch/Makefile
+ rm -f conftmp.libscotch.cmd
+
+ # replaces single scotch line in Makefiles
+ # src/scotch/
+ sed -i "s/^scotch.*clean/scotch : /" ${SCOTCH_DIR}/src/scotch/Makefile
+ # src/libscotch/
+ sed -i "s/^scotch.*clean/scotch : /" ${SCOTCH_DIR}/src/libscotch/Makefile
+ # src/libscotchmetis/
+ sed -i "s/^scotch.*clean/scotch : /" ${SCOTCH_DIR}/src/libscotchmetis/Makefile
+
+ cd $builddir
+
+ # done scotch Makefile modification
+
+ else
+
+ # no mpi support, scotch not needed
+ USE_BUNDLED_SCOTCH=0
+
+ fi # want_mpi
+
+
+fi
+LDFLAGS=${ac_save_ldflags}
+
+# influential environment variables
+
+AC_ARG_VAR(USE_BUNDLED_SCOTCH, [Set to 1 to always use the bundled Scotch library])
+AC_ARG_VAR(SCOTCH_DIR, [Directory where Scotch is installed])
+AC_ARG_VAR(SCOTCH_INCLUDEDIR, [Directory where Scotch headers are installed])
+AC_ARG_VAR(SCOTCH_LIBDIR, [Directory where Scotch libraries are installed])
+AC_ARG_VAR(MPIFC, [MPI Fortran compiler command])
+AC_ARG_VAR(MPILIBS, [extra libraries for linking MPI programs])
+AC_ARG_VAR(MPICC, [MPI C compiler command])
+AC_ARG_VAR(FLAGS_CHECK, [Fortran compiler flags for non-critical subroutines])
+AC_ARG_VAR(FLAGS_NO_CHECK, [Fortran compiler flags for creating fast, production-run code for critical subroutines])
+if test x"$MPIFC" = x; then
+ MPIFC=mpif90
+fi
+if test x"$MPICC" = x; then
+ MPICC=mpicc
+fi
+
+AC_ARG_VAR(LOCAL_PATH_IS_ALSO_GLOBAL, [files on a local path on each node are also seen as global with same path @<:@default=true@:>@])
+if test x"$LOCAL_PATH_IS_ALSO_GLOBAL" = x; then
+ LOCAL_PATH_IS_ALSO_GLOBAL=true
+fi
+
+AC_ARG_VAR(PYTHON, [Python interpreter])
+AC_ARG_VAR(PYTHONPATH, [Python module search path])
+
+
+
+# Checks for Python modules and packages.
+
+AC_LANG(C)
+if test "$want_pyre" = yes; then
+ builddir=`pwd`
+ save_PYTHONPATH="$PYTHONPATH"
+ PYTHONPATH="$builddir/python:$PYTHONPATH"; export PYTHONPATH
+ # Cheap work-around for the inability of merlin/setuptools to control #! line.
+ rm -f pyspecfem2D
+ $as_ln_s $PYTHON pyspecfem2D
+ pyspecfem2D="$builddir/pyspecfem2D"
+ cd $srcdir
+
+ AC_MSG_NOTICE([downloading missing Python dependencies])
+ AS_IF([AC_TRY_COMMAND([$pyspecfem2D setup.py install_deps -zmxd $builddir/deps >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD])],
+ [],
+ [AC_MSG_FAILURE([cannot download missing Python dependencies])])
+
+ AC_MSG_NOTICE([building Python dependencies])
+ AS_IF([AC_TRY_COMMAND([$pyspecfem2D setup.py develop -H None -f $builddir/deps -s $builddir -d $builddir/python >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD])],
+ [],
+ [AC_MSG_FAILURE([building Python dependencies])])
+
+ AC_MSG_CHECKING([for egg-related flags])
+ AS_IF([AC_TRY_COMMAND([$pyspecfem2D setup.py egg_flags >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD])],
+ [AC_MSG_RESULT(ok)
+ . egg-flags.sh
+ rm -f egg-flags.sh
+ ],
+ [AC_MSG_RESULT(failed)
+ AC_MSG_FAILURE([cannot scan Python eggs for flags])])
+
+ cd $builddir
+ rm -f pyspecfem2D
+ PYTHONPATH="$save_PYTHONPATH"
+ PYTHONPATH="${pythondir}:${pyexecdir}${save_PYTHONPATH:+:${save_PYTHONPATH}}"
+
+ AC_SUBST(PYTHONPATH)
+ AC_SUBST(PYTHON_EGG_CFLAGS)
+ AC_SUBST(PYTHON_EGG_CPPFLAGS)
+ AC_SUBST(PYTHON_EGG_LDFLAGS)
+fi
+
+
+# Checks for libraries.
+
+
+# Checks for header files.
+
+if test "$want_mpi" = yes; then
+ CIT_FC_MPI_HEADER([$MPIFC], [$FLAGS_NO_CHECK])
+fi
+
+# Checks for typedefs, structures, and compiler characteristics.
+
+if test "$want_pyre" = yes; then
+ CIT_FC_MAIN
+fi
+
+
+# Checks for library functions.
+
+
+AC_CONFIG_FILES([Makefile DATA/Par_file DATA/SOURCE src/meshfem2D/Makefile src/specfem2D/Makefile setup/constants.h setup/precision_mpi.h scotch_5.1.11/src/Makefile.inc])
+AC_OUTPUT
+
+
+dnl end of configure.ac
Deleted: seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.csh
===================================================================
--- seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.csh 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.csh 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,25 +0,0 @@
-#!/bin/csh
-
-# we mimic a triangle of half duration equal to half_duration_triangle
-# using a Gaussian having a very close shape, as explained in Figure 4.2
-# of the manual
-
-set half_duration_triangle = 11.2
-
-foreach file ( $* )
-
-set nlines = `wc -l $file `
-echo $nlines > input_convolve_code.txt
-echo $half_duration_triangle >> input_convolve_code.txt
-# use .true. for a triangle and .false. for a Gaussian
-#echo ".true." >> input_convolve_code.txt
-echo ".false." >> input_convolve_code.txt
-
-echo convolving $file with half_duration_triangle = $half_duration_triangle using lines $nlines
-
-./bin/xconvolve_source_timefunction < $file > ${file}.convolved
-
-rm input_convolve_code.txt
-
-end
-
Added: seismo/2D/SPECFEM2D/trunk/m4/ac_pkg_swig.m4
===================================================================
--- seismo/2D/SPECFEM2D/trunk/m4/ac_pkg_swig.m4 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/m4/ac_pkg_swig.m4 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,126 @@
+# ===========================================================================
+# http://autoconf-archive.cryp.to/ac_pkg_swig.html
+# ===========================================================================
+#
+# SYNOPSIS
+#
+# AC_PROG_SWIG([major.minor.micro])
+#
+# DESCRIPTION
+#
+# This macro searches for a SWIG installation on your system. If found you
+# should call SWIG via $(SWIG). You can use the optional first argument to
+# check if the version of the available SWIG is greater than or equal to
+# the value of the argument. It should have the format: N[.N[.N]] (N is a
+# number between 0 and 999. Only the first N is mandatory.)
+#
+# If the version argument is given (e.g. 1.3.17), AC_PROG_SWIG checks that
+# the swig package is this version number or higher.
+#
+# In configure.in, use as:
+#
+# AC_PROG_SWIG(1.3.17)
+# SWIG_ENABLE_CXX
+# SWIG_MULTI_MODULE_SUPPORT
+# SWIG_PYTHON
+#
+# LAST MODIFICATION
+#
+# 2010-07-17 (Brad Aagaard, permit newer major and minor versions than required)
+#
+# COPYLEFT
+#
+# Copyright (c) 2008 Sebastian Huber <sebastian-huber at web.de>
+# Copyright (c) 2008 Alan W. Irwin <irwin at beluga.phys.uvic.ca>
+# Copyright (c) 2008 Rafael Laboissiere <rafael at laboissiere.net>
+# Copyright (c) 2008 Andrew Collier <colliera at ukzn.ac.za>
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the
+# Free Software Foundation; either version 2 of the License, or (at your
+# option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+# Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program. If not, see <http://www.gnu.org/licenses/>.
+#
+# As a special exception, the respective Autoconf Macro's copyright owner
+# gives unlimited permission to copy, distribute and modify the configure
+# scripts that are the output of Autoconf when processing the Macro. You
+# need not follow the terms of the GNU General Public License when using
+# or distributing such scripts, even though portions of the text of the
+# Macro appear in them. The GNU General Public License (GPL) does govern
+# all other use of the material that constitutes the Autoconf Macro.
+#
+# This special exception to the GPL applies to versions of the Autoconf
+# Macro released by the Autoconf Macro Archive. When you make and
+# distribute a modified version of the Autoconf Macro, you may extend this
+# special exception to the GPL to apply to your modified version as well.
+
+AC_DEFUN([AC_PROG_SWIG],[
+ AC_PATH_PROG([SWIG],[swig])
+ if test -z "$SWIG" ; then
+ AC_MSG_FAILURE([cannot find 'swig' program. Go to http://www.swig.org to download SWIG.])
+ SWIG='echo "Error: SWIG is not installed. SWIG is available at http://www.swig.org". ; false'
+ elif test -n "$1" ; then
+ AC_MSG_CHECKING([for SWIG version])
+ [swig_version=`$SWIG -version 2>&1 | grep 'SWIG Version' | sed 's/.*\([0-9][0-9]*\.[0-9][0-9]*\.[0-9][0-9]*\).*/\1/g'`]
+ AC_MSG_RESULT([$swig_version])
+ if test -n "$swig_version" ; then
+ # Calculate the required version number components
+ [required=$1]
+ [required_major=`echo $required | sed 's/[^0-9].*//'`]
+ if test -z "$required_major" ; then
+ [required_major=0]
+ fi
+ [required=`echo $required | sed 's/[0-9]*[^0-9]//'`]
+ [required_minor=`echo $required | sed 's/[^0-9].*//'`]
+ if test -z "$required_minor" ; then
+ [required_minor=0]
+ fi
+ [required=`echo $required | sed 's/[0-9]*[^0-9]//'`]
+ [required_patch=`echo $required | sed 's/[^0-9].*//'`]
+ if test -z "$required_patch" ; then
+ [required_patch=0]
+ fi
+ # Calculate the available version number components
+ [available=$swig_version]
+ [available_major=`echo $available | sed 's/[^0-9].*//'`]
+ if test -z "$available_major" ; then
+ [available_major=0]
+ fi
+ [available=`echo $available | sed 's/[0-9]*[^0-9]//'`]
+ [available_minor=`echo $available | sed 's/[^0-9].*//'`]
+ if test -z "$available_minor" ; then
+ [available_minor=0]
+ fi
+ [available=`echo $available | sed 's/[0-9]*[^0-9]//'`]
+ [available_patch=`echo $available | sed 's/[^0-9].*//'`]
+ if test -z "$available_patch" ; then
+ [available_patch=0]
+ fi
+ if test $available_major -lt $required_major ; then
+ AC_MSG_FAILURE([SWIG version >= $1 is required. You have $swig_version. Go to http://www.swig.org to get the current version.])
+ SWIG='echo "Error: SWIG version >= $1 is required. You have '"$swig_version"'. Go to http://www.swig.org to get the current version." ; false'
+ elif test $available_major -eq $required_major -a $available_minor -lt $required_minor ; then
+ AC_MSG_FAILURE([SWIG version >= $1 is required. You have $swig_version. Go to http://www.swig.org to get the current version.])
+ SWIG='echo "Error: SWIG version >= $1 is required. You have '"$swig_version"'. Go to http://www.swig.org to get the current version." ; false'
+ elif test $available_major -eq $required_major -a $available_minor -eq $required_minor -a $available_patch -lt $required_patch ; then
+ AC_MSG_FAILURE([SWIG version >= $1 is required. You have $swig_version. Go to http://www.swig.org to get the current version.])
+ SWIG='echo "Error: SWIG version >= $1 is required. You have '"$swig_version"'. Go to http://www.swig.org to get the current version." ; false'
+ else
+ AC_MSG_NOTICE([SWIG executable is '$SWIG'])
+ SWIG_LIB=`$SWIG -swiglib`
+ AC_MSG_NOTICE([SWIG library directory is '$SWIG_LIB'])
+ fi
+ else
+ AC_MSG_FAILURE([cannot determine SWIG version])
+ SWIG='echo "Error: Cannot determine SWIG version. See the SWIG website http://www.swig.org" ; false'
+ fi
+ fi
+ AC_SUBST([SWIG_LIB])
+])
Added: seismo/2D/SPECFEM2D/trunk/m4/cit_fortran.m4
===================================================================
--- seismo/2D/SPECFEM2D/trunk/m4/cit_fortran.m4 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/m4/cit_fortran.m4 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,304 @@
+# -*- Autoconf -*-
+
+
+## ---------------------------- ##
+## Autoconf macros for Fortran. ##
+## ---------------------------- ##
+
+
+# _CIT_FC_MAIN
+# ------------
+# Define {F77,FC}_MAIN to the name of the alternate main() function
+# for use with the Fortran libraries (i.e., MAIN__ or whatever), or
+# 'main' if no such alternate name is found.
+#
+# As of Autoconf 2.59, the macro AC_FC_MAIN does not work with ifort
+# v9, because the macro assumes that 'main' will be resolved by
+# FCLIBS, but FCLIBS does not include Intel's 'for_main.o'. This
+# macro simply links with the Fortran compiler instead.
+#
+AC_DEFUN([_CIT_FC_MAIN],
+[_AC_FORTRAN_ASSERT()dnl
+AC_CACHE_CHECK([for alternate main to link with Fortran libraries],
+ ac_cv_[]_AC_LANG_ABBREV[]_main,
+[ac_[]_AC_LANG_ABBREV[]_m_save_LIBS=$LIBS
+ LIBS="cfortran_test.$ac_objext $LIBS"
+ ac_fortran_dm_var=[]_AC_FC[]_DUMMY_MAIN
+ ac_cv_fortran_main="main" # default entry point name
+ for ac_func in MAIN__ MAIN_ __main MAIN _MAIN __MAIN main_ main__ _main; do
+ AC_LANG_PUSH(C)
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([@%:@ifdef FC_DUMMY_MAIN_EQ_F77
+@%:@ undef F77_DUMMY_MAIN
+@%:@ undef FC_DUMMY_MAIN
+@%:@else
+@%:@ undef $ac_fortran_dm_var
+@%:@endif
+@%:@define main $ac_func])],
+ [mv conftest.$ac_objext cfortran_test.$ac_objext],
+ [AC_MSG_FAILURE([cannot compile a simple C program])])
+ AC_LANG_POP(C)
+ AC_LINK_IFELSE([AC_LANG_SOURCE(
+[ subroutine foobar()
+ return
+ end])], [ac_cv_fortran_main=$ac_func; break])
+ rm -f cfortran_test* conftest*
+ done
+ ac_cv_[]_AC_LANG_ABBREV[]_main=$ac_cv_fortran_main
+ rm -f cfortran_test* conftest*
+ LIBS=$ac_[]_AC_LANG_ABBREV[]_m_save_LIBS
+])
+AC_DEFINE_UNQUOTED([]_AC_FC[]_MAIN, $ac_cv_[]_AC_LANG_ABBREV[]_main,
+ [Define to alternate name for `main' routine that is
+ called from a `main' in the Fortran libraries.])
+])# _CIT_FC_MAIN
+
+
+# CIT_F77_MAIN
+# ------------
+AC_DEFUN([CIT_F77_MAIN],
+[AC_REQUIRE([AC_F77_LIBRARY_LDFLAGS])dnl
+AC_LANG_PUSH(Fortran 77)dnl
+_AC_FC_MAIN
+AC_LANG_POP(Fortran 77)dnl
+])# CIT_F77_MAIN
+
+
+# CIT_FC_MAIN
+# -----------
+AC_DEFUN([CIT_FC_MAIN],
+[AC_REQUIRE([AC_FC_LIBRARY_LDFLAGS])dnl
+AC_LANG_PUSH(Fortran)dnl
+_CIT_FC_MAIN
+AC_LANG_POP(Fortran)dnl
+])# CIT_FC_MAIN
+
+
+# CIT_FC_OPEN_APPEND
+# ------------------
+AC_DEFUN([CIT_FC_OPEN_APPEND], [
+AC_LANG_PUSH(Fortran)
+cit_fc_append=no
+AC_MSG_CHECKING([whether $FC supports OPEN control item 'position="append"'])
+AC_COMPILE_IFELSE([
+ AC_LANG_PROGRAM([], [[ open(10,file="foo",status="old",position="append")]])
+], [
+ AC_MSG_RESULT(yes)
+ FCFLAGS="-DFORTRAN_POSITION_APPEND $FCFLAGS"; export FCFLAGS
+ cit_fc_append=yes
+], [
+ AC_MSG_RESULT(no)
+])
+AC_MSG_CHECKING([whether $FC supports OPEN control item 'access="append"'])
+AC_COMPILE_IFELSE([
+ AC_LANG_PROGRAM([], [[ open(10,file="foo",status="old",access="append")]])
+], [
+ AC_MSG_RESULT(yes)
+ FCFLAGS="-DFORTRAN_ACCESS_APPEND $FCFLAGS"; export FCFLAGS
+ cit_fc_append=yes
+], [
+ AC_MSG_RESULT(no)
+])
+AS_IF([test $cit_fc_append = yes], [], [
+ AC_MSG_FAILURE([cannot determine method for appending to Fortran files])
+])
+AC_LANG_POP(Fortran)
+])dnl CIT_FC_OPEN_APPEND
+
+
+# CIT_FC_STREAM_IO
+# ----------------
+AC_DEFUN([CIT_FC_STREAM_IO], [
+AC_LANG_PUSH(Fortran)
+AC_MSG_CHECKING([whether $FC supports stream i/o])
+AC_COMPILE_IFELSE([
+ AC_LANG_PROGRAM([], [[ open(10,file="foo",status="new",access="stream",
+ & form="unformatted")
+ write(10,pos=1) 1,2,3.0d0]])
+], [
+ AC_MSG_RESULT(yes)
+ FCFLAGS="-DFORTRAN_STREAM_IO $FCFLAGS"; export FCFLAGS
+], [
+ AC_MSG_RESULT(no)
+ AC_MSG_CHECKING([whether $FC supports f77-style binary direct-access i/o])
+ AC_COMPILE_IFELSE([
+ AC_LANG_PROGRAM([], [[ open(10,file="foo",status="new",access="direct",recl=1,
+ & form="unformatted")
+ write(10,rec=1) 1,2,3.0d0]])
+ ], [
+ AC_MSG_RESULT(yes)
+ FCFLAGS="-DFORTRAN_F77_IO $FCFLAGS"; export FCFLAGS
+ AC_MSG_CHECKING([whether $FC supports I/O specifiers 'advance' and 'eor'])
+ AC_COMPILE_IFELSE([
+ AC_LANG_PROGRAM([], [[ open(10,file="foo",status="new",access="direct",recl=1,
+ & form="unformatted")
+ write(10,rec=1,advance='yes',eor=10) 1,2,3.0d0
+ 10 continue]])
+ ], [
+ AC_MSG_RESULT(yes)
+ FCFLAGS="-DFORTRAN_EOR $FCFLAGS"; export FCFLAGS
+ ], [
+ AC_MSG_RESULT(no)
+ ])
+ ], [
+ AC_MSG_RESULT(no)
+ AC_MSG_WARN([cannot determine how to produce binary direct-access files with variable record length])
+ FCFLAGS="-DFORTRAN_NO_BINARY $FCFLAGS"; export FCFLAGS
+ ])
+])
+AC_LANG_POP(Fortran)
+])dnl CIT_FC_STREAM_IO
+
+
+# CIT_FC_MPI_MODULE(FILENAME, MPIFC, MPIFCFLAGS)
+# -----------------------------------------------------
+AC_DEFUN([CIT_FC_MPI_MODULE], [
+# Use 'mpi' module or 'mpif.h', as appropriate. UNFINISHED. This
+# strategy doesn't play well with "implicit none": whether the
+# generated header must be included before or after "implicit none"
+# depends upon the result of the test! It might be possible to make
+# "use mpi" always work: simply generate an 'mpi' module if the MPI
+# library doesn't provide one. The generated module would simply
+# "include 'mpif.h'".
+AC_LANG_PUSH(Fortran)
+
+ofile=$1
+cfgfile="${ofile}T"
+trap "rm \"$cfgfile\"; exit 1" 1 2 15
+rm -f "$cfgfile"
+
+cit_fc_save_fc=$FC
+cit_fc_save_fcflags=$FCFLAGS
+FC=$2
+FCFLAGS="$FCFLAGS $3"
+
+AC_MSG_CHECKING([whether "use mpi" works])
+AC_COMPILE_IFELSE([
+ AC_LANG_PROGRAM([], [[
+ use mpi
+ integer ier
+ call MPI_INIT(ier)
+ call MPI_FINALIZE(ier)
+]])
+], [
+ AC_MSG_RESULT(yes)
+ cit_fc_header="use mpi"
+], [
+ AC_MSG_RESULT(no)
+ AC_MSG_CHECKING([whether mpif.h works])
+ AC_COMPILE_IFELSE([
+ AC_LANG_PROGRAM([], [[
+ include 'mpif.h'
+ integer ier
+ call MPI_INIT(ier)
+ call MPI_FINALIZE(ier)
+]])
+ ], [
+ AC_MSG_RESULT(yes)
+dnl Allow projects to simply include the standard 'mpif.h' everywhere.
+dnl If FILENAME is 'mpif.h', this macro will conditionally create a header
+dnl to override the system header.
+ if test "$ofile" = "mpif.h"; then
+ cit_fc_header=none
+ else
+ cit_fc_header="include 'mpif.h'"
+ fi
+ ], [
+ AC_MSG_RESULT(no)
+ AC_MSG_FAILURE([cannot compile a trivial MPI program using $2])
+ ])
+])
+
+if test "$cit_fc_header" != "none"; then
+ AC_MSG_NOTICE([creating $ofile])
+ cat >"$cfgfile" <<END_OF_HEADER
+! $ofile. Generated by configure.
+
+ $cit_fc_header
+
+END_OF_HEADER
+ mv -f "$cfgfile" "$ofile" || \
+ (rm -f "$ofile" && cp "$cfgfile" "$ofile" && rm -f "$cfgfile")
+fi
+
+
+FC=$cit_fc_save_fc
+FCFLAGS=$cit_fc_save_fcflags
+
+AC_LANG_POP(Fortran)
+])dnl CIT_FC_MPI_MODULE
+
+
+# CIT_FC_MPI_HEADER(MPIFC, MPIFCFLAGS)
+# -----------------------------------------------------
+AC_DEFUN([CIT_FC_MPI_HEADER], [
+# Generate a Fortran 9x-compatible 'mpif.h', if necessary.
+AC_LANG_PUSH(Fortran)
+
+ofile="mpif.h"
+cfgfile="${ofile}T"
+trap "rm \"$cfgfile\"; exit 1" 1 2 15
+rm -f "$cfgfile"
+
+cit_fc_save_fc=$FC
+cit_fc_save_fcflags=$FCFLAGS
+FC=$1
+FCFLAGS="$FCFLAGS $2"
+
+AC_MSG_CHECKING([whether mpif.h works])
+AC_COMPILE_IFELSE(_CIT_FC_TRIVIAL_MPI_PROGRAM, [
+ AC_MSG_RESULT(yes)
+], [
+ AC_MSG_RESULT(no)
+ cit_mpif_h=unknown
+ cit_mpifc_info=`$FC -compile_info 2>/dev/null`
+ for cit_arg in $cit_mpifc_info; do
+ case $cit_arg in
+ */mpif.h) cit_mpif_h="$cit_arg"; break;;
+ esac
+ done
+ if test "$cit_mpif_h" == "unknown"; then
+ AC_MSG_FAILURE([cannot compile a trivial MPI program using $1])
+ fi
+
+dnl Special hack for MPICH.
+ AC_MSG_NOTICE([creating $ofile])
+ cat >"$cfgfile" <<END_OF_HEADER
+! $ofile. Generated from $cit_mpif_h by configure.
+
+END_OF_HEADER
+ grep -v MPI_DISPLACEMENT_CURRENT "$cit_mpif_h" >>"$cfgfile"
+ mv -f "$cfgfile" "$ofile" || \
+ (rm -f "$ofile" && cp "$cfgfile" "$ofile" && rm -f "$cfgfile")
+
+ AC_MSG_CHECKING([whether generated mpif.h works])
+ AC_COMPILE_IFELSE(_CIT_FC_TRIVIAL_MPI_PROGRAM, [
+ AC_MSG_RESULT(yes)
+ ], [
+ AC_MSG_RESULT(no)
+ AC_MSG_FAILURE([cannot compile a trivial MPI program using $1])
+ ])
+
+])
+
+FC=$cit_fc_save_fc
+FCFLAGS=$cit_fc_save_fcflags
+
+AC_LANG_POP(Fortran)
+])dnl CIT_FC_MPI_HEADER
+
+
+# _CIT_FC_TRIVIAL_MPI_PROGRAM
+# ------------------------
+AC_DEFUN([_CIT_FC_TRIVIAL_MPI_PROGRAM], [
+AC_LANG_PROGRAM([], [[
+ include 'mpif.h'
+ integer, parameter :: CUSTOM_MPI_TYPE = MPI_REAL
+ integer ier
+ call MPI_INIT(ier)
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+ call MPI_FINALIZE(ier)
+]])
+])dnl _CIT_FC_TRIVIAL_MPI_PROGRAM
+
+
+dnl end of file
Added: seismo/2D/SPECFEM2D/trunk/m4/cit_funcstring.m4
===================================================================
--- seismo/2D/SPECFEM2D/trunk/m4/cit_funcstring.m4 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/m4/cit_funcstring.m4 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,47 @@
+# -*- Autoconf -*-
+
+## Autoconf macro for testing if compiler provides string with
+## function names.
+##
+
+# CIT_HAVE_FUNTIONSTRING
+# Defines preprocessor macro __FUNCTION_NAME__.
+# ------------
+AC_DEFUN([CIT_FUNCTIONSTRING], [
+ AC_LANG(C++)
+ set_function_name=no
+
+ AC_MSG_CHECKING([whether C++ compiler defines __PRETTY_FUNCTION__])
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[]],
+ [[const char* name = __PRETTY_FUNCTION__;]])],
+ [AC_MSG_RESULT(yes)
+ set_function_name=yes
+ AC_DEFINE([__FUNCTION_NAME__], [__PRETTY_FUNCTION__], [Define __FUNCTION_NAME__ to __PRETTY_FUNCTION__.])],
+ [AC_MSG_RESULT(no)])
+
+ if test "$set_function_name" == no; then
+ AC_MSG_CHECKING([whether C++ compiler defines __FUNCTION__])
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[]],
+ [[const char* name = __FUNCTION__;]])],
+ [AC_MSG_RESULT(yes)
+ set_function_name=yes
+ AC_DEFINE([__FUNCTION_NAME__], [__FUNCTION__], [Define __FUNCTION_NAME__ to __FUNCTION__.])],
+ [AC_MSG_RESULT(no)])
+ fi
+
+ if test "$set_function_name" == no; then
+ AC_MSG_CHECKING([whether C++ compiler defines __func__])
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([[]],
+ [[const char* name = __func__;]])],
+ [AC_MSG_RESULT(yes)
+ set_function_name=yes
+ AC_DEFINE([__FUNCTION_NAME__], [__func__], [Define __FUNCTION_NAME__ to __func__.])],
+ [AC_MSG_RESULT(no)])
+ fi
+]))
+
+
+dnl end of file
Added: seismo/2D/SPECFEM2D/trunk/m4/cit_hdf.m4
===================================================================
--- seismo/2D/SPECFEM2D/trunk/m4/cit_hdf.m4 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/m4/cit_hdf.m4 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,81 @@
+# -*- Autoconf -*-
+
+
+## ------------------------ ##
+## Autoconf macros for HDF. ##
+## ------------------------ ##
+
+
+# CIT_ARG_HDF5
+# ------------
+AC_DEFUN([CIT_ARG_HDF5], [
+# $Id: cit_hdf.m4 5189 2006-11-07 02:29:23Z leif $
+AC_ARG_VAR(PHDF5_HOME, [home path to HDF5 library])
+AC_ARG_WITH([hdf5],
+ [AC_HELP_STRING([--with-hdf5],
+ [enable HDF5 output @<:@default=$1@:>@])],
+ [want_hdf5="$withval"],
+ [want_hdf5=$1])
+])dnl CIT_ARG_HDF5
+
+
+# CIT_CHECK_LIB_HDF5
+# ------------------
+AC_DEFUN([CIT_CHECK_LIB_HDF5], [
+# $Id: cit_hdf.m4 5189 2006-11-07 02:29:23Z leif $
+if test "$want_hdf5" != no; then
+ if test -n "$PHDF5_HOME"; then
+ LDFLAGS="-L$PHDF5_HOME/lib $LDFLAGS"
+ fi
+ # check for basic HDF5 function
+ AC_SEARCH_LIBS([H5Fopen], [hdf5], [], [
+ if test "$want_hdf5" = auto; then
+ want_hdf5=no
+ AC_MSG_WARN([HDF5 library not found; disabling HDF5 support])
+ else
+ AC_MSG_ERROR([HDF5 library not found; try setting PHDF5_HOME])
+ fi
+ ])
+fi
+])dnl CIT_CHECK_LIB_HDF5
+
+
+# CIT_CHECK_LIB_HDF5_PARALLEL
+# ---------------------------
+AC_DEFUN([CIT_CHECK_LIB_HDF5_PARALLEL], [
+# $Id: cit_hdf.m4 5189 2006-11-07 02:29:23Z leif $
+if test "$want_hdf5" != no; then
+ # check for HDF5 parallel-IO function
+ AC_SEARCH_LIBS([H5Pset_dxpl_mpio], [hdf5], [], [
+ if test "$want_hdf5" = auto; then
+ want_hdf5=no
+ AC_MSG_WARN([parallel HDF5 library not found; disabling HDF5 support])
+ else
+ AC_MSG_ERROR([parallel HDF5 library not found; try configuring HDF5 with '--enable-parallel'])
+ fi
+ ])
+fi
+])dnl CIT_CHECK_LIB_HDF5_PARALLEL
+
+
+# CIT_CHECK_HEADER_HDF5
+# ---------------------
+AC_DEFUN([CIT_CHECK_HEADER_HDF5], [
+# $Id: cit_hdf.m4 5189 2006-11-07 02:29:23Z leif $
+if test "$want_hdf5" != no; then
+ if test -n "$PHDF5_HOME"; then
+ CPPFLAGS="-I$PHDF5_HOME/include $CPPFLAGS"
+ fi
+ AC_CHECK_HEADERS([hdf5.h], [AC_DEFINE([HAVE_HDF5_H])], [
+ if test "$want_hdf5" = auto; then
+ want_hdf5=no
+ AC_MSG_WARN([header 'hdf5.h' not found; disabling HDF5 support])
+ else
+ AC_MSG_ERROR([header 'hdf5.h' not found])
+ fi
+ ])
+fi
+])dnl CIT_CHECK_HEADER_HDF5
+
+
+dnl end of file
Added: seismo/2D/SPECFEM2D/trunk/m4/cit_mpi.m4
===================================================================
--- seismo/2D/SPECFEM2D/trunk/m4/cit_mpi.m4 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/m4/cit_mpi.m4 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,489 @@
+# -*- Autoconf -*-
+
+
+## ------------------------ ##
+## Autoconf macros for MPI. ##
+## ------------------------ ##
+
+
+# CIT_PROG_MPICC
+# --------------
+# Call AC_PROG_CC, but prefer MPI C wrappers to a bare compiler in
+# the search list. Set MPICC to the program/wrapper used to compile
+# C MPI programs. Set CC to the compiler used to compile ordinary
+# C programs, and link shared libraries of all types (see the
+# comment about the MPI library, below). Make sure that CC and
+# MPICC both represent the same underlying C compiler.
+AC_DEFUN([CIT_PROG_MPICC], [
+# $Id: cit_mpi.m4 7980 2007-09-18 01:01:59Z leif $
+AC_PROVIDE([_CIT_PROG_MPICC])dnl
+AC_REQUIRE([_CIT_PROG_MPICC_SEARCH_LIST])dnl
+AC_BEFORE([$0], [AC_PROG_CC])
+AC_ARG_VAR(MPICC, [MPI C compiler command])
+AC_SUBST([MPICC])
+test -z "$want_mpi" && want_mpi=yes
+# The 'cit_compiler_search_list' is the result of merging the
+# following:
+# * MPI C wrappers
+# * the range of values for config's COMPILER_CC_NAME
+# (cc cl ecc gcc icc pgcc xlc xlc_r)
+# Newer names are tried first (e.g., icc before ecc).
+cit_compiler_search_list="gcc cc cl icc ecc pgcc xlc xlc_r"
+# There are two C command variables, so there are four cases to
+# consider:
+#
+# ./configure CC=gcc MPICC=mpicc # save MPICC as cit_MPICC; MPICC=$CC
+# ./configure CC=gcc # MPICC=$CC, guess cit_MPICC
+# ./configure MPICC=mpicc # derive CC
+# ./configure # guess MPICC and derive CC
+#
+# In the cases where CC is explicitly specified, the MPI C wrapper
+# (cit_MPICC, if known) is only used to gather compile/link flags (if
+# needed).
+if test "$want_mpi" = yes; then
+ if test -n "$CC"; then
+ cit_MPICC_underlying_CC=$CC
+ if test -n "$MPICC"; then
+ # CC=gcc MPICC=mpicc
+ cit_MPICC=$MPICC
+ MPICC=$CC
+ else
+ # CC=gcc MPICC=???
+ AC_CHECK_PROGS(cit_MPICC, $cit_mpicc_search_list)
+ fi
+ else
+ if test -n "$MPICC"; then
+ # CC=??? MPICC=mpicc
+ cit_MPICC=$MPICC
+ CC=$MPICC # will be reevaluated below
+ else
+ # CC=??? MPICC=???
+ cit_compiler_search_list="$cit_mpicc_search_list $cit_compiler_search_list"
+ fi
+ fi
+fi
+AC_PROG_CC($cit_compiler_search_list)
+if test "$want_mpi" = yes; then
+ if test -z "$MPICC"; then
+ MPICC=$CC
+ fi
+ if test -z "$cit_MPICC"; then
+ case $MPICC in
+ *mp* | hcc)
+ cit_MPICC=$MPICC
+ ;;
+ esac
+ fi
+ # The MPI library is typically static. Linking a shared object
+ # against static library is non-portable, and needlessly bloats our
+ # Python extension modules on the platforms where it does work.
+ # Unless CC was set explicitly, attempt to set CC to the underlying
+ # compiler command, so that we may link with the matching C
+ # compiler, but omit -lmpi/-lmpich from the link line.
+ if test -z "$cit_MPICC_underlying_CC"; then
+ if test -n "$cit_MPICC"; then
+ AC_MSG_CHECKING([for the C compiler underlying $cit_MPICC])
+ CC=
+ AC_LANG_PUSH(C)
+ for cit_arg_show in CIT_MPI_COMPILE_INFO_SWITCHES
+ do
+ cit_cmd="$cit_MPICC -c $cit_arg_show"
+ if $cit_cmd >/dev/null 2>&1; then
+ CC=`$cit_cmd 2>/dev/null | sed 's/ .*//'`
+ if test -n "$CC"; then
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM()], [break 2], [CC=])
+ fi
+ fi
+ done
+ AC_LANG_POP(C)
+ if test -n "$CC"; then
+ AC_MSG_RESULT($CC)
+ else
+ AC_MSG_RESULT(failed)
+ AC_MSG_FAILURE([can not determine the C compiler underlying $cit_MPICC])
+ fi
+ fi
+ cit_MPICC_underlying_CC=$CC
+ fi
+fi
+])dnl CIT_PROG_MPICC
+
+
+# _CIT_PROG_MPICC
+# ---------------
+# Search for an MPI C wrapper. ~ This private macro is employed by
+# C++-only projects (via CIT_CHECK_LIB_MPI and CIT_HEADER_MPI). It
+# handles the case where an MPI C wrapper is present, but an MPI C++
+# wrapper is missing or broken. This can happen if a C++ compiler was
+# not found/specified when MPI was installed.
+AC_DEFUN([_CIT_PROG_MPICC], [
+AC_REQUIRE([_CIT_PROG_MPICC_SEARCH_LIST])dnl
+AC_CHECK_PROGS(cit_MPICC, $cit_mpicc_search_list)
+])dnl _CIT_PROG_MPICC
+
+
+# _CIT_PROG_MPICC_SEARCH_LIST
+# ---------------------------
+AC_DEFUN([_CIT_PROG_MPICC_SEARCH_LIST], [
+# $Id: cit_mpi.m4 7980 2007-09-18 01:01:59Z leif $
+cit_mpicc_search_list="mpicc hcc mpcc mpcc_r mpxlc cmpicc"
+])dnl _CIT_PROG_MPICC_SEARCH_LIST
+
+
+# CIT_PROG_MPICXX
+# ---------------
+# Call AC_PROG_CXX, but prefer MPI C++ wrappers to a bare compiler in
+# the search list. Set MPICXX to the program/wrapper used to compile
+# C++ MPI programs. Set CXX to the compiler used to compile ordinary
+# C++ programs, and link shared libraries of all types (see the
+# comment about the MPI library, below). Make sure that CXX and
+# MPICXX both represent the same underlying C++ compiler.
+AC_DEFUN([CIT_PROG_MPICXX], [
+# $Id: cit_mpi.m4 7980 2007-09-18 01:01:59Z leif $
+AC_BEFORE([$0], [AC_PROG_CXX])
+AC_ARG_VAR(MPICXX, [MPI C++ compiler command])
+AC_SUBST([MPICXX])
+test -z "$want_mpi" && want_mpi=yes
+# The 'cit_compiler_search_list' is the result of merging the
+# following:
+# * MPI C++ wrappers
+# * the Autoconf default (g++ c++ gpp aCC CC cxx cc++ cl
+# FCC KCC RCC xlC_r xlC)
+# * the range of values for config's COMPILER_CXX_NAME (aCC CC cl
+# cxx ecpc g++ icpc KCC pgCC xlC xlc++_r xlC_r)
+# Newer names are tried first (e.g., icpc before ecpc).
+cit_compiler_search_list="g++ c++ gpp aCC CC cxx cc++ cl FCC KCC RCC xlc++_r xlC_r xlC"
+cit_compiler_search_list="$cit_compiler_search_list icpc ecpc pgCC"
+cit_mpicxx_search_list="mpicxx mpic++ mpiCC hcp mpCC mpxlC mpxlC_r cmpic++"
+# There are two C++ command variables, so there are four cases to
+# consider:
+#
+# ./configure CXX=g++ MPICXX=mpicxx # save MPICXX as cit_MPICXX; MPICXX=$CXX
+# ./configure CXX=g++ # MPICXX=$CXX, guess cit_MPICXX
+# ./configure MPICXX=mpicxx # derive CXX
+# ./configure # guess MPICXX and derive CXX
+#
+# In the cases where CXX is explicitly specified, the MPI C++ wrapper
+# (cit_MPICXX, if known) is only used to gather compile/link flags (if
+# needed).
+if test "$want_mpi" = yes; then
+ if test -n "$CXX"; then
+ cit_MPICXX_underlying_CXX=$CXX
+ if test -n "$MPICXX"; then
+ # CXX=g++ MPICXX=mpicxx
+ cit_MPICXX=$MPICXX
+ MPICXX=$CXX
+ else
+ # CXX=g++ MPICXX=???
+ AC_CHECK_PROGS(cit_MPICXX, $cit_mpicxx_search_list)
+ fi
+ else
+ if test -n "$MPICXX"; then
+ # CXX=??? MPICXX=mpicxx
+ cit_MPICXX=$MPICXX
+ CXX=$MPICXX # will be reevaluated below
+ else
+ # CXX=??? MPICXX=???
+ cit_compiler_search_list="$cit_mpicxx_search_list $cit_compiler_search_list"
+ fi
+ fi
+fi
+AC_PROG_CXX($cit_compiler_search_list)
+if test "$want_mpi" = yes; then
+ if test -z "$MPICXX"; then
+ MPICXX=$CXX
+ fi
+ if test -z "$cit_MPICXX"; then
+ case $MPICXX in
+ *mp* | hcp)
+ cit_MPICXX=$MPICXX
+ ;;
+ esac
+ fi
+ # The MPI library is typically static. Linking a shared object
+ # against static library is non-portable, and needlessly bloats our
+ # Python extension modules on the platforms where it does work.
+ # Unless CXX was set explicitly, attempt to set CXX to the underlying
+ # compiler command, so that we may link with the matching C++
+ # compiler, but omit -lmpi/-lmpich from the link line.
+ if test -z "$cit_MPICXX_underlying_CXX"; then
+ if test -n "$cit_MPICXX"; then
+ AC_MSG_CHECKING([for the C++ compiler underlying $cit_MPICXX])
+ CXX=
+ AC_LANG_PUSH(C++)
+ for cit_arg_show in CIT_MPI_COMPILE_INFO_SWITCHES
+ do
+ cit_cmd="$cit_MPICXX -c $cit_arg_show"
+ if $cit_cmd >/dev/null 2>&1; then
+ CXX=`$cit_cmd 2>/dev/null | sed 's/ .*//'`
+ if test -n "$CXX"; then
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM()], [break 2], [CXX=])
+ fi
+ fi
+ done
+ AC_LANG_POP(C++)
+ if test -n "$CXX"; then
+ AC_MSG_RESULT($CXX)
+ else
+ AC_MSG_RESULT(failed)
+ AC_MSG_FAILURE([can not determine the C++ compiler underlying $cit_MPICXX])
+ fi
+ fi
+ cit_MPICXX_underlying_CXX=$CXX
+ fi
+fi
+])dnl CIT_PROG_MPICXX
+dnl end of file
+
+
+# CIT_CHECK_LIB_MPI
+# -----------------
+AC_DEFUN([CIT_CHECK_LIB_MPI], [
+# $Id: cit_mpi.m4 7980 2007-09-18 01:01:59Z leif $
+AC_REQUIRE([_CIT_PROG_MPICC])dnl
+AC_ARG_VAR(MPILIBS, [MPI linker flags, e.g. -L<mpi lib dir> -lmpi])
+AC_SUBST(MPILIBS)
+cit_mpi_save_CC=$CC
+cit_mpi_save_CXX=$CXX
+cit_mpi_save_LIBS=$LIBS
+CC=$MPICC
+CXX=$MPICXX
+LIBS="$MPILIBS $LIBS"
+# If MPILIBS is set, check to see if it works.
+# If MPILIBS is not set, check to see if it is needed.
+AC_CHECK_FUNC(MPI_Init, [], [
+ if test -n "$MPILIBS"; then
+ AC_MSG_ERROR([function MPI_Init not found; check MPILIBS])
+ fi
+ # MPILIBS is needed but was not set.
+ AC_LANG_CASE(
+ [C], [
+ cit_mpicmd=$cit_MPICC
+ ],
+ [C++], [
+ cit_mpicmd=$cit_MPICXX
+ test -z "$cit_mpicmd" && cit_mpicmd=$cit_MPICC
+ ]
+ )
+ if test -n "$cit_mpicmd"; then
+ # Try to guess the correct value for MPILIBS using an MPI wrapper.
+ CIT_MPI_LIBS(cit_libs, $cit_mpicmd, [
+ LIBS="$cit_libs $cit_mpi_save_LIBS"
+ unset ac_cv_func_MPI_Init
+ AC_CHECK_FUNC(MPI_Init, [
+ MPILIBS=$cit_libs
+ export MPILIBS
+ ], [
+ _CIT_CHECK_LIB_MPI_FAILED
+ ])
+ ], [
+ _CIT_CHECK_LIB_MPI_FAILED
+ ])
+ else
+ # Desperate, last-ditch effort.
+ cit_libs=
+ for cit_lib in mpi mpich; do
+ AC_CHECK_LIB($cit_lib, MPI_Init, [
+ cit_libs="-l$cit_lib"
+ MPILIBS=$cit_libs
+ export MPILIBS
+ break])
+ done
+ if test -z "$cit_libs"; then
+ _CIT_CHECK_LIB_MPI_FAILED
+ fi
+ fi
+])
+LIBS=$cit_mpi_save_LIBS
+CXX=$cit_mpi_save_CXX
+CC=$cit_mpi_save_CC
+])dnl CIT_CHECK_LIB_MPI
+
+
+# _CIT_CHECK_LIB_MPI_FAILED
+# -------------------------
+AC_DEFUN([_CIT_CHECK_LIB_MPI_FAILED], [
+AC_MSG_ERROR([no MPI library found
+
+ Set the MPICC, MPICXX, MPIINCLUDES, and MPILIBS environment variables
+ to specify how to build MPI programs.
+])
+])dnl _CIT_CHECK_LIB_MPI_FAILED
+
+
+# CIT_HEADER_MPI
+# --------------
+AC_DEFUN([CIT_HEADER_MPI], [
+# $Id: cit_mpi.m4 7980 2007-09-18 01:01:59Z leif $
+AC_LANG_CASE(
+ [C], [
+ AC_CHECK_HEADER([mpi.h], [], [AC_MSG_ERROR([header 'mpi.h' not found])])
+ ],
+ [C++], [
+ CIT_MPI_CHECK_CXX_LINK(cit_MPI_CPPFLAGS, [],
+ _CIT_TRIVIAL_MPI_PROGRAM,
+ [whether we can link a trivial C++ MPI program],
+ [],
+ AC_MSG_FAILURE([cannot link a trivial C++ MPI program using $CXX]))
+ CPPFLAGS="$cit_MPI_CPPFLAGS $CPPFLAGS"
+])
+])dnl CIT_HEADER_MPI
+
+
+# CIT_MPI_CHECK_CXX_LINK(INCLUDES, LIBS, PROGRAM,
+# MSG, IF-WORKS, IF-NOT)
+# -----------------------------------------------
+AC_DEFUN([CIT_MPI_CHECK_CXX_LINK], [
+# $Id: cit_mpi.m4 7980 2007-09-18 01:01:59Z leif $
+AC_LANG_ASSERT(C++)
+AC_MSG_CHECKING($4)
+CIT_MPI_CXX_LINK_IFELSE(cit_arg, $$1, $2, $3,
+[
+ if test -z "$cit_arg"; then
+ AC_MSG_RESULT(yes)
+ else
+ AC_MSG_RESULT([yes, with $cit_arg])
+ fi
+ $1="$cit_arg [$]$1"
+ $5
+], [
+ AC_MSG_RESULT(no)
+ $6
+])
+])
+
+
+# CIT_MPI_CXX_LINK_IFELSE(DEFINES,
+# INCLUDES, LIBS, PROGRAM,
+# IF-WORKS, IF-NOT)
+# ------------------------------------------------
+# Verify that the MPI library is link-compatible with CXX (which could
+# be different than the C++ compiler used to build the MPI library) by
+# attempting to compile and link PROGRAM. If there is a problem,
+# attempt to work-around it by preventing MPI's C++ bindings from
+# being #included. If successful, set DEFINES to the preprocessor
+# flags (if any) needed to successfully compile and link PROGRAM and
+# evaluate IF-WORKS; otherwise, evaluate IF-NOT.
+AC_DEFUN([CIT_MPI_CXX_LINK_IFELSE], [
+# $Id: cit_mpi.m4 7980 2007-09-18 01:01:59Z leif $
+AC_LANG_ASSERT(C++)
+$1=
+cit_mpi_cxx_link_save_LIBS=$LIBS
+cit_mpi_cxx_link_save_CPPFLAGS=$CPPFLAGS
+LIBS="$3 $LIBS"
+CPPFLAGS="$2 $cit_mpi_cxx_link_save_CPPFLAGS"
+AC_LINK_IFELSE([$4], [$5], [
+ for cit_skip_mpicxx_define in CIT_SKIP_MPICXX_DEFINES
+ do
+ CPPFLAGS="$cit_skip_mpicxx_define $2 $cit_mpi_cxx_link_save_CPPFLAGS"
+ AC_LINK_IFELSE([$4], [
+ $1=$cit_skip_mpicxx_define
+ $5
+ break
+ ], [
+ $6
+ ])
+ done
+])
+CPPFLAGS=$cit_mpi_cxx_link_save_CPPFLAGS
+LIBS=$cit_mpi_cxx_link_save_LIBS
+])dnl CIT_MPI_CXX_LINK_IFELSE
+
+
+# _CIT_TRIVIAL_MPI_PROGRAM
+# ------------------------
+AC_DEFUN([_CIT_TRIVIAL_MPI_PROGRAM], [
+AC_LANG_PROGRAM([[
+#include <stdio.h>
+#include <mpi.h>
+]], [[
+ MPI_Init(0,0);
+ MPI_Finalize();
+]])
+])dnl _CIT_TRIVIAL_MPI_PROGRAM
+
+
+# CIT_MPI_LIBS(LIBS, COMMAND,
+# ACTION-IF-FOUND, ACTION-IF-NOT-FOUND)
+# -------------------------------------------------------
+# Guess the libraries used by the MPI wrapper.
+AC_DEFUN([CIT_MPI_LIBS], [
+# $Id: cit_mpi.m4 7980 2007-09-18 01:01:59Z leif $
+AC_MSG_CHECKING([for the libraries used by $2])
+$1=
+for cit_arg_show in CIT_MPI_LINK_INFO_SWITCHES
+do
+ cit_cmd="$2 $cit_arg_show"
+ if $cit_cmd >/dev/null 2>&1; then
+ cit_args=`$cit_cmd 2>/dev/null`
+ test -z "$cit_args" && continue
+ for cit_arg in $cit_args
+ do
+ case $cit_arg in
+ -L* | -l* | -pthread* [)] $1="[$]$1 $cit_arg" ;;
+ esac
+ done
+ test -z "[$]$1" && continue
+ break
+ fi
+done
+if test -n "[$]$1"; then
+ AC_MSG_RESULT([[$]$1])
+ $3
+else
+ AC_MSG_RESULT(failed)
+ $4
+fi
+])dnl CIT_MPI_LIBS
+
+
+# CIT_MPI_INCLUDES(INCLUDES, COMMAND,
+# ACTION-IF-FOUND, ACTION-IF-NOT-FOUND)
+# ----------------------------------------------------------
+# Guess the includes used by the MPI wrapper.
+AC_DEFUN([CIT_MPI_INCLUDES], [
+# $Id: cit_mpi.m4 7980 2007-09-18 01:01:59Z leif $
+AC_MSG_CHECKING([for the includes used by $2])
+$1=
+for cit_arg_show in CIT_MPI_COMPILE_INFO_SWITCHES
+do
+ cit_cmd="$2 -c $cit_arg_show"
+ if $cit_cmd >/dev/null 2>&1; then
+ cit_args=`$cit_cmd 2>/dev/null`
+ test -z "$cit_args" && continue
+ for cit_arg in $cit_args
+ do
+ case $cit_arg in
+ -I* [)] $1="[$]$1 $cit_arg" ;;
+ esac
+ done
+ test -z "[$]$1" && continue
+ break
+ fi
+done
+if test -n "[$]$1"; then
+ AC_MSG_RESULT([[$]$1])
+ $3
+else
+ AC_MSG_RESULT(failed)
+ $4
+fi
+])dnl CIT_MPI_INCLUDES
+
+
+# CIT_MPI_COMPILE_INFO_SWITCHES
+# CIT_MPI_LINK_INFO_SWITCHES
+# -----------------------------
+# The variety of flags used by MPICH, LAM/MPI, Open MPI, and ChaMPIon/Pro.
+# NYI: mpxlc/mpcc (xlc?), mpcc_r (xlc_r?)
+AC_DEFUN([CIT_MPI_COMPILE_INFO_SWITCHES], ["-show" "-showme" "-echo" "-compile_info"])
+AC_DEFUN([CIT_MPI_LINK_INFO_SWITCHES], ["-show" "-showme" "-echo" "-link_info"])
+
+
+# CIT_SKIP_MPICXX_DEFINES
+# -----------------------
+# Switches to disable inclusion of C++ MPI bindings.
+AC_DEFUN([CIT_SKIP_MPICXX_DEFINES], ["-DMPICH_SKIP_MPICXX" "-UHAVE_MPI_CPP" "-DLAM_WANT_MPI2CPP=0" "-DLAM_BUILDING=1" "-DOMPI_WANT_CXX_BINDINGS=0" "-DOMPI_BUILDING=1"])
+
+
+dnl end of file
Added: seismo/2D/SPECFEM2D/trunk/m4/cit_numpy.m4
===================================================================
--- seismo/2D/SPECFEM2D/trunk/m4/cit_numpy.m4 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/m4/cit_numpy.m4 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,33 @@
+# -*- Autoconf -*-
+
+
+## --------------------------- ##
+## Autoconf macros for Numpy. ##
+## --------------------------- ##
+
+# CIT_NUMPY_PYTHON_MODULE
+# Determine whether the numpy Python module is available.
+AC_DEFUN([CIT_NUMPY_PYTHON_MODULE], [
+AC_REQUIRE([AM_PATH_PYTHON])
+AC_MSG_CHECKING(for numpy python module)
+$PYTHON -c "import numpy" 2>/dev/null
+if test $? == 0; then
+ AC_MSG_RESULT(found)
+else
+ AC_MSG_FAILURE(not found)
+fi
+]) dnl CIT_NUMPY_PYTHON_MODULE
+
+# NUMPY_INCDIR
+# -----------------
+# Determine the directory containing <numpy/arrayobject.h>
+AC_DEFUN([CIT_NUMPY_INCDIR], [
+AC_REQUIRE([AM_PATH_PYTHON])
+AC_CACHE_CHECK([for numpy include directory],
+ [_cv_numpy_incdir],
+ [_cv_numpy_incdir=`$PYTHON -c "import numpy; numpypath=numpy.__path__[[0]]; print '%s/core/include' % numpypath"`])
+AC_SUBST([NUMPY_INCDIR], [$_cv_numpy_incdir])
+])dnl CIT_NUMPY_INCDIR
+
+
+dnl end of file
Added: seismo/2D/SPECFEM2D/trunk/m4/cit_petsc.m4
===================================================================
--- seismo/2D/SPECFEM2D/trunk/m4/cit_petsc.m4 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/m4/cit_petsc.m4 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,383 @@
+# -*- Autoconf -*-
+
+
+## -------------------------- ##
+## Autoconf macros for PETSc. ##
+## -------------------------- ##
+
+
+# CIT_PATH_PETSC([VERSION], [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND])
+# -----------------------------------------------------------------------
+# Check for the PETSc package. Requires Python.
+AC_DEFUN([CIT_PATH_PETSC], [
+# $Id: cit_petsc.m4 17942 2011-02-22 20:47:56Z brad $
+
+AC_REQUIRE([AM_PATH_PYTHON])
+AC_ARG_VAR(PETSC_DIR, [location of PETSc installation])
+AC_ARG_VAR(PETSC_ARCH, [PETSc configuration])
+
+AC_MSG_CHECKING([for PETSc dir])
+if test -z "$PETSC_DIR"; then
+ AC_MSG_RESULT(no)
+ m4_default([$3], [AC_MSG_ERROR([PETSc not found; set PETSC_DIR])])
+elif test ! -d "$PETSC_DIR"; then
+ AC_MSG_RESULT(no)
+ m4_default([$3], [AC_MSG_ERROR([PETSc not found; PETSC_DIR=$PETSC_DIR is invalid])])
+elif test ! -d "$PETSC_DIR/include"; then
+ AC_MSG_RESULT(broken)
+ m4_default([$3], [AC_MSG_ERROR([PETSc include dir $PETSC_DIR/include not found; check PETSC_DIR])])
+elif test ! -f "$PETSC_DIR/include/petscversion.h"; then
+ AC_MSG_RESULT(broken)
+ m4_default([$3], [AC_MSG_ERROR([PETSc header file $PETSC_DIR/include/petscversion.h not found; check PETSC_DIR])])
+fi
+AC_MSG_RESULT([$PETSC_DIR])
+
+# In what follows, we consistenly check for the new config layout
+# first, in case the user is using an old HG working copy with junk in
+# it.
+
+AC_MSG_CHECKING([for PETSc arch])
+if test -z "$PETSC_ARCH"; then
+ if test -d "$PETSC_DIR/conf"; then
+ # new config layout; no default config (?)
+ AC_MSG_RESULT(no)
+ m4_default([$3], [AC_MSG_ERROR([set PETSC_ARCH])])
+ elif test ! -f "$PETSC_DIR/bmake/petscconf"; then
+ # old config layout (2.3.3 and earlier)
+ AC_MSG_RESULT(error)
+ m4_default([$3], [AC_MSG_ERROR([PETSc file $PETSC_DIR/bmake/petscconf not found; check PETSC_DIR])])
+ else
+ cat >petsc.py <<END_OF_PYTHON
+[from distutils.sysconfig import parse_makefile
+
+vars = parse_makefile('$PETSC_DIR/bmake/petscconf')
+print 'PETSC_ARCH="%s"' % vars['PETSC_ARCH']
+
+]
+END_OF_PYTHON
+ eval `$PYTHON petsc.py 2>/dev/null`
+ rm -f petsc.py
+ fi
+fi
+AC_MSG_RESULT([$PETSC_ARCH])
+
+AC_MSG_CHECKING([for PETSc config])
+if test -d "$PETSC_DIR/$PETSC_ARCH/conf"; then
+ if test -f "$PETSC_DIR/$PETSC_ARCH/conf/petscvariables"; then
+ cit_petsc_petscconf="$PETSC_DIR/$PETSC_ARCH/conf/petscvariables"
+ elif test -f "$PETSC_DIR/$PETSC_ARCH/conf/petscconf"; then
+ cit_petsc_petscconf="$PETSC_DIR/$PETSC_ARCH/conf/petscconf"
+ else
+ AC_MSG_RESULT(no)
+ m4_default([$3], [AC_MSG_ERROR([Could not find file with PETSc configuration settings; check PETSC_ARCH/conf])])
+ fi
+ # Using conf/variables *should* be obsolete for new config.
+ #cit_petsc_variables="$PETSC_DIR/conf/variables"
+elif test -d "$PESC_DIR/bmake/$PETSC_ARCH"; then
+ # old config layout
+ cit_petsc_petscconf="$PETSC_DIR/bmake/$PETSC_ARCH/petscconf"
+ cit_petsc_variables="$PETSC_DIR/bmake/common/variables"
+ if test ! -f "$cit_petsc_variables"; then
+ AC_MSG_RESULT(error)
+ m4_default([$3], [AC_MSG_ERROR([PETSc config file $cit_petsc_variables not found; check PETSC_DIR])])
+ fi
+else
+ AC_MSG_RESULT(no)
+ m4_default([$3], [AC_MSG_ERROR([PETSc config dir not found; check PETSC_ARCH])])
+fi
+if test ! -f "$cit_petsc_petscconf"; then
+ AC_MSG_RESULT(no)
+ m4_default([$3], [AC_MSG_ERROR([PETSc config file $cit_petsc_petscconf not found; check PETSC_ARCH])])
+fi
+AC_MSG_RESULT([$cit_petsc_petscconf])
+
+AC_MSG_CHECKING([for PETSc version == $1])
+echo "PETSC_DIR = $PETSC_DIR" > petscconf
+echo "PETSC_ARCH = $PETSC_ARCH" >> petscconf
+cat $cit_petsc_petscconf $cit_petsc_variables >> petscconf
+cat >petsc.py <<END_OF_PYTHON
+[from distutils.sysconfig import parse_config_h, parse_makefile, expand_makefile_vars
+
+f = open('$PETSC_DIR/include/petscversion.h')
+vars = parse_config_h(f)
+f.close()
+
+parse_makefile('petscconf', vars)
+
+keys = (
+ 'PETSC_VERSION_MAJOR',
+ 'PETSC_VERSION_MINOR',
+ 'PETSC_VERSION_SUBMINOR',
+
+ 'PETSC_CC_INCLUDES',
+ 'PETSC_FC_INCLUDES',
+ 'PETSC_LIB',
+ 'PETSC_FORTRAN_LIB',
+
+ 'CC',
+ 'CXX',
+ 'FC',
+
+ 'MPI_LIB',
+ 'MPI_INCLUDE',
+
+ 'SIEVE_FLAGS',
+)
+
+for key in keys:
+ if key[:6] == 'PETSC_':
+ value = expand_makefile_vars(str(vars.get(key, '')), vars)
+ if key == 'PETSC_LIB':
+ # Libtool strips the former. (Does it ever work?)
+ value = value.replace("/System/Library/Frameworks/vecLib.framework/vecLib",
+ "-Wl,-framework,vecLib")
+ print '%s="%s"' % (key, value)
+ else:
+ print 'PETSC_%s="%s"' % (key, expand_makefile_vars(str(vars.get(key, '')), vars))
+
+]
+END_OF_PYTHON
+AS_IF([AC_TRY_COMMAND([$PYTHON petsc.py >conftest.sh 2>&AS_MESSAGE_LOG_FD])],
+ [],
+ [AC_MSG_RESULT(error)
+ AC_MSG_FAILURE([cannot parse PETSc configuration])])
+eval `cat conftest.sh`
+rm -f conftest.sh petsc.py petscconf
+
+[eval `echo $1 | sed 's/\([^.]*\)[.]\([^.]*\)[.]\([^.]*\).*/petsc_1_major=\1; petsc_1_minor=\2; petsc_1_subminor=\3;/'`]
+if test -z "$PETSC_VERSION_MAJOR" -o -z "$PETSC_VERSION_MINOR" -o -z "$PETSC_VERSION_SUBMINOR"; then
+ AC_MSG_RESULT(no)
+ m4_default([$3], [AC_MSG_ERROR([no suitable PETSc package found])])
+elif test "$PETSC_VERSION_MAJOR" -eq "$petsc_1_major" -a \
+ "$PETSC_VERSION_MINOR" -eq "$petsc_1_minor" -a \
+ "$PETSC_VERSION_SUBMINOR" -eq "$petsc_1_subminor" ; then
+ AC_MSG_RESULT(yes)
+ $2
+else
+ AC_MSG_RESULT([no ($PETSC_VERSION_MAJOR.$PETSC_VERSION_MINOR.$PETSC_VERSION_SUBMINOR)])
+ m4_default([$3], [AC_MSG_ERROR([no suitable PETSc package found])])
+fi
+
+AC_SUBST([PETSC_VERSION_MAJOR])
+AC_SUBST([PETSC_VERSION_MINOR])
+AC_SUBST([PETSC_VERSION_SUBMINOR])
+AC_SUBST([PETSC_CC_INCLUDES])
+AC_SUBST([PETSC_FC_INCLUDES])
+AC_SUBST([PETSC_LIB])
+AC_SUBST([PETSC_FORTRAN_LIB])
+AC_SUBST([PETSC_CC])
+AC_SUBST([PETSC_CXX])
+AC_SUBST([PETSC_FC])
+AC_SUBST([PETSC_MPI_LIB])
+AC_SUBST([PETSC_MPI_INCLUDE])
+AC_SUBST([PETSC_SIEVE_FLAGS])
+])dnl CIT_PATH_PETSC
+
+
+# CIT_CHECK_LIB_PETSC
+# -------------------
+# Try to link against the PETSc libraries. If the current language is
+# C++, determine the value of PETSC_CXX_LIB, which names the extra
+# libraries needed when using a C++ compiler. (As of PETSc v2.3,
+# PETSC_CXX_LIB will always be empty; see comment below.)
+AC_DEFUN([CIT_CHECK_LIB_PETSC], [
+# $Id: cit_petsc.m4 17942 2011-02-22 20:47:56Z brad $
+AC_REQUIRE([CIT_PATH_PETSC])dnl
+AC_SUBST(PETSC_CXX_LIB)
+PETSC_CXX_LIB=
+cit_petsc_save_CC=$CC
+cit_petsc_save_LIBS=$LIBS
+CC=$PETSC_CC
+LIBS="$PETSC_LIB $LIBS"
+_CIT_LINK_PETSC_IFELSE([], [
+ AC_LANG_CASE(
+ [C++], [],
+ _CIT_CHECK_LIB_PETSC_FAILED
+ )
+ #
+ # Try to guess the correct value for PETSC_CXX_LIB, assuming PETSC_CC
+ # is an MPI wrapper.
+ #
+ # In theory, when PETSC_CC is 'mpicc', *both* the MPI libraries and
+ # includes are effectively hidden, and must be extracted in order to
+ # use a C++ compiler (the PETSc configuration does not specify a C++
+ # compiler command).
+ #
+ # But this path was only added for symmetry with CIT_HEADER_PETSC.
+ # Because, in practice, there is an asymmetry between includes and
+ # libs. When PETSC_CC is 'mpicc', the MPI includes are indeed hidden:
+ # PETSC_INCLUDE omits MPI includes. But PETSC_LIB always explicitly
+ # specifies the MPI library, even (redundantly) when PETSC_CC is
+ # 'mpicc'. So, as of PETSc v2.3 at least, this path is never taken.
+ CIT_MPI_LIBS(cit_libs, $PETSC_CC, [
+ LIBS="$PETSC_LIB $cit_libs $cit_petsc_save_LIBS"
+ unset ac_cv_func_PetscInitialize
+ _CIT_LINK_PETSC_IFELSE([
+ PETSC_CXX_LIB=$cit_libs
+ ], [
+ _CIT_CHECK_LIB_PETSC_FAILED
+ ])
+ ], [
+ _CIT_CHECK_LIB_PETSC_FAILED
+ ])
+])
+LIBS=$cit_petsc_save_LIBS
+CC=$cit_petsc_save_CC
+])dnl CIT_CHECK_LIB_PETSC
+
+
+# _CIT_CHECK_LIB_PETSC_FAILED
+# ---------------------------
+AC_DEFUN([_CIT_CHECK_LIB_PETSC_FAILED], [
+AC_MSG_ERROR([cannot link against PETSc libraries])
+])dnl _CIT_CHECK_LIB_PETSC_FAILED
+
+
+# _CIT_LINK_PETSC_IFELSE([ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND])
+# ----------------------------------------------------------------
+AC_DEFUN([_CIT_LINK_PETSC_IFELSE], [
+# PetscInitialize() might have C++ linkage. If the current language
+# is C++, allow for this possibility.
+AC_LANG_CASE(
+ [C++], [
+ AC_MSG_CHECKING([for PetscInitialize])
+ AC_LINK_IFELSE(_CIT_CHECK_LIB_PETSC_PROGRAM([]), [
+ AC_MSG_RESULT([yes (C++)])
+ $1
+ ], [
+ AC_LINK_IFELSE(_CIT_CHECK_LIB_PETSC_PROGRAM([extern "C"]), [
+ AC_MSG_RESULT([yes (C)])
+ $1
+ ], [
+ AC_MSG_RESULT(no)
+ $2
+ ])
+ ])
+ ],
+ [AC_CHECK_FUNC(PetscInitialize, [$1], [$2])]
+)
+])dnl _CIT_LINK_PETSC_IFELSE
+
+
+# _CIT_CHECK_LIB_PETSC_PROGRAM
+# ----------------------------
+AC_DEFUN([_CIT_CHECK_LIB_PETSC_PROGRAM], [
+AC_LANG_PROGRAM([[
+$1 int PetscInitialize(int *, char ***,const char *,const char *);
+]], [[
+ PetscInitialize(0, 0, 0, "checklib");
+]])
+])dnl _CIT_CHECK_LIB_PETSC_PROGRAM
+
+
+# CIT_HEADER_PETSC
+# ----------------
+# Try to use PETSc headers. If the current language is C++, determine
+# the value of PETSC_CXX_INCLUDE, which names the extra include paths
+# needed when using a C++ compiler... i.e., the MPI includes. When
+# PETSC_CC is set to an MPI wrapper such as 'mpicc', the required MPI
+# includes are effectively hidden, and must be extracted in order to
+# use a C++ compiler (the PETSc configuration does not specify a C++
+# compiler command).
+AC_DEFUN([CIT_HEADER_PETSC], [
+# $Id: cit_petsc.m4 17942 2011-02-22 20:47:56Z brad $
+AC_REQUIRE([CIT_PATH_PETSC])dnl
+AC_REQUIRE([CIT_CHECK_LIB_PETSC])dnl
+AC_SUBST(PETSC_CXX_INCLUDE)
+PETSC_CXX_INCLUDE=
+cit_petsc_save_CC=$CC
+cit_petsc_save_CPPFLAGS=$CPPFLAGS
+cit_petsc_save_LIBS=$LIBS
+CC=$PETSC_CC
+CPPFLAGS="$PETSC_CC_INCLUDES $CPPFLAGS"
+AC_MSG_CHECKING([for petsc.h])
+dnl Use AC_TRY_COMPILE instead of AC_CHECK_HEADER because the
+dnl latter also preprocesses using $CXXCPP.
+AC_TRY_COMPILE([
+#include <petsc.h>
+], [], [
+ AC_MSG_RESULT(yes)
+], [
+ AC_MSG_RESULT(no)
+ AC_LANG_CASE(
+ [C++], [],
+ _CIT_HEADER_PETSC_FAILED
+ )
+ # Try to guess the correct value for PETSC_CXX_INCLUDE, assuming
+ # PETSC_CC is an MPI wrapper.
+ CIT_MPI_INCLUDES(cit_includes, $PETSC_CC, [
+ AC_MSG_CHECKING([for petsc.h])
+ CPPFLAGS="$PETSC_CC_INCLUDES $cit_includes $cit_petsc_save_CPPFLAGS"
+ AC_TRY_COMPILE([
+#include <petsc.h>
+ ], [], [
+ AC_MSG_RESULT(yes)
+ PETSC_CXX_INCLUDE=$cit_includes
+ ], [
+ AC_MSG_RESULT(no)
+ _CIT_HEADER_PETSC_FAILED
+ ])
+ ], [
+ _CIT_HEADER_PETSC_FAILED
+ ])
+])
+AC_LANG_CASE([C++], [
+ LIBS="$PETSC_LIB $PETSC_CXX_LIB $LIBS"
+ CIT_MPI_CHECK_CXX_LINK(PETSC_CXX_INCLUDE, [$PETSC_LIB],
+ _CIT_TRIVIAL_PETSC_PROGRAM,
+ [whether we can link a trivial C++ PETSc program],
+ [],
+ AC_MSG_FAILURE([cannot link a trivial C++ PETSc program using $CXX]))
+])
+LIBS=$cit_petsc_save_LIBS
+CPPFLAGS=$cit_petsc_save_CPPFLAGS
+CC=$cit_petsc_save_CC
+])dnl CIT_HEADER_PETSC
+
+
+# _CIT_HEADER_PETSC_FAILED
+# ------------------------
+AC_DEFUN([_CIT_HEADER_PETSC_FAILED], [
+AC_MSG_ERROR([header "petsc.h" not found])
+])dnl _CIT_HEADER_PETSC_FAILED
+
+
+# _CIT_TRIVIAL_PETSC_PROGRAM
+# --------------------------
+AC_DEFUN([_CIT_TRIVIAL_PETSC_PROGRAM], [
+AC_LANG_PROGRAM([[
+#include <petsc.h>
+]], [[
+ PetscInitialize(0, 0, 0, "trivial");
+ PetscFinalize();
+]])
+])dnl _CIT_TRIVIAL_PETSC_PROGRAM
+
+
+# CIT_CHECK_LIB_PETSC_SIEVE
+# -------------------------
+AC_DEFUN([CIT_CHECK_LIB_PETSC_SIEVE], [
+AC_MSG_CHECKING([for PETSc/Sieve])
+AC_LANG_PUSH(C++)
+cit_petsc_save_LIBS=$LIBS
+cit_petsc_save_CPPFLAGS=$CPPFLAGS
+LIBS="$PETSC_LIB $PETSC_CXX_LIB $LIBS"
+CPPFLAGS="$PETSC_CC_INCLUDES $PETSC_CXX_INCLUDE $CPPFLAGS"
+AC_LINK_IFELSE(AC_LANG_PROGRAM([[
+#include <petscmesh.h>
+]], [[
+ const int dim = 3;
+ ALE::Mesh<int,double> mesh(PETSC_COMM_WORLD, dim);
+]]), [
+ AC_MSG_RESULT(yes)
+], [
+ AC_MSG_RESULT(no)
+ AC_MSG_FAILURE([cannot build a trivial C++ PETSc program which uses ALE::Sieve])
+])
+CPPFLAGS=$cit_petsc_save_CPPFLAGS
+LIBS=$cit_petsc_save_LIBS
+AC_LANG_POP(C++)
+])dnl CIT_CHECK_LIB_PETSC_SIEVE
+
+
+dnl end of file
Added: seismo/2D/SPECFEM2D/trunk/m4/cit_python.m4
===================================================================
--- seismo/2D/SPECFEM2D/trunk/m4/cit_python.m4 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/m4/cit_python.m4 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,465 @@
+# -*- Autoconf -*-
+
+
+## --------------------------- ##
+## Autoconf macros for Python. ##
+## --------------------------- ##
+
+
+# CIT_PYTHON_INCDIR
+# -----------------
+# Determine the directory containing <Python.h> using distutils.
+AC_DEFUN([CIT_PYTHON_INCDIR], [
+# $Id: cit_python.m4 17971 2011-02-24 17:22:51Z brad $
+AC_REQUIRE([AM_PATH_PYTHON])
+AC_CACHE_CHECK([for $am_display_PYTHON include directory],
+ [PYTHON_INCDIR],
+ [PYTHON_INCDIR=`$PYTHON -c "from distutils import sysconfig; print sysconfig.get_python_inc()" 2>/dev/null ||
+ echo "$PYTHON_PREFIX/include/python$PYTHON_VERSION"`])
+AC_SUBST([PYTHON_INCDIR], [$PYTHON_INCDIR])
+])dnl CIT_PYTHON_INCDIR
+
+
+# CIT_CHECK_PYTHON_HEADER
+# -----------------------
+# Checking the existence of Python.h
+AC_DEFUN([CIT_CHECK_PYTHON_HEADER], [
+# $Id: cit_python.m4 17971 2011-02-24 17:22:51Z brad $
+AC_REQUIRE([CIT_PYTHON_INCDIR])
+cit_save_CPPFLAGS=$CPPFLAGS
+CPPFLAGS="-I$PYTHON_INCDIR $cit_save_CPPFLAGS"
+AC_CHECK_HEADER([Python.h], [], [
+ AC_MSG_ERROR([Header file 'Python.h' not found; maybe you don't have the python development package, e.g. 'python-dev', installed?])
+ ])
+CPPFLAGS=$cit_save_CPPFLAGS
+])dnl CIT_CHECK_PYTHON_HEADER
+
+
+# CIT_CHECK_PYTHON_SHARED
+# -----------------------
+# Check whether -lpythonX.X is a shared library.
+AC_DEFUN([CIT_CHECK_PYTHON_SHARED], [
+# $Id: cit_python.m4 17971 2011-02-24 17:22:51Z brad $
+AC_REQUIRE([CIT_PYTHON_CONFIG])
+AC_MSG_CHECKING([whether -lpython$PYTHON_VERSION is a shared library])
+cit_save_CPPFLAGS=$CPPFLAGS
+cit_save_LDFLAGS=$LDFLAGS
+cit_save_LIBS=$LIBS
+CPPFLAGS="$PYTHON_CPPFLAGS $cit_save_CPPFLAGS"
+LDFLAGS="$PYTHON_LDFLAGS $cit_save_LDFLAGS"
+LIBS="$PYTHON_LIBS $cit_save_LIBS"
+AC_RUN_IFELSE([AC_LANG_PROGRAM([[
+#include "Python.h"
+]], [[
+ int status;
+ Py_Initialize();
+ status = PyRun_SimpleString("import binascii") != 0;
+ Py_Finalize();
+ return status;
+]])], [
+ AC_MSG_RESULT(yes)
+], [
+ AC_MSG_RESULT(no)
+ AC_MSG_ERROR([-lpython$PYTHON_VERSION is not a shared library])
+])
+CPPFLAGS=$cit_save_CPPFLAGS
+LDFLAGS=$cit_save_LDFLAGS
+LIBS=$cit_save_LIBS
+])dnl CIT_CHECK_PYTHON_SHARED
+
+
+# CIT_PYTHON_CONFIG
+# -----------------
+AC_DEFUN([CIT_PYTHON_CONFIG], [
+# $Id: cit_python.m4 17971 2011-02-24 17:22:51Z brad $
+AC_REQUIRE([AM_PATH_PYTHON])
+AC_MSG_CHECKING([$am_display_PYTHON config])
+cat >python-config.py <<END_OF_PYTHON
+[
+# This is based upon the pythonX.X-config utility that ships with
+# Python 2.4 and later.
+from distutils import sysconfig
+
+pyver = sysconfig.get_config_var('VERSION')
+getvar = sysconfig.get_config_var
+
+cppflags = ['-I' + sysconfig.get_python_inc(),
+ '-I' + sysconfig.get_python_inc(plat_specific=True)]
+print 'PYTHON_CPPFLAGS="%s"' % ' '.join(cppflags)
+
+ldflags = ['-L' + getvar('LIBDIR'), '-L' + getvar('LIBPL')]
+print 'PYTHON_LDFLAGS="%s"' % ' '.join(ldflags)
+
+libs = getvar('LIBS').split() + getvar('SYSLIBS').split()
+libs.append('-lpython'+pyver)
+print 'PYTHON_LIBS="%s"' % ' '.join(libs)
+
+]
+END_OF_PYTHON
+eval `$PYTHON python-config.py 2>/dev/null`
+if test -n "$PYTHON_CPPFLAGS"; then
+ AC_MSG_RESULT(ok)
+else
+ AC_MSG_ERROR(["failed
+
+Run '$PYTHON python-config.py' to see what went wrong.
+"])
+fi
+rm -f python-config.py
+AC_SUBST([PYTHON_CPPFLAGS], [$PYTHON_CPPFLAGS])
+AC_SUBST([PYTHON_LDFLAGS], [$PYTHON_LDFLAGS])
+AC_SUBST([PYTHON_LIBS], [$PYTHON_LIBS])
+])dnl CIT_PYTHON_CONFIG
+
+
+# CIT_PYTHON_SYSCONFIG
+# --------------------
+AC_DEFUN([CIT_PYTHON_SYSCONFIG], [
+# $Id: cit_python.m4 17971 2011-02-24 17:22:51Z brad $
+AC_REQUIRE([AM_PATH_PYTHON])
+AC_MSG_CHECKING([$am_display_PYTHON sysconfig])
+cat >sysconfig.py <<END_OF_PYTHON
+[import os, sys
+from distutils import sysconfig
+def cygpath(wpath):
+ s = os.popen('cygpath -u "%s"' % wpath)
+ path = s.read().strip()
+ s.close()
+ return path
+incdir = sysconfig.get_python_inc()
+keys = (
+ 'BLDLIBRARY',
+ 'LDFLAGS',
+ 'LDLAST',
+ 'LDLIBRARY',
+ 'LIBDIR',
+ 'LIBP',
+ 'LIBPL',
+ 'LIBS',
+ 'LINKFORSHARED',
+ 'MODLIBS',
+ 'SYSLIBS',
+ 'LA_LDFLAGS',
+)
+if os.name == "nt":
+ # We are running under Python for Windows (the real one...
+ # not Cygwin Python, under which 'os.name' is 'posix').
+ # We assume that we are still in the Cygwin POSIX environment,
+ # however (this is 'configure', after all); so we convert
+ # all Windows pathnames to POSIX pathnames using 'cygpath'.
+ incdir = cygpath(incdir)
+ vars = {}
+ libs = os.path.join(sys.prefix, "libs")
+ libs = cygpath(libs)
+ version = sysconfig.get_python_version()
+ version = version.replace('.', '')
+ vars['BLDLIBRARY'] = "-L%s -lpython%s" % (libs, version)
+else:
+ vars = sysconfig.get_config_vars()
+ # transform AIX's python.exp
+ vars['LINKFORSHARED'] = vars['LINKFORSHARED'].replace('Modules',vars['LIBPL'])
+ if vars['LDLIBRARY'] == vars['LIBRARY']:
+ # "On systems without shared libraries, LDLIBRARY is the same as LIBRARY"
+ vars['BLDLIBRARY'] = "-L%(LIBPL)s -lpython%(VERSION)s" % vars
+ elif vars['BLDLIBRARY']:
+ # The 'mpicc' wrapper for LAM/MPI isn't very smart about "-L"
+ # options. Adding "-L/usr/lib" can cause "-lmpi" to be found in /usr/lib
+ # instead of LAM's 'lib' directory. Of course, avoiding "-L/usr/lib"
+ # doesn't really fix the problem, but it does make it much less likely;
+ # and "-L/usr/lib" is redundant and potentially problematic anyway.
+ # Python 2.4 and later puts a symlink to libpython.so in LIBPL
+ # (/usr/lib/python2.x/config), which makes adding "-L$LIBDIR"
+ # (in addition to "-L$LIBPL") completely redundant.
+ # But we still support Python 2.3, and we prefer shared to static,
+ # so we still add "-L$LIBDIR" when Python is installed in a non-standard
+ # location. Note that the linker will still prefer shared over static
+ # with only "-L/usr/lib/python2.3/config" on the link line.
+ libdir = ""
+ if vars['LIBDIR'] != "/usr/lib":
+ libdir = "-L%(LIBDIR)s "
+ # Important: on Cygwin, the import library for libpython.dll is
+ # nested inside Python's 'config' directory (see Issue39). This means
+ # that the linker always needs help finding "-lpython2.x" (in the form
+ # of "-L$LIBPL"), even for the "system" Python installed under /usr.
+ vars['BLDLIBRARY'] = (libdir + "-L%(LIBPL)s -lpython%(VERSION)s") % vars
+ else:
+ # "On Mac OS X frameworks, BLDLIBRARY is blank"
+ # See also Issue39.
+ framework = "%(PYTHONFRAMEWORKDIR)s/Versions/%(VERSION)s/%(PYTHONFRAMEWORK)s" % vars
+ PYTHONFRAMEWORK = vars.get('PYTHONFRAMEWORK', 'Python')
+ vars['LINKFORSHARED'] = vars['LINKFORSHARED'].replace(framework, "-framework " + PYTHONFRAMEWORK)
+ vars['LA_LDFLAGS'] = "-Wl,-framework,%s" % PYTHONFRAMEWORK
+vars['LDFLAGS'] = '' # only causes trouble (e.g., "-arch i386 -arch ppc" on Mac) -- see issue97
+print 'PYTHON_INCDIR="%s"' % incdir
+for key in keys:
+ print 'PYTHON_%s="%s"' % (key, vars.get(key, ''))
+]
+END_OF_PYTHON
+eval `$PYTHON sysconfig.py 2>/dev/null`
+if test -n "$PYTHON_INCDIR"; then
+ AC_MSG_RESULT(ok)
+else
+ AC_MSG_ERROR(["failed
+
+Run '$PYTHON sysconfig.py' to see what went wrong.
+"])
+fi
+rm -f sysconfig.py
+AC_SUBST([PYTHON_INCDIR], [$PYTHON_INCDIR])
+AC_SUBST([PYTHON_BLDLIBRARY], [$PYTHON_BLDLIBRARY])
+AC_SUBST([PYTHON_LDFLAGS], [$PYTHON_LDFLAGS])
+AC_SUBST([PYTHON_LDLAST], [$PYTHON_LDLAST])
+AC_SUBST([PYTHON_LDLIBRARY], [$PYTHON_LDLIBRARY])
+AC_SUBST([PYTHON_LIBDIR], [$PYTHON_LIBDIR])
+AC_SUBST([PYTHON_LIBP], [$PYTHON_LIBP])
+AC_SUBST([PYTHON_LIBPL], [$PYTHON_LIBPL])
+AC_SUBST([PYTHON_LIBS], [$PYTHON_LIBS])
+AC_SUBST([PYTHON_LINKFORSHARED], [$PYTHON_LINKFORSHARED])
+AC_SUBST([PYTHON_MODLIBS], [$PYTHON_MODLIBS])
+AC_SUBST([PYTHON_SYSLIBS], [$PYTHON_SYSLIBS])
+AC_SUBST([PYTHON_LA_LDFLAGS], [$PYTHON_LA_LDFLAGS])
+])dnl CIT_PYTHON_SYSCONFIG
+
+
+# CIT_PYTHON_SITE
+# ---------------
+AC_DEFUN([CIT_PYTHON_SITE], [
+# $Id: cit_python.m4 17971 2011-02-24 17:22:51Z brad $
+AC_REQUIRE([AM_PATH_PYTHON])
+AC_MSG_CHECKING([whether we are installing to Python's prefix])
+cit_python_prefix=`$PYTHON -c "import sys; print sys.prefix"`
+if test "$cit_python_prefix" = "$prefix"; then
+ AC_MSG_RESULT(yes)
+ cit_cond_python_site=true
+else
+ AC_MSG_RESULT(no)
+ cit_cond_python_site=false
+fi
+AC_MSG_CHECKING([whether we are installing to Python's exec prefix])
+cit_python_exec_prefix=`$PYTHON -c "import sys; print sys.exec_prefix"`
+cit_exec_prefix=$exec_prefix
+test "x$cit_exec_prefix" = xNONE && cit_exec_prefix=$prefix
+if test "$cit_python_exec_prefix" = "$cit_exec_prefix"; then
+ AC_MSG_RESULT(yes)
+ cit_cond_pyexec_site=true
+else
+ AC_MSG_RESULT(no)
+ cit_cond_pyexec_site=false
+fi
+AM_CONDITIONAL([COND_PYTHON_SITE], [$cit_cond_python_site])
+AM_CONDITIONAL([COND_PYEXEC_SITE], [$cit_cond_pyexec_site])
+])dnl CIT_PYTHON_SITE
+
+
+# CIT_CHECK_PYTHON_EGG(REQUIREMENT,
+# [ACTION-IF-FOUND, [ACTION-IF-NOT-FOUND]])
+# --------------------------------------------------------------
+
+# Check for REQUIREMENT using pkg_resources.require(). If the
+# corresponding distribution is found, execute ACTION-IF-FOUND.
+# Otherwise, execute ACTION-IF-NOT-FOUND.
+
+AC_DEFUN([CIT_CHECK_PYTHON_EGG], [
+# $Id: cit_python.m4 17971 2011-02-24 17:22:51Z brad $
+
+AC_MSG_CHECKING([for "$1"])
+
+cat >check_python_egg.py <<END_OF_PYTHON
+[
+import sys
+try:
+ from pkg_resources import require
+ require("$1")
+except Exception, e:
+ print >>sys.stderr, e
+ print "cit_egg_status=1"
+else:
+ print "cit_egg_status=0"
+]
+END_OF_PYTHON
+
+AS_IF([AC_TRY_COMMAND([$PYTHON check_python_egg.py >conftest.sh 2>&AS_MESSAGE_LOG_FD])],
+ [],
+ [AC_MSG_RESULT(failed)
+ AC_MSG_FAILURE([cannot check for Python eggs])])
+eval `cat conftest.sh`
+rm -f conftest.sh check_python_egg.py
+
+if test "$cit_egg_status" == 0; then
+ AC_MSG_RESULT(yes)
+ $2
+else
+ AC_MSG_RESULT(no)
+ m4_default([$3], [AC_MSG_ERROR([required Python package not found: $1])])
+fi
+
+])dnl CIT_CHECK_PYTHON_EGG
+
+
+# CIT_PYTHON_EGG_SETUP
+# --------------------
+
+AC_DEFUN([CIT_PYTHON_EGG_SETUP], [
+# $Id: cit_python.m4 17971 2011-02-24 17:22:51Z brad $
+AC_REQUIRE([AM_PATH_PYTHON])
+
+cit_builddir=`pwd`
+cit_save_PYTHONPATH="$PYTHONPATH"
+PYTHONPATH="$cit_builddir/python:$PYTHONPATH"; export PYTHONPATH
+cd $srcdir
+
+AC_MSG_NOTICE([downloading missing Python dependencies])
+AS_IF([AC_TRY_COMMAND([$PYTHON setup.py install_deps -f $cit_builddir/deps -zmxd $cit_builddir/deps >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD])],
+ [],
+ [AC_MSG_FAILURE([cannot download missing Python dependencies])])
+
+AC_MSG_NOTICE([building Python dependencies])
+AS_IF([AC_TRY_COMMAND([$PYTHON setup.py develop -H None -f $cit_builddir/deps -x -d $cit_builddir/python >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD])],
+ [],
+ [AC_MSG_FAILURE([building Python dependencies])])
+
+AC_MSG_CHECKING([for egg-related flags])
+AS_IF([AC_TRY_COMMAND([$PYTHON setup.py egg_flags >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD])],
+ [AC_MSG_RESULT(ok)
+ . ./egg-flags.sh
+ rm -f egg-flags.sh
+ ],
+ [AC_MSG_RESULT(failed)
+ AC_MSG_FAILURE([cannot scan Python eggs for flags])])
+
+cd $cit_builddir
+PYTHONPATH="$cit_save_PYTHONPATH"
+PYTHONPATH="${pythondir}:${pyexecdir}${cit_save_PYTHONPATH:+:${cit_save_PYTHONPATH}}"
+
+AC_SUBST(PYTHONPATH)
+AC_SUBST(PYTHON_EGG_CFLAGS)
+AC_SUBST(PYTHON_EGG_CPPFLAGS)
+AC_SUBST(PYTHON_EGG_LDFLAGS)
+AC_SUBST(PYTHON_EGG_LIBS)
+AC_SUBST(PYTHON_EGG_PYXFLAGS)
+
+])dnl CIT_PYTHON_EGG_SETUP
+
+
+# CIT_PROG_PYCONFIG
+# -----------------
+# Provide a simple Python script which generates a Python module to
+# expose our package configuration, similar to Python's
+# distutils.sysconfig.
+AC_DEFUN([CIT_PROG_PYCONFIG], [
+# $Id: cit_python.m4 17971 2011-02-24 17:22:51Z brad $
+PYCONFIG='$(top_builddir)/pyconfig'
+AC_SUBST(PYCONFIG)
+ofile=pyconfig
+cfgfile="${ofile}T"
+trap "rm \"$cfgfile\"; exit 1" 1 2 15
+rm -f "$cfgfile"
+AC_MSG_NOTICE([creating $ofile])
+cat >"$cfgfile" <<END_OF_PYTHON
+[#!/usr/bin/env python
+
+from getopt import getopt, GetoptError
+from sys import argv, exit
+from getopt import getopt
+from distutils.sysconfig import parse_config_h, parse_makefile, expand_makefile_vars
+
+def printUsage():
+ print "Usage: %s -h HEADER -m MAKEFILE -o OUTPUT" % argv[0]
+
+try:
+ (opts, args) = getopt(argv[1:], "h:m:o:")
+except GetoptError, error:
+ print "%s: %s" % (argv[0], error)
+ printUsage()
+ exit(1)
+
+header = '';
+makefile = '';
+output = '';
+for option, parameter in opts:
+ if option == '-h':
+ header = parameter
+ elif option == '-m':
+ makefile = parameter
+ elif option == '-o':
+ output = parameter
+if not (header and makefile and output):
+ printUsage()
+ exit(1)
+
+f = open(header)
+config_vars = parse_config_h(f)
+f.close()
+
+makefile_vars = parse_makefile(makefile)
+keys = makefile_vars.keys()
+for key in keys:
+ makefile_vars[key] = expand_makefile_vars(makefile_vars[key], makefile_vars)
+
+f = open(output, 'w')
+print >>f, "#!/usr/bin/env python"
+print >>f
+print >>f, "config =", config_vars
+print >>f
+print >>f, "makefile =", makefile_vars
+print >>f
+print >>f, "# end of file"
+f.close()
+
+# end of file]
+END_OF_PYTHON
+mv -f "$cfgfile" "$ofile" || \
+ (rm -f "$ofile" && cp "$cfgfile" "$ofile" && rm -f "$cfgfile")
+chmod +x "$ofile"
+])dnl CIT_PROG_PYCONFIG
+
+
+# CIT_PATH_NEMESIS
+# -----------------
+AC_DEFUN([CIT_PATH_NEMESIS], [
+# $Id: cit_python.m4 17971 2011-02-24 17:22:51Z brad $
+AC_BEFORE([$0], [AM_PATH_PYTHON])
+AC_PATH_PROG(PYTHON, nemesis, no)
+if test "$PYTHON" = no; then
+ AC_MSG_ERROR([program 'nemesis' not found])
+fi
+])dnl CIT_PATH_NEMESIS
+
+# CIT_PYTHON_MODULE(name, version)
+# -----------------
+# Determine whether module is available.
+AC_DEFUN([CIT_PYTHON_MODULE],[
+AC_REQUIRE([AM_PATH_PYTHON])
+AC_MSG_CHECKING(for python module $1)
+$PYTHON -c "import $1" 2>/dev/null
+if test $? == 0; then
+ eval s=`$PYTHON -c "import $1; print $1.__""file__"`
+ AC_MSG_RESULT([found $s])
+else
+ AC_MSG_FAILURE(not found)
+fi
+if test -n "$2" ; then
+ AC_MSG_CHECKING([for $1 version])
+ [eval `$PYTHON -c "import $1; print $1.__version__" | sed 's/\([0-9]\{1,\}\)\.\([0-9]\{1,\}\)\.\([0-9]\{1,\}\)/avail_major=\1; avail_minor=\2; avail_patch=\3/'`]
+ [eval `echo $2 | sed 's/\([0-9]\{1,\}\)\.\([0-9]\{1,\}\)\.\([0-9]\{1,\}\)/req_major=\1; req_minor=\2; req_patch=\3/' 2>/dev/null`]
+ if test -n "$avail_major" -a -n "$avail_minor" -a -n "$avail_patch"; then
+ if test $avail_major -lt $req_major ; then
+ AC_MSG_FAILURE([$1 version >= $2 is required. You have $avail_major.$avail_minor.$avail_patch.])
+ elif test $avail_major -eq $req_major -a $avail_minor -lt $req_minor; then
+ AC_MSG_FAILURE([$1 version >= $2 is required. You have $avail_major.$avail_minor.$avail_patch.])
+ elif test $avail_major -eq $req_major -a $avail_minor -eq $req_minor -a $avail_patch -lt $req_patch; then
+ AC_MSG_FAILURE([$1 version >= $2 is required. You have $avail_major.$avail_minor.$avail_patch.])
+ else
+ AC_MSG_RESULT([$avail_major.$avail_minor.$avail_patch])
+ fi
+ else
+ AC_MSG_FAILURE([Could not determine version of module $1. Version >= $2 is required.])
+ fi
+fi
+
+]) dnl CIT_PYTHON_MODULE
+
+
+
+
+dnl end of file
Deleted: seismo/2D/SPECFEM2D/trunk/src/adj_seismogram.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/adj_seismogram.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/adj_seismogram.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,176 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- program adj_seismogram
-
-! This program cuts a certain portion of the seismograms and convert it
-! into the adjoint source for generating banana-dougnut kernels
-
- implicit none
-!
-!!!! user edit
- integer, parameter :: NSTEP = 3000
- integer, parameter :: nrec = 1
- double precision, parameter :: t0 = 12
- double precision, parameter :: deltat = 6d-2
- double precision, parameter :: EPS = 1.d-40
-!!!!
- integer :: itime,icomp,istart,iend,nlen,irec,NDIM,NDIMr,adj_comp
- double precision :: time,tstart(nrec),tend(nrec)
- character(len=150), dimension(nrec) :: station_name
- double precision, dimension(NSTEP) :: time_window
- double precision :: seism(NSTEP,3),Nnorm,seism_win(NSTEP)
- double precision :: seism_veloc(NSTEP),seism_accel(NSTEP),ft_bar(NSTEP)
- character(len=3) :: compr(2),comp(3)
- character(len=150) :: filename,filename2
-
- NDIM=3
- comp = (/"BHX","BHY","BHZ"/)
-
-!!!! user edit
-! which calculation: P-SV (use (1)) or SH (membrane) (use (2)) waves
- NDIMr=2 !(1)
-! NDIMr=1 !(2)
-! list of stations
- station_name(1) = 'S0001'
- tstart(1) = 100d0 + t0
- tend(1) = 120d0 + t0
-! which calculation: P-SV (use (1)) or SH (membrane) (use (2)) waves
- compr = (/"BHX","BHZ"/) !(1)
-! compr = (/"BHY","dummy"/) !(2)
-! chose the component for the adjoint source (adj_comp = 1: X, 2:Y, 3:Z)
- adj_comp = 1
-!!!!
-
- do irec =1,nrec
-
- do icomp = 1, NDIMr
-
- filename = 'OUTPUT_FILES/'//trim(station_name(irec))//'.AA.'// compr(icomp) // '.semd'
- open(unit = 10, file = trim(filename))
-
- do itime = 1,NSTEP
- read(10,*) time , seism(itime,icomp)
- enddo
-
- enddo
-
- if(NDIMr==2)then
- seism(:,3) = seism(:,2)
- seism(:,2) = 0.d0
- else
- seism(:,2) = seism(:,1)
- seism(:,1) = 0.d0
- seism(:,3) = 0.d0
- endif
-
- close(10)
-
-
- istart = max(floor(tstart(irec)/deltat),1)
- iend = min(floor(tend(irec)/deltat),NSTEP)
- print*,'istart =',istart, 'iend =', iend
- print*,'tstart =',istart*deltat, 'tend =', iend*deltat
- if(istart >= iend) stop 'check istart,iend'
- nlen = iend - istart +1
-
- do icomp = 1, NDIM
-
- print*,comp(icomp)
-
- filename = 'OUTPUT_FILES/'//trim(station_name(irec))//'.AA.'// comp(icomp) // '.adj'
- open(unit = 11, file = trim(filename))
-
- time_window(:) = 0.d0
- seism_win(:) = seism(:,icomp)
- seism_veloc(:) = 0.d0
- seism_accel(:) = 0.d0
-
- do itime =istart,iend
-! time_window(itime) = 1.d0 - cos(pi*(itime-1)/NSTEP+1)**10 ! cosine window
- time_window(itime) = 1.d0 - (2* (dble(itime) - istart)/(iend-istart) -1.d0)**2 ! Welch window
- enddo
-
- do itime = 2,NSTEP-1
- seism_veloc(itime) = (seism_win(itime+1) - seism_win(itime-1))/(2*deltat)
- enddo
- seism_veloc(1) = (seism_win(2) - seism_win(1))/deltat
- seism_veloc(NSTEP) = (seism_win(NSTEP) - seism_win(NSTEP-1))/deltat
-
- do itime = 2,NSTEP-1
- seism_accel(itime) = (seism_veloc(itime+1) - seism_veloc(itime-1))/(2*deltat)
- enddo
- seism_accel(1) = (seism_veloc(2) - seism_veloc(1))/deltat
- seism_accel(NSTEP) = (seism_veloc(NSTEP) - seism_veloc(NSTEP-1))/deltat
-
- Nnorm = deltat * sum(time_window(:) * seism_win(:) * seism_accel(:))
-! Nnorm = deltat * sum(time_window(:) * seism_veloc(:) * seism_veloc(:))
-! cross-correlation traveltime adjoint source
- if(abs(Nnorm) > EPS) then
-! ft_bar(:) = - seism_veloc(:) * time_window(:) / Nnorm
- ft_bar(:) = seism_veloc(:) * time_window(:) / Nnorm
- print*,'Norm =', Nnorm
- else
- print *, 'norm < EPS for file '
- print*,'Norm =', Nnorm
- ft_bar(:) = 0.d0
- endif
-
- do itime =1,NSTEP
- if(icomp == adj_comp) then
- write(11,*) (itime-1)*deltat - t0, ft_bar(itime)
- else
- write(11,*) (itime-1)*deltat - t0, 0.d0
- endif
- enddo
-
- enddo
- close(11)
-
- enddo
- print*,'*************************'
- print*,'The input files (S****.AA.BHX/BHY/BHZ.adj) needed to run the adjoint simulation are in OUTPUT_FILES'
- print*,'*************************'
-
- end program adj_seismogram
Deleted: seismo/2D/SPECFEM2D/trunk/src/assemble_MPI.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/assemble_MPI.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/assemble_MPI.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,563 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!
-! 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.
-!
-
-
-#ifdef USE_MPI
-
-!-----------------------------------------------
-! Assembling the mass matrix.
-!-----------------------------------------------
- subroutine assemble_MPI_scalar(array_val1,npoin_val1, &
- array_val2,npoin_val2, &
- array_val3,array_val4,npoin_val3, &
- 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
-
- include 'constants.h'
- include 'mpif.h'
-
- 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, 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) :: my_neighbours
- ! array to assemble
- ! acoustic
- integer :: npoin_val1
- real(kind=CUSTOM_REAL), dimension(npoin_val1), intent(inout) :: array_val1
- ! elastic
- integer :: npoin_val2
- real(kind=CUSTOM_REAL), dimension(npoin_val2), intent(inout) :: array_val2
- ! poroelastic
- integer :: npoin_val3
- real(kind=CUSTOM_REAL), dimension(npoin_val3), intent(inout) :: array_val3,array_val4
-
- integer :: ipoin, num_interface
- integer :: ier
- integer :: i
- double precision, dimension(max_ibool_interfaces_size_ac+max_ibool_interfaces_size_el+&
- 2*max_ibool_interfaces_size_po, ninterface) :: &
- buffer_send_faces_scalar, &
- buffer_recv_faces_scalar
- integer, dimension(MPI_STATUS_SIZE) :: msg_status
- integer, dimension(ninterface) :: msg_requests
-
- buffer_send_faces_scalar(:,:) = 0.d0
- buffer_recv_faces_scalar(:,:) = 0.d0
-
- do num_interface = 1, ninterface
-
- ipoin = 0
- do i = 1, nibool_interfaces_acoustic(num_interface)
- ipoin = ipoin + 1
- buffer_send_faces_scalar(ipoin,num_interface) = &
- array_val1(ibool_interfaces_acoustic(i,num_interface))
- end do
-
- do i = 1, nibool_interfaces_elastic(num_interface)
- ipoin = ipoin + 1
- buffer_send_faces_scalar(ipoin,num_interface) = &
- array_val2(ibool_interfaces_elastic(i,num_interface))
- end do
-
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- ipoin = ipoin + 1
- buffer_send_faces_scalar(ipoin,num_interface) = &
- array_val3(ibool_interfaces_poroelastic(i,num_interface))
- end do
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- ipoin = ipoin + 1
- buffer_send_faces_scalar(ipoin,num_interface) = &
- array_val4(ibool_interfaces_poroelastic(i,num_interface))
- end do
-
- ! non-blocking synchronous send request
- 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)
-
- end do
-
- do num_interface = 1, ninterface
-
- ! starts a blocking receive
- call MPI_recv ( buffer_recv_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_status(1), ier)
-
- 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_scalar(ipoin,num_interface)
- end do
-
- do i = 1, nibool_interfaces_elastic(num_interface)
- ipoin = ipoin + 1
- array_val2(ibool_interfaces_elastic(i,num_interface)) = &
- array_val2(ibool_interfaces_elastic(i,num_interface)) &
- + buffer_recv_faces_scalar(ipoin,num_interface)
- end do
-
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- ipoin = ipoin + 1
- array_val3(ibool_interfaces_poroelastic(i,num_interface)) = &
- array_val3(ibool_interfaces_poroelastic(i,num_interface)) &
- + buffer_recv_faces_scalar(ipoin,num_interface)
- end do
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- ipoin = ipoin + 1
- array_val4(ibool_interfaces_poroelastic(i,num_interface)) = &
- array_val4(ibool_interfaces_poroelastic(i,num_interface)) &
- + buffer_recv_faces_scalar(ipoin,num_interface)
- end do
-
- end do
-
- ! synchronizes MPI processes
- call MPI_BARRIER(mpi_comm_world,ier)
-
- end subroutine assemble_MPI_scalar
-
-
-!-----------------------------------------------
-! Assembling potential_dot_dot for acoustic 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_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_recv_faces_vector_ac, &
- my_neighbours )
-
- implicit none
-
- include 'constants.h'
- include 'mpif.h'
- include 'precision_mpi.h'
-
- 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_send_faces_vector_ac
- real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(inout) :: &
- buffer_recv_faces_vector_ac
- ! array to assemble
- real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1
- integer, dimension(ninterface), intent(in) :: my_neighbours
-
- ! local parameters
- integer :: ipoin, num_interface,iinterface,ier,iglob
- integer, dimension(MPI_STATUS_SIZE) :: status_acoustic
-
- ! initializes buffers
- buffer_send_faces_vector_ac(:,:) = 0._CUSTOM_REAL
- buffer_recv_faces_vector_ac(:,:) = 0._CUSTOM_REAL
- tab_requests_send_recv_acoustic(:) = 0
-
- ! loops over acoustic interfaces only
- do iinterface = 1, ninterface_acoustic
-
- ! gets interface index in the range of all interfaces [1,ninterface]
- num_interface = inum_interfaces_acoustic(iinterface)
-
- ! loops over all interface points
- do ipoin = 1, nibool_interfaces_acoustic(num_interface)
- iglob = ibool_interfaces_acoustic(ipoin,num_interface)
-
- ! copies array values to buffer
- buffer_send_faces_vector_ac(ipoin,iinterface) = array_val1(iglob)
- end do
-
- end do
-
- do iinterface = 1, ninterface_acoustic
-
- ! gets global interface index
- num_interface = inum_interfaces_acoustic(iinterface)
-
- ! non-blocking synchronous send
- call MPI_ISSEND( buffer_send_faces_vector_ac(1,iinterface), &
- nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_acoustic(iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_start')
- end if
-
- ! starts a non-blocking receive
- call MPI_Irecv ( buffer_recv_faces_vector_ac(1,iinterface), &
- nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_acoustic(ninterface_acoustic+iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector')
- end if
-
- end do
-
-
- ! waits for MPI requests to complete (recv)
- ! each wait returns once the specified MPI request completed
- do iinterface = 1, ninterface_acoustic
- call MPI_Wait (tab_requests_send_recv_acoustic(ninterface_acoustic+iinterface), &
- status_acoustic, ier)
- enddo
-
- ! assembles the array values
- do iinterface = 1, ninterface_acoustic
-
- ! gets global interface index
- num_interface = inum_interfaces_acoustic(iinterface)
-
- ! loops over all interface points
- do ipoin = 1, nibool_interfaces_acoustic(num_interface)
- iglob = ibool_interfaces_acoustic(ipoin,num_interface)
- ! adds buffer contribution
- array_val1(iglob) = array_val1(iglob) + buffer_recv_faces_vector_ac(ipoin,iinterface)
- end do
-
- end do
-
-
- ! waits for MPI requests to complete (send)
- ! just to make sure that all sending is done
- do iinterface = 1, ninterface_acoustic
- call MPI_Wait (tab_requests_send_recv_acoustic(iinterface), status_acoustic, ier)
- enddo
-
-
- end subroutine assemble_MPI_vector_ac
-
-
-!-----------------------------------------------
-! 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_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_recv_faces_vector_el, &
- my_neighbours)
-
- implicit none
-
- include 'constants.h'
- include 'mpif.h'
- include 'precision_mpi.h'
-
- 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(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
- ! array to assemble
- real(kind=CUSTOM_REAL), dimension(3,npoin), intent(inout) :: array_val2
- integer, dimension(ninterface), intent(in) :: my_neighbours
-
- integer :: ipoin, num_interface, iinterface, ier, i
- integer, dimension(MPI_STATUS_SIZE) :: status_elastic
-
-
- do iinterface = 1, ninterface_elastic
-
- num_interface = inum_interfaces_elastic(iinterface)
-
- ipoin = 0
- do i = 1, nibool_interfaces_elastic(num_interface)
- buffer_send_faces_vector_el(ipoin+1:ipoin+3,iinterface) = &
- array_val2(:,ibool_interfaces_elastic(i,num_interface))
- ipoin = ipoin + 3
- end do
-
- end do
-
- do iinterface = 1, ninterface_elastic
-
- num_interface = inum_interfaces_elastic(iinterface)
-
- call MPI_ISSEND( buffer_send_faces_vector_el(1,iinterface), &
- 3*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_elastic(iinterface), 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,iinterface), &
- 3*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_elastic(ninterface_elastic+iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_el')
- end if
-
- end do
-
- do iinterface = 1, ninterface_elastic*2
-
- call MPI_Wait (tab_requests_send_recv_elastic(iinterface), status_elastic, ier)
-
- enddo
-
- do iinterface = 1, ninterface_elastic
-
- num_interface = inum_interfaces_elastic(iinterface)
-
- 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+3,iinterface)
- ipoin = ipoin + 3
- end do
-
- end do
-
- end subroutine assemble_MPI_vector_el
-
-
-!-----------------------------------------------
-! 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(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_poro, &
- 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'
-
- 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*4), intent(inout) :: tab_requests_send_recv_poro
- 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
- ! array to assemble
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(inout) :: array_val3,array_val4
- integer, dimension(ninterface), intent(in) :: my_neighbours
-
- integer :: ipoin, num_interface, iinterface, ier, i
- integer, dimension(MPI_STATUS_SIZE) :: status_poroelastic
-
-
- do iinterface = 1, ninterface_poroelastic
-
- num_interface = inum_interfaces_poroelastic(iinterface)
-
- ipoin = 0
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- buffer_send_faces_vector_pos(ipoin+1:ipoin+2,iinterface) = &
- array_val3(:,ibool_interfaces_poroelastic(i,num_interface))
- ipoin = ipoin + 2
- end do
-
- ipoin = 0
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- buffer_send_faces_vector_pow(ipoin+1:ipoin+2,iinterface) = &
- array_val4(:,ibool_interfaces_poroelastic(i,num_interface))
- ipoin = ipoin + 2
- end do
-
- end do
-
- do iinterface = 1, ninterface_poroelastic
-
- num_interface = inum_interfaces_poroelastic(iinterface)
-
- call MPI_ISSEND( buffer_send_faces_vector_pos(1,iinterface), &
- NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_poro(iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pos')
- end if
-
- call MPI_Irecv ( buffer_recv_faces_vector_pos(1,iinterface), &
- NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_poro(ninterface_poroelastic+iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pos')
- end if
-
- call MPI_ISSEND( buffer_send_faces_vector_pow(1,iinterface), &
- NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_poro(ninterface_poroelastic*2+iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pow')
- end if
-
- call MPI_Irecv ( buffer_recv_faces_vector_pow(1,iinterface), &
- NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_poro(ninterface_poroelastic*3+iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pow')
- end if
-
- end do
-
- do iinterface = 1, ninterface_poroelastic*4
-
- call MPI_Wait (tab_requests_send_recv_poro(iinterface), status_poroelastic, ier)
-
- enddo
-
- do iinterface = 1, ninterface_poroelastic
-
- num_interface = inum_interfaces_poroelastic(iinterface)
-
- ipoin = 0
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) = &
- array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) + &
- buffer_recv_faces_vector_pos(ipoin+1:ipoin+2,iinterface)
- 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,iinterface)
- ipoin = ipoin + 2
- end do
-
- end do
-
- end subroutine assemble_MPI_vector_po
-
-#endif
Deleted: seismo/2D/SPECFEM2D/trunk/src/attenuation_compute_param.c
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/attenuation_compute_param.c 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/attenuation_compute_param.c 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,1176 +0,0 @@
-
-/* See Liu, Anderson & Kanamori (Geophysical Journal of the Royal Astronomical Society, vol. 47, p. 41-58, 1976) for details */
-
-/* cleaned by Dimitri Komatitsch, University of Pau, France, July 2007 */
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <stdio.h>
-#include <math.h>
-#include <sgtty.h>
-#include <signal.h>
-#include <stdlib.h>
-
-/* useful constants */
-
-#define PI 3.14159265358979
-#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".
-*/
-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;
- double Q_s, target_Qp, target_Qs;
- double f1, f2, Q, om0, Omega;
- double a, b;
- double kappa, mu, kappa0, mu0, kappaR, muR;
- double *tau_s, *tau_e;
- double *dvector();
- void constant_Q2_sub(),plot_modulus();
- void free_dvector();
-
-
- /* We get the arguments passed in fortran by adress. */
- target_Qp = *Qp_in; /* target value of Qp */
- target_Qs = *Qs_in; /* target value of Qs */
- n = *nmech_in; /* number of mechanisms */
- f1 = *f1_in; /* shortest frequency (Hz) */
- f2 = *f2_in; /* highest frequency (Hz) */
-
- /*
- printf("target value of Qp: ");
- scanf("%lf",&target_Qp);
- printf("%lf\n",target_Qp);
-
- printf("target value of Qs: ");
- scanf("%lf",&target_Qs);
- printf("%lf\n",target_Qs);
-
- printf("shortest frequency (Hz): ");
- scanf("%lf",&f1);
- printf("%lf\n",f1);
-
- printf("highest frequency (Hz): ");
- scanf("%lf",&f2);
- printf("%lf\n",f2);
-
- printf("number of mechanisms: ");
- scanf("%d",&n);
- printf("%d\n",n);
- */
-
-/* DK DK printf("1 = use xmgr 0 = do not use xmgr: "); */
-/* scanf("%d",&xmgr); */
- xmgr = 0;
-
- if (f2 < f1) {
- printf("T2 > T1\n");
- exit; }
-
- if (target_Qp <= 0.0001) {
- printf("Qp cannot be negative or null\n");
- exit; }
-
- if (target_Qs <= 0.0001) {
- printf("Qs cannot be negative or null\n");
- exit; }
-
- if (n < 1) {
- printf("n < 1\n");
- exit; }
-
- om0 = PI2 * pow(10.0, 0.5 * (log10(f1) + log10(f2)));
-
- /*
- printf("\n! put this in file constants.h\n\n");
-
- printf("! number of standard linear solids for attenuation\n");
- printf(" integer, parameter :: N_SLS = %d\n\n",n);
-
- printf("! put this in file attenuation_model.f90\n\n");
-
- printf("! frequency range: %lf Hz - %lf Hz\n", f1 , f2);
- printf("! central frequency in log scale in Hz = %20.15f\n",om0 / PI2);
-
- printf("! target constant attenuation factor Qp = %20.10lf\n", target_Qp);
- printf("! target constant attenuation factor Qs = %20.10lf\n\n", target_Qs);
-
- printf("! tau_sigma evenly spaced in log frequency, do not depend on value of Q\n\n");
- */
-
- plot = 0;
-
-/* loop on the Qp dilatation mode (nu = 1) and Qs shear mode (nu = 2) */
- for (nu = 1; nu <= 2; nu++) {
-
-/* assign Qp or Qs to generic variable Q_s which is used for the calculations */
- if (nu == 1) { Q_s = target_Qp ; }
- if (nu == 2) { Q_s = target_Qs ; }
-
- tau_s = dvector(1, n);
- tau_e = dvector(1, n);
-
- constant_Q2_sub(f1, f2, n, Q_s, tau_s, tau_e, xmgr);
-
-/* 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];
- }
- if ( nu == 2 ) {
- 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]);
- */
- /* We put the results in tau_epsilon_nu to get them in fortran. */
- if ( nu == 1 ) {
- tau_epsilon_nu1[i-1] = tau_e[i];
- }
- if ( nu == 2 ) {
- tau_epsilon_nu2[i-1] = tau_e[i];
- }
-
- }
- //printf("\n");
-
- free_dvector(tau_s, 1, n);
- free_dvector(tau_e, 1, n);
-
- }
-
-}
-
-void plot_modulus(f1, f2, n, m, mR, Q, tau_e, tau_s ,xmgr)
- int n, xmgr;
- double f1, f2, m, mR, Q, *tau_e, *tau_s;
-{
-int pid, i;
-double exp1, exp2, dexp, expo;
-double f, om, Omega;
-double a, b, m_om, m_prem;
-char strng[180];
-int getpid(), system();
-FILE *fp_v, *fp_q;
-
-pid = getpid();
-sprintf(strng, "modulus%1d", pid);
-if((fp_v=fopen(strng,"w"))==NULL) {
- puts("cannot open file\n");
- exit;
-}
-sprintf(strng, "Q%1d", pid);
-if((fp_q=fopen(strng,"w"))==NULL) {
- puts("cannot open file\n");
- exit;
-}
-
-exp1 = log10(f1) - 2.0;
-exp2 = log10(f2) + 2.0;
-dexp = (exp2 - exp1) / 100.0;
-for (expo = exp1; expo <= exp2; expo += dexp) {
- f = pow(10.0, expo);
- om = PI2 * f;
- a = 1.0;
- b = 0.0;
- for (i = 1; i <= n; i++) {
- a -= om * om * tau_e[i] * (tau_e[i] - tau_s[i]) /
- (1.0 + om * om * tau_e[i] * tau_e[i]);
- b += om * (tau_e[i] - tau_s[i]) /
- (1.0 + om * om * tau_e[i] * tau_e[i]);
- }
- Omega=a*(sqrt(1.0+b*b/(a*a))-1.0);
- m_om = 2.0*mR* Omega/(b*b);
- m_prem = m * (1.0 + (2.0 / (PI * Q)) * log(om / PI2));
- fprintf(fp_v, "%f %f %f\n", expo, m_om/m, m_prem/m);
- if (om >= PI2 * f1 && om <= PI2 * f2) {
- fprintf(fp_q, "%f %f %f\n", expo, 1.0/atan(b/a), Q);
- }
-}
-fclose(fp_v);
-fclose(fp_q);
-
-/* DK DK call xmgr to plot curves if needed */
-
-if (xmgr == 1) {
- sprintf(strng, "xmgr -nxy Q%1d", pid);
- system(strng);
- sprintf(strng, "xmgr -nxy modulus%1d", pid);
- system(strng);
- sprintf(strng, "rm modulus%1d", pid);
- system(strng);
- sprintf(strng, "rm Q%1d", pid);
- system(strng);
-}
-
-}
-
-#include <malloc.h>
-#include <stdio.h>
-
-void nrerror(error_text)
-char error_text[];
-{
- void exit();
-
- fprintf(stderr,"Numerical Recipes run-time error...\n");
- fprintf(stderr,"%s\n",error_text);
- fprintf(stderr,"...now exiting to system...\n");
- exit(1);
-}
-
-float *vector(nl,nh)
-int nl,nh;
-{
- float *v;
-
- v=(float *)malloc((unsigned) (nh-nl+1)*sizeof(float));
- if (!v) nrerror("allocation failure in vector()");
- return v-nl;
-}
-
-int *ivector(nl,nh)
-int nl,nh;
-{
- int *v;
-
- v=(int *)malloc((unsigned) (nh-nl+1)*sizeof(int));
- if (!v) nrerror("allocation failure in ivector()");
- return v-nl;
-}
-
-double *dvector(nl,nh)
-int nl,nh;
-{
- double *v;
-
- v=(double *)malloc((unsigned) (nh-nl+1)*sizeof(double));
- if (!v) nrerror("allocation failure in dvector()");
- return v-nl;
-}
-
-
-
-float **matrix(nrl,nrh,ncl,nch)
-int nrl,nrh,ncl,nch;
-{
- int i;
- float **m;
-
- m=(float **) malloc((unsigned) (nrh-nrl+1)*sizeof(float*));
- if (!m) nrerror("allocation failure 1 in matrix()");
- m -= nrl;
-
- for(i=nrl;i<=nrh;i++) {
- m[i]=(float *) malloc((unsigned) (nch-ncl+1)*sizeof(float));
- if (!m[i]) nrerror("allocation failure 2 in matrix()");
- m[i] -= ncl;
- }
- return m;
-}
-
-double **dmatrix(nrl,nrh,ncl,nch)
-int nrl,nrh,ncl,nch;
-{
- int i;
- double **m;
-
- m=(double **) malloc((unsigned) (nrh-nrl+1)*sizeof(double*));
- if (!m) nrerror("allocation failure 1 in dmatrix()");
- m -= nrl;
-
- for(i=nrl;i<=nrh;i++) {
- m[i]=(double *) malloc((unsigned) (nch-ncl+1)*sizeof(double));
- if (!m[i]) nrerror("allocation failure 2 in dmatrix()");
- m[i] -= ncl;
- }
- return m;
-}
-
-int **imatrix(nrl,nrh,ncl,nch)
-int nrl,nrh,ncl,nch;
-{
- int i,**m;
-
- m=(int **)malloc((unsigned) (nrh-nrl+1)*sizeof(int*));
- if (!m) nrerror("allocation failure 1 in imatrix()");
- m -= nrl;
-
- for(i=nrl;i<=nrh;i++) {
- m[i]=(int *)malloc((unsigned) (nch-ncl+1)*sizeof(int));
- if (!m[i]) nrerror("allocation failure 2 in imatrix()");
- m[i] -= ncl;
- }
- return m;
-}
-
-
-
-float **submatrix(a,oldrl,oldrh,oldcl,oldch,newrl,newcl)
-float **a;
-int oldrl,oldrh,oldcl,oldch,newrl,newcl;
-{
- int i,j;
- float **m;
-
- m=(float **) malloc((unsigned) (oldrh-oldrl+1)*sizeof(float*));
- if (!m) nrerror("allocation failure in submatrix()");
- m -= newrl;
-
- for(i=oldrl,j=newrl;i<=oldrh;i++,j++) m[j]=a[i]+oldcl-newcl;
-
- return m;
-}
-
-
-
-void free_vector(v,nl,nh)
-float *v;
-int nl,nh;
-{
- free((char*) (v+nl));
-}
-
-void free_ivector(v,nl,nh)
-int *v,nl,nh;
-{
- free((char*) (v+nl));
-}
-
-void free_dvector(v,nl,nh)
-double *v;
-int nl,nh;
-{
- free((char*) (v+nl));
-}
-
-
-
-void free_matrix(m,nrl,nrh,ncl,nch)
-float **m;
-int nrl,nrh,ncl,nch;
-{
- int i;
-
- for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
- free((char*) (m+nrl));
-}
-
-void free_dmatrix(m,nrl,nrh,ncl,nch)
-double **m;
-int nrl,nrh,ncl,nch;
-{
- int i;
-
- for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
- free((char*) (m+nrl));
-}
-
-void free_imatrix(m,nrl,nrh,ncl,nch)
-int **m;
-int nrl,nrh,ncl,nch;
-{
- int i;
-
- for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
- free((char*) (m+nrl));
-}
-
-
-
-void free_submatrix(b,nrl,nrh,ncl,nch)
-float **b;
-int nrl,nrh,ncl,nch;
-{
- free((char*) (b+nrl));
-}
-
-
-
-float **convert_matrix(a,nrl,nrh,ncl,nch)
-float *a;
-int nrl,nrh,ncl,nch;
-{
- int i,j,nrow,ncol;
- float **m;
-
- nrow=nrh-nrl+1;
- ncol=nch-ncl+1;
- m = (float **) malloc((unsigned) (nrow)*sizeof(float*));
- if (!m) nrerror("allocation failure in convert_matrix()");
- m -= nrl;
- for(i=0,j=nrl;i<=nrow-1;i++,j++) m[j]=a+ncol*i-ncl;
- return m;
-}
-
-
-
-void free_convert_matrix(b,nrl,nrh,ncl,nch)
-float **b;
-int nrl,nrh,ncl,nch;
-{
- free((char*) (b+nrl));
-}
-
-#include <math.h>
-
-#define NMAX 5000
-#define ALPHA 1.0
-#define BETA 0.5
-#define GAMMA 2.0
-
-#define GET_PSUM for (j=1;j<=ndim;j++) { for (i=1,sum=0.0;i<=mpts;i++)\
- sum += p[i][j]; psum[j]=sum;}
-
-void amoeba(p,y,ndim,ftol,funk,nfunk)
-float **p,y[],ftol,(*funk)();
-int ndim,*nfunk;
-{
- int i,j,ilo,ihi,inhi,mpts=ndim+1;
- float ytry,ysave,sum,rtol,amotry(),*psum,*vector();
- void nrerror(),free_vector();
-
- psum=vector(1,ndim);
- *nfunk=0;
- GET_PSUM
- for (;;) {
- ilo=1;
- ihi = y[1]>y[2] ? (inhi=2,1) : (inhi=1,2);
- for (i=1;i<=mpts;i++) {
- if (y[i] < y[ilo]) ilo=i;
- if (y[i] > y[ihi]) {
- inhi=ihi;
- ihi=i;
- } else if (y[i] > y[inhi])
- if (i != ihi) inhi=i;
- }
- rtol=2.0*fabs(y[ihi]-y[ilo])/(fabs(y[ihi])+fabs(y[ilo]));
- if (rtol < ftol) break;
- if (*nfunk >= NMAX) nrerror("Too many iterations in AMOEBA");
- ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,-ALPHA);
- if (ytry <= y[ilo])
- ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,GAMMA);
- else if (ytry >= y[inhi]) {
- ysave=y[ihi];
- ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,BETA);
- if (ytry >= ysave) {
- for (i=1;i<=mpts;i++) {
- if (i != ilo) {
- for (j=1;j<=ndim;j++) {
- psum[j]=0.5*(p[i][j]+p[ilo][j]);
- p[i][j]=psum[j];
- }
- y[i]=(*funk)(psum);
- }
- }
- *nfunk += ndim;
- GET_PSUM
- }
- }
- }
- free_vector(psum,1,ndim);
-}
-
-float amotry(p,y,psum,ndim,funk,ihi,nfunk,fac)
-float **p,*y,*psum,(*funk)(),fac;
-int ndim,ihi,*nfunk;
-{
- int j;
- float fac1,fac2,ytry,*ptry,*vector();
- void nrerror(),free_vector();
-
- ptry=vector(1,ndim);
- fac1=(1.0-fac)/ndim;
- fac2=fac1-fac;
- for (j=1;j<=ndim;j++) ptry[j]=psum[j]*fac1-p[ihi][j]*fac2;
- ytry=(*funk)(ptry);
- ++(*nfunk);
- if (ytry < y[ihi]) {
- y[ihi]=ytry;
- for (j=1;j<=ndim;j++) {
- psum[j] += ptry[j]-p[ihi][j];
- p[ihi][j]=ptry[j];
- }
- }
- free_vector(ptry,1,ndim);
- return ytry;
-}
-
-#undef ALPHA
-#undef BETA
-#undef GAMMA
-#undef NMAX
-
-void spline(x,y,n,yp1,ypn,y2)
-float x[],y[],yp1,ypn,y2[];
-int n;
-{
- int i,k;
- float p,qn,sig,un,*u,*vector();
- void free_vector();
-
- u=vector(1,n-1);
- if (yp1 > 0.99e30)
- y2[1]=u[1]=0.0;
- else {
- y2[1] = -0.5;
- u[1]=(3.0/(x[2]-x[1]))*((y[2]-y[1])/(x[2]-x[1])-yp1);
- }
- for (i=2;i<=n-1;i++) {
- sig=(x[i]-x[i-1])/(x[i+1]-x[i-1]);
- p=sig*y2[i-1]+2.0;
- y2[i]=(sig-1.0)/p;
- u[i]=(y[i+1]-y[i])/(x[i+1]-x[i]) - (y[i]-y[i-1])/(x[i]-x[i-1]);
- u[i]=(6.0*u[i]/(x[i+1]-x[i-1])-sig*u[i-1])/p;
- }
- if (ypn > 0.99e30)
- qn=un=0.0;
- else {
- qn=0.5;
- un=(3.0/(x[n]-x[n-1]))*(ypn-(y[n]-y[n-1])/(x[n]-x[n-1]));
- }
- y2[n]=(un-qn*u[n-1])/(qn*y2[n-1]+1.0);
- for (k=n-1;k>=1;k--)
- y2[k]=y2[k]*y2[k+1]+u[k];
- free_vector(u,1,n-1);
-}
-
-void splint(xa,ya,y2a,n,x,y)
-float xa[],ya[],y2a[],x,*y;
-int n;
-{
- int klo,khi,k;
- float h,b,a;
- void nrerror();
-
- klo=1;
- khi=n;
- while (khi-klo > 1) {
- k=(khi+klo) >> 1;
- if (xa[k] > x) khi=k;
- else klo=k;
- }
- h=xa[khi]-xa[klo];
- if (h == 0.0) nrerror("Bad XA input to routine SPLINT");
- a=(xa[khi]-x)/h;
- b=(x-xa[klo])/h;
- *y=a*ya[klo]+b*ya[khi]+((a*a*a-a)*y2a[klo]+(b*b*b-b)*y2a[khi])*(h*h)/6.0;
-}
-
-#define FUNC(x) ((*func)(x))
-
-float trapzd(func,a,b,n)
-float a,b;
-float (*func)(); /* ANSI: float (*func)(float); */
-int n;
-{
- float x,tnm,sum,del;
- static float s;
- static int it;
- int j;
-
- if (n == 1) {
- it=1;
- return (s=0.5*(b-a)*(FUNC(a)+FUNC(b)));
- } else {
- tnm=it;
- del=(b-a)/tnm;
- x=a+0.5*del;
- for (sum=0.0,j=1;j<=it;j++,x+=del) sum += FUNC(x);
- it *= 2;
- s=0.5*(s+(b-a)*sum/tnm);
- return s;
- }
-}
-
-#include <math.h>
-
-#define EPS 0.5e-5
-#define JMAX 20
-#define JMAXP JMAX+1
-#define K 5
-
-float qromb(func,a,b)
-float a,b;
-float (*func)();
-{
- float ss,dss,trapzd();
- float s[JMAXP+1],h[JMAXP+1];
- int j;
- void polint(),nrerror();
-
- h[1]=1.0;
- for (j=1;j<=JMAX;j++) {
- s[j]=trapzd(func,a,b,j);
- if (j >= K) {
- polint(&h[j-K],&s[j-K],K,0.0,&ss,&dss);
- if (fabs(dss) < EPS*fabs(ss)) return ss;
- }
- s[j+1]=s[j];
- h[j+1]=0.25*h[j];
- }
- nrerror("Too many steps in routine QROMB");
-}
-
-#undef EPS
-#undef JMAX
-#undef JMAXP
-#undef K
-
-#include <math.h>
-
-void polint(xa,ya,n,x,y,dy)
-float xa[],ya[],x,*y,*dy;
-int n;
-{
- int i,m,ns=1;
- float den,dif,dift,ho,hp,w;
- float *c,*d,*vector();
- void nrerror(),free_vector();
-
- dif=fabs(x-xa[1]);
- c=vector(1,n);
- d=vector(1,n);
- for (i=1;i<=n;i++) {
- if ( (dift=fabs(x-xa[i])) < dif) {
- ns=i;
- dif=dift;
- }
- c[i]=ya[i];
- d[i]=ya[i];
- }
- *y=ya[ns--];
- for (m=1;m<n;m++) {
- for (i=1;i<=n-m;i++) {
- ho=xa[i]-x;
- hp=xa[i+m]-x;
- w=c[i+1]-d[i];
- if ( (den=ho-hp) == 0.0) nrerror("Error in routine POLINT");
- den=w/den;
- d[i]=hp*den;
- c[i]=ho*den;
- }
- *y += (*dy=(2*ns < (n-m) ? c[ns+1] : d[ns--]));
- }
- free_vector(d,1,n);
- free_vector(c,1,n);
-}
-
-#define MBIG 1000000000
-#define MSEED 161803398
-#define MZ 0
-#define FAC (1.0/MBIG)
-
-float ran3(idum)
-int *idum;
-{
- static int inext,inextp;
- static long ma[56];
- static int iff=0;
- long mj,mk;
- int i,ii,k;
-
- if (*idum < 0 || iff == 0) {
- iff=1;
- mj=MSEED-(*idum < 0 ? -*idum : *idum);
- mj %= MBIG;
- ma[55]=mj;
- mk=1;
- for (i=1;i<=54;i++) {
- ii=(21*i) % 55;
- ma[ii]=mk;
- mk=mj-mk;
- if (mk < MZ) mk += MBIG;
- mj=ma[ii];
- }
- for (k=1;k<=4;k++)
- for (i=1;i<=55;i++) {
- ma[i] -= ma[1+(i+30) % 55];
- if (ma[i] < MZ) ma[i] += MBIG;
- }
- inext=0;
- inextp=31;
- *idum=1;
- }
- if (++inext == 56) inext=1;
- if (++inextp == 56) inextp=1;
- mj=ma[inext]-ma[inextp];
- if (mj < MZ) mj += MBIG;
- ma[inext]=mj;
- return mj*FAC;
-}
-
-#undef MBIG
-#undef MSEED
-#undef MZ
-#undef FAC
-
-#include <math.h>
-
-static double at,bt,ct;
-#define PYTHAG(a,b) ((at=fabs(a)) > (bt=fabs(b)) ? \
-(ct=bt/at,at*sqrt(1.0+ct*ct)) : (bt ? (ct=at/bt,bt*sqrt(1.0+ct*ct)): 0.0))
-
-static double maxarg1,maxarg2;
-#define MAX(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1) > (maxarg2) ?\
- (maxarg1) : (maxarg2))
-#define SIGN(a,b) ((b) >= 0.0 ? fabs(a) : -fabs(a))
-
-void dsvdcmp(a,m,n,w,v)
-double **a,*w,**v;
-int m,n;
-{
- int flag,i,its,j,jj,k,l,nm;
- double c,f,h,s,x,y,z;
- double anorm=0.0,g=0.0,scale=0.0;
- double *rv1,*dvector();
- void nrerror(),free_dvector();
-
- if (m < n) nrerror("SVDCMP: You must augment A with extra zero rows");
- rv1=dvector(1,n);
- for (i=1;i<=n;i++) {
- l=i+1;
- rv1[i]=scale*g;
- g=s=scale=0.0;
- if (i <= m) {
- for (k=i;k<=m;k++) scale += fabs(a[k][i]);
- if (scale) {
- for (k=i;k<=m;k++) {
- a[k][i] /= scale;
- s += a[k][i]*a[k][i];
- }
- f=a[i][i];
- g = -SIGN(sqrt(s),f);
- h=f*g-s;
- a[i][i]=f-g;
- if (i != n) {
- for (j=l;j<=n;j++) {
- for (s=0.0,k=i;k<=m;k++) s += a[k][i]*a[k][j];
- f=s/h;
- for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
- }
- }
- for (k=i;k<=m;k++) a[k][i] *= scale;
- }
- }
- w[i]=scale*g;
- g=s=scale=0.0;
- if (i <= m && i != n) {
- for (k=l;k<=n;k++) scale += fabs(a[i][k]);
- if (scale) {
- for (k=l;k<=n;k++) {
- a[i][k] /= scale;
- s += a[i][k]*a[i][k];
- }
- f=a[i][l];
- g = -SIGN(sqrt(s),f);
- h=f*g-s;
- a[i][l]=f-g;
- for (k=l;k<=n;k++) rv1[k]=a[i][k]/h;
- if (i != m) {
- for (j=l;j<=m;j++) {
- for (s=0.0,k=l;k<=n;k++) s += a[j][k]*a[i][k];
- for (k=l;k<=n;k++) a[j][k] += s*rv1[k];
- }
- }
- for (k=l;k<=n;k++) a[i][k] *= scale;
- }
- }
- anorm=MAX(anorm,(fabs(w[i])+fabs(rv1[i])));
- }
- for (i=n;i>=1;i--) {
- if (i < n) {
- if (g) {
- for (j=l;j<=n;j++)
- v[j][i]=(a[i][j]/a[i][l])/g;
- for (j=l;j<=n;j++) {
- for (s=0.0,k=l;k<=n;k++) s += a[i][k]*v[k][j];
- for (k=l;k<=n;k++) v[k][j] += s*v[k][i];
- }
- }
- for (j=l;j<=n;j++) v[i][j]=v[j][i]=0.0;
- }
- v[i][i]=1.0;
- g=rv1[i];
- l=i;
- }
- for (i=n;i>=1;i--) {
- l=i+1;
- g=w[i];
- if (i < n)
- for (j=l;j<=n;j++) a[i][j]=0.0;
- if (g) {
- g=1.0/g;
- if (i != n) {
- for (j=l;j<=n;j++) {
- for (s=0.0,k=l;k<=m;k++) s += a[k][i]*a[k][j];
- f=(s/a[i][i])*g;
- for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
- }
- }
- for (j=i;j<=m;j++) a[j][i] *= g;
- } else {
- for (j=i;j<=m;j++) a[j][i]=0.0;
- }
- ++a[i][i];
- }
- for (k=n;k>=1;k--) {
- for (its=1;its<=30;its++) {
- flag=1;
- for (l=k;l>=1;l--) {
- nm=l-1;
- if (fabs(rv1[l])+anorm == anorm) {
- flag=0;
- break;
- }
- if (fabs(w[nm])+anorm == anorm) break;
- }
- if (flag) {
- c=0.0;
- s=1.0;
- for (i=l;i<=k;i++) {
- f=s*rv1[i];
- if (fabs(f)+anorm != anorm) {
- g=w[i];
- h=PYTHAG(f,g);
- w[i]=h;
- h=1.0/h;
- c=g*h;
- s=(-f*h);
- for (j=1;j<=m;j++) {
- y=a[j][nm];
- z=a[j][i];
- a[j][nm]=y*c+z*s;
- a[j][i]=z*c-y*s;
- }
- }
- }
- }
- z=w[k];
- if (l == k) {
- if (z < 0.0) {
- w[k] = -z;
- for (j=1;j<=n;j++) v[j][k]=(-v[j][k]);
- }
- break;
- }
- if (its == 60) nrerror("No convergence in 60 SVDCMP iterations");
- x=w[l];
- nm=k-1;
- y=w[nm];
- g=rv1[nm];
- h=rv1[k];
- f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y);
- g=PYTHAG(f,1.0);
- f=((x-z)*(x+z)+h*((y/(f+SIGN(g,f)))-h))/x;
- c=s=1.0;
- for (j=l;j<=nm;j++) {
- i=j+1;
- g=rv1[i];
- y=w[i];
- h=s*g;
- g=c*g;
- z=PYTHAG(f,h);
- rv1[j]=z;
- c=f/z;
- s=h/z;
- f=x*c+g*s;
- g=g*c-x*s;
- h=y*s;
- y=y*c;
- for (jj=1;jj<=n;jj++) {
- x=v[jj][j];
- z=v[jj][i];
- v[jj][j]=x*c+z*s;
- v[jj][i]=z*c-x*s;
- }
- z=PYTHAG(f,h);
- w[j]=z;
- if (z) {
- z=1.0/z;
- c=f*z;
- s=h*z;
- }
- f=(c*g)+(s*y);
- x=(c*y)-(s*g);
- for (jj=1;jj<=m;jj++) {
- y=a[jj][j];
- z=a[jj][i];
- a[jj][j]=y*c+z*s;
- a[jj][i]=z*c-y*s;
- }
- }
- rv1[l]=0.0;
- rv1[k]=f;
- w[k]=x;
- }
- }
- free_dvector(rv1,1,n);
-}
-
-#undef SIGN
-#undef MAX
-#undef PYTHAG
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <stdio.h>
-#include <math.h>
-#include <sgtty.h>
-#include <signal.h>
-#include <stdlib.h>
-
-/* useful constants */
-
-#define PI 3.14159265358979
-#define PI2 6.28318530717958
-
-void constant_Q2_sub(f1, f2, n, Q, tau_s, tau_e, xmgr)
-
- int n, xmgr;
- double f1, f2, Q;
- double *tau_s, *tau_e;
-{
- int i,j;
- double *x1, *x2;
- double *gradient, **hessian;
- double *dvector(), **dmatrix();
- void derivatives();
- void initialize(), invert();
- void free_dvector(), free_dmatrix();
-
- if (f2 < f1) {
- printf("T2 > T1\n");
- exit;
- }
- if (Q < 0.0) {
- printf("Q < 0\n");
- exit;
- }
- if (n < 1) {
- printf("n < 1\n");
- exit;
- }
-
- x1 = dvector(1, n);
- x2 = dvector(1, n);
- gradient = dvector(1, n);
- hessian = dmatrix(1, n, 1, n);
- for(i=1;i<=n;i++) {
- x1[i]=0.0;
- x2[i]=0.0;
- gradient[i]=0.0;
- for(j=1;j<=n;j++) hessian[i][j]=0.0;
- }
-
- initialize(f1, f2, n, Q, x1, x2);
-
- derivatives(f1, f2, n, Q, x1, x2, gradient, hessian);
-
- invert(x1, gradient, hessian, n);
-
- free_dvector(gradient, 1, n);
- free_dmatrix(hessian, 1, n, 1, n);
-
- for (i = 1; i <= n; i++) {
- tau_e[i]=x1[i] + x2[i];
- }
- for (i = 1; i <= n; i++) {
- tau_s[i]=x2[i];
- }
-
- free_dvector(x1, 1, n);
- free_dvector(x2, 1, n);
-
-}
-
-void initialize(f1, f2, n, Q, x1, x2)
- int n;
- double f1, f2, Q, *x1, *x2;
-{
-int i;
-double q, omega, *tau_e, *tau_s;
-double exp1, exp2, dexp, expo;
-double *dvector();
-void free_dvector();
-
-tau_e = dvector(1, n);
-tau_s = dvector(1, n);
-if (n > 1) {
- exp1 = log10(f1);
- exp2 = log10(f2);
- dexp = (exp2 - exp1) / ((double) (n - 1));
- q = 1.0 / ((n - 1.0) * Q);
- for (i = 1, expo = exp1; i <= n; i++, expo += dexp) {
- omega = PI2 * pow(10.0, expo);
- tau_s[i] = 1.0 / omega;
- tau_e[i] = tau_s[i] * (1.0 + q) / (1.0 - q);
- }
-} else {
- q = 1.0 / Q;
- exp1 = log10(f1);
- exp2 = log10(f2);
- expo=(exp1+exp2)/2.0;
- omega = PI2 * pow(10.0, expo);
- tau_s[1] = 1.0 / omega;
- tau_e[1] = tau_s[1] * (1.0 + q) / (1.0 - q);
-}
-/*
- * x1 denotes the parameter tau_e - tau_s and x2 denotes the parameter tau_s
- */
-for (i = 1; i <= n; i++) {
- x1[i] = tau_e[i] - tau_s[i];
- x2[i] = tau_s[i];
-}
-
-free_dvector(tau_e, 1, n);
-free_dvector(tau_s, 1, n);
-}
-
-double penalty(f1, f2, n, Q, x1, x2)
- int n;
- double f1, f2, Q, *x1, *x2;
-{
-int i;
-double exp1, exp2, dexp, expo;
-double pnlt;
-double f, df, omega;
-double tau_e, tau_s, a, b, Q_omega;
-
-exp1 = log10(f1);
-exp2 = log10(f2);
-dexp = (exp2 - exp1) / 100.0;
-pnlt = 0.0;
-for (expo = exp1; expo <= exp2; expo += dexp) {
- f = pow(10.0, expo);
- df = pow(10.0, expo + dexp) - f;
- omega = PI2 * f;
- a = (double) (1 - n);
- b = 0.0;
- for (i = 1; i <= n; i++) {
- tau_e = x1[i] + x2[i];
- tau_s = x2[i];
- a += (1.0 + omega * omega * tau_e * tau_s) /
- (1.0 + omega * omega * tau_s * tau_s);
- b += omega * (tau_e - tau_s) /
- (1.0 + omega * omega * tau_s * tau_s);
- }
- Q_omega = a / b;
- pnlt += pow(1.0 / Q - 1.0 / Q_omega, 2.0) * df;
-}
-pnlt /= (f2 - f1);
-return pnlt;
-}
-
-
-void derivatives(f1, f2, n, Q, x1, x2, gradient, hessian)
- int n;
- double f1, f2, Q, *x1, *x2;
- double *gradient, **hessian;
-{
-int i, j;
-double exp1, exp2, dexp, expo;
-double f, df, omega;
-double *dadp, *dbdp, *dqdp, d2qdp2;
-double tau_e, tau_s, a, b, Q_omega;
-double *dvector();
-void free_dvector();
-
-dadp = dvector(1, n);
-dbdp = dvector(1, n);
-dqdp = dvector(1, n);
-exp1 = log10(f1);
-exp2 = log10(f2);
-dexp = (exp2 - exp1) / 100.0;
-for (i = 1; i <= n; i++) {
- gradient[i] = 0.0;
- for (j = 1; j <= i; j++) {
- hessian[j][i] = 0.0;
- hessian[j][i] = hessian[i][j];
- }
-}
-for (expo = exp1; expo <= exp2; expo += dexp) {
- f = pow(10.0, expo);
- df = pow(10.0, expo + dexp) - f;
- omega = PI2 * f;
- a = (double) (1 - n);
- b = 0.0;
- for (i = 1; i <= n; i++) {
- tau_e = x1[i] + x2[i];
- tau_s = x2[i];
- a += (1.0 + omega * omega * tau_e * tau_s) /
- (1.0 + omega * omega * tau_s * tau_s);
- b += omega * (tau_e - tau_s) /
- (1.0 + omega * omega * tau_s * tau_s);
- dadp[i] = omega * omega * tau_s / (1.0 + omega * omega * tau_s * tau_s);
- dbdp[i] = omega / (1.0 + omega * omega * tau_s * tau_s);
- }
- Q_omega = a / b;
- for (i = 1; i <= n; i++) {
- dqdp[i] = (dbdp[i] - (b / a) * dadp[i]) / a;
- gradient[i] += 2.0 * (1.0 / Q_omega - 1.0 / Q) * dqdp[i] * df / (f2 - f1);
- for (j = 1; j <= i; j++) {
- d2qdp2 = -(dadp[i] * dbdp[j] + dbdp[i] * dadp[j]
- - 2.0 * (b / a) * dadp[i] * dadp[j]) / (a * a);
- hessian[i][j] += (2.0 * dqdp[i] * dqdp[j] + 2.0 * (1.0 / Q_omega - 1.0 / Q) * d2qdp2)
- * df / (f2 - f1);
- hessian[j][i] = hessian[i][j];
- }
- }
-}
-free_dvector(dadp, 1, n);
-free_dvector(dbdp, 1, n);
-free_dvector(dqdp, 1, n);
-}
-
-void invert(x, b, A, n)
- int n;
- double *x;
- double *b, **A;
-{
-int i, j, k;
-double *dvector(), **dmatrix();
-double *xp, *W, **V, **A_inverse;
-void free_dvector(), free_dmatrix(), dsvdcmp();
-
-xp = dvector(1, n);
-W = dvector(1, n);
-V = dmatrix(1, n, 1, n);
-A_inverse = dmatrix(1, n, 1, n);
-dsvdcmp(A, n, n, W, V);
-for (i = 1; i <= n; i++)
- for (j = 1; j <= n; j++)
- V[i][j] = (1.0 / W[i]) * A[j][i];
-for (i = 1; i <= n; i++) {
- for (j = 1; j <= n; j++) {
- A_inverse[i][j] = 0.0;
- for (k = 1; k <= n; k++)
- A_inverse[i][j] += A[i][k] * V[k][j];
- }
-}
-free_dvector(W, 1, n);
-free_dmatrix(V, 1, n, 1, n);
-for (i = 1; i <= n; i++) {
- xp[i] = x[i];
- for (j = 1; j <= n; j++) {
- xp[i] -= A_inverse[i][j] * b[j];
- }
- x[i] = xp[i];
-}
-free_dvector(xp, 1, n);
-free_dmatrix(A_inverse, 1, n, 1, n);
-}
Deleted: seismo/2D/SPECFEM2D/trunk/src/attenuation_model.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/attenuation_model.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/attenuation_model.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,153 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine 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 constants
-
- implicit none
-
- include "constants.h"
-
- integer :: N_SLS
- double precision :: Qp_attenuation,Qs_attenuation,f0_attenuation
- double precision, dimension(N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
- double precision :: Mu_nu1,Mu_nu2
-
- integer :: i_sls
-
- double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,tau_epsilon_nu2,tau_sigma_nu2
-
- double precision :: f1_attenuation, f2_attenuation
-
-
-! f1 and f2 are computed as : f2/f1=12 and (log(f1)+log(f2))/2 = log(f0)
- f1_attenuation = exp(log(f0_attenuation)-log(12.d0)/2.d0)
- f2_attenuation = 12.d0 * f1_attenuation
-
-! Call of C function that computes attenuation parameters (function in file "attenuation_compute_param.c";
-! a main can be found in UTILS/attenuation directory).
-! Beware of underscores in this function name; depending on your compiler and compilation options, you will have to add or
-! delete underscores. Also look in file "attenuation_compute_param.c" for this issue.
- call attenuation_compute_param(N_SLS, Qp_attenuation, Qs_attenuation, &
- f1_attenuation,f2_attenuation, &
- tau_sigma_nu1, tau_sigma_nu2, tau_epsilon_nu1, tau_epsilon_nu2)
-
-! attenuation constants for standard linear solids
-
-! nu1 is the dilatation mode
-! nu2 is the shear mode
-
-! array index (1) is the first standard linear solid, (2) is the second etc.
-
-! from J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
-! vol. 58(1), p. 110-120 (1993) for two memory-variable mechanisms (page 112).
-! Beware: these values implement specific values of the quality factors:
-! Qp approximately equal to 13 and Qs approximately equal to 10,
-! which means very high attenuation, see that paper for details.
-! tau_epsilon_nu1(1) = 0.0334d0
-! tau_sigma_nu1(1) = 0.0303d0
-! tau_epsilon_nu2(1) = 0.0352d0
-! tau_sigma_nu2(1) = 0.0287d0
-
-! tau_epsilon_nu1(2) = 0.0028d0
-! tau_sigma_nu1(2) = 0.0025d0
-! tau_epsilon_nu2(2) = 0.0029d0
-! tau_sigma_nu2(2) = 0.0024d0
-
-! from J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation
-! in a linear viscoelastic medium, Geophysical Journal International,
-! vol. 95, p. 597-611 (1988) for two memory-variable mechanisms (page 604).
-! Beware: these values implement specific values of the quality factors:
-! Qp approximately equal to 27 and Qs approximately equal to 20,
-! which means very high attenuation, see that paper for details.
-! tau_epsilon_nu1(1) = 0.0325305d0
-! tau_sigma_nu1(1) = 0.0311465d0
-! tau_epsilon_nu2(1) = 0.0332577d0
-! tau_sigma_nu2(1) = 0.0304655d0
-
-! tau_epsilon_nu1(2) = 0.0032530d0
-! tau_sigma_nu1(2) = 0.0031146d0
-! tau_epsilon_nu2(2) = 0.0033257d0
-! tau_sigma_nu2(2) = 0.0030465d0
-
-! values for Paul Cristini for fluid-solid ocean acoustics simulations
-
-! for N_SLS = 2
-! frequency range: 1.500000 Hz - 18.000000 Hz
-! central frequency in log scale in Hz = 5.196152422706633
-! target constant attenuation factor Q = 136.4376068115
-! tau sigma evenly spaced in log frequency, do not depend on value of Q
-
-! tau_sigma_nu1(1) = 0.10610329539459699422d0
-! tau_sigma_nu1(2) = 0.00884194128288308401d0
-
-! tau_epsilon_nu1(1) = 0.10754721280605997191d0
-! tau_epsilon_nu1(2) = 0.00895488050110176612d0
-
-! tau_epsilon_nu2(1) = tau_epsilon_nu1(1)
-! tau_epsilon_nu2(2) = tau_epsilon_nu1(2)
-! tau_sigma_nu2(1) = tau_sigma_nu1(1)
-! tau_sigma_nu2(2) = tau_sigma_nu1(2)
-
-!
-!--- other constants computed from the parameters above, do not modify
-!
- inv_tau_sigma_nu1(:) = ONE / tau_sigma_nu1(:)
- inv_tau_sigma_nu2(:) = ONE / tau_sigma_nu2(:)
-
- phi_nu1(:) = (ONE - tau_epsilon_nu1(:)/tau_sigma_nu1(:)) / tau_sigma_nu1(:)
- phi_nu2(:) = (ONE - tau_epsilon_nu2(:)/tau_sigma_nu2(:)) / tau_sigma_nu2(:)
-
- Mu_nu1 = ONE
- Mu_nu2 = ONE
-
- do i_sls = 1,N_SLS
- Mu_nu1 = Mu_nu1 - (ONE - tau_epsilon_nu1(i_sls)/tau_sigma_nu1(i_sls))
- Mu_nu2 = Mu_nu2 - (ONE - tau_epsilon_nu2(i_sls)/tau_sigma_nu2(i_sls))
- enddo
-
- end subroutine attenuation_model
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/calendar.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/calendar.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/calendar.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,729 +0,0 @@
-
- integer function julian_day(yr,mo,da)
-
- implicit none
-
- integer yr,mo,da
-
- integer mon(12)
- integer lpyr
- data mon /0,31,59,90,120,151,181,212,243,273,304,334/
-
- julian_day = da + mon(mo)
- if(mo>2) julian_day = julian_day + lpyr(yr)
-
- end function julian_day
-
-! ------------------------------------------------------------------
-
- integer function lpyr(yr)
-
- implicit none
-
- integer yr
-!
-!---- returns 1 if leap year
-!
- lpyr=0
- if(mod(yr,400) == 0) then
- lpyr=1
- else if(mod(yr,4) == 0) then
- lpyr=1
- if(mod(yr,100) == 0) lpyr=0
- endif
-
- end function lpyr
-
-! ------------------------------------------------------------------
-
-! function to determine if year is a leap year
- logical function is_leap_year(yr)
-
- implicit none
-
- integer yr
-
- integer, external :: lpyr
-
-!---- function lpyr above returns 1 if leap year
- if(lpyr(yr) == 1) then
- is_leap_year = .true.
- else
- is_leap_year = .false.
- endif
-
- end function is_leap_year
-
-
-!----------------------------------------------------------------------------------------------
-! open-source subroutines below taken from ftp://ftp.met.fsu.edu/pub/ahlquist/calendar_software
-!----------------------------------------------------------------------------------------------
-
- integer function idaywk(jdayno)
-
-! IDAYWK = compute the DAY of the WeeK given the Julian Day number,
-! version 1.0.
-
- implicit none
-
-! Input variable
- integer, intent(in) :: jdayno
-! jdayno = Julian Day number starting at noon of the day in question.
-
-! Output of the function:
-! idaywk = day of the week, where 0=Sunday, 1=Monday, ..., 6=Saturday.
-
-!----------
-! Compute the day of the week given the Julian Day number.
-! You can find the Julian Day number given (day,month,year)
-! using subroutine calndr below.
-! Example: For the first day of the Gregorian calendar,
-! Friday 15 October 1582, compute the Julian day number (option 3 of
-! subroutine calndr) and compute the day of the week.
-! call calndr (3, 15, 10, 1582, jdayno)
-! write(*,*) jdayno, idaywk(jdayno)
-! The numbers printed should be 2299161 and 5, where 5 refers to Friday.
-!
-! Copyright (C) 1999 Jon Ahlquist.
-! Issued under the second GNU General Public License.
-! See www.gnu.org for details.
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-! If you find any errors, please notify:
-! Jon Ahlquist <ahlquist at met.fsu.edu>
-! Dept of Meteorology
-! Florida State University
-! Tallahassee, FL 32306-4520
-! 15 March 1999.
-!
-!-----
-
-! converted to Fortran90 by Dimitri Komatitsch,
-! University of Pau, France, January 2008.
-
-! jdSun is the Julian Day number starting at noon on any Sunday.
-! I arbitrarily chose the first Sunday after Julian Day 1,
-! which is Julian Day 6.
- integer, parameter :: jdSun = 6
-
- idaywk = mod(jdayno-jdSun,7)
-
-! If jdayno-jdSun < 0, then we are taking the modulus of a negative
-! number. Fortran's built-in mod function returns a negative value
-! when the argument is negative. In that case, we adjust the result
-! to a positive value.
- if (idaywk < 0) idaywk = idaywk + 7
-
- end function idaywk
-
-!
-!----
-!
-
- subroutine calndr(iday,month,iyear,idayct)
-
-! CALNDR = CALeNDaR conversions, version 1.0
-
- implicit none
-
-! specify the desired calendar conversion option.
-! in order to return the julian day number, compatible with function idaywk from above,
-! we choose option 3
-! (tested with dates: Feb, 23 2010 -> idaywk = Tue
-! Dec, 24 2009 -> idaywk = Thu
-! Oct, 15 1582 -> idaywk = Fri ...which all look o.k. )
- integer, parameter :: ioptn = 3
-
-! Input/Output variables
- integer, intent(inout) :: iday,month,iyear,idayct
-
-!----------
-!
-! Subroutine calndr() performs calendar calculations using either
-! the standard Gregorian calendar or the old Julian calendar.
-! This subroutine extends the definitions of these calendar systems
-! to any arbitrary year. The algorithms in this subroutine
-! will work with any date in the past or future,
-! but overflows will occur if the numbers are sufficiently large.
-! For a computer using a 32-bit integer, this routine can handle
-! any date between roughly 5.8 million BC and 5.8 million AD
-! without experiencing overflow during calculations.
-!
-! No external functions or subroutines are called.
-!
-!----------
-!
-! INPUT/OUTPUT ARGUMENTS FOR SUBROUTINE CALNDR()
-!
-! "ioptn" is the desired calendar conversion option explained below.
-! Positive option values use the standard modern Gregorian calendar.
-! Negative option values use the old Julian calendar which was the
-! standard in Europe from its institution by Julius Caesar in 45 BC
-! until at least 4 October 1582. The Gregorian and Julian calendars
-! are explained further below.
-!
-! (iday,month,iyear) is a calendar date where "iday" is the day of
-! the month, "month" is 1 for January, 2 for February, etc.,
-! and "iyear" is the year. If the year is 1968 AD, enter iyear=1968,
-! since iyear=68 would refer to 68 AD.
-! For BC years, iyear should be negative, so 45 BC would be iyear=-45.
-! By convention, there is no year 0 under the BC/AD year numbering
-! scheme. That is, years proceed as 2 BC, 1 BC, 1 AD, 2 AD, etc.,
-! without including 0. Subroutine calndr() will print an error message
-! and stop if you specify iyear=0.
-!
-! "idayct" is a day count. It is either the day number during the
-! specified year or the Julian Day number, depending on the value
-! of ioptn. By day number during the specified year, we mean
-! idayct=1 on 1 January, idayct=32 on 1 February, etc., to idayct=365
-! or 366 on 31 December, depending on whether the specified year
-! is a leap year.
-!
-! The values of input variables are not changed by this subroutine.
-!
-!
-! ALLOWABLE VALUES FOR "IOPTN" and the conversions they invoke.
-! Positive option values ( 1 to 5) use the standard Gregorian calendar.
-! Negative option values (-1 to -5) use the old Julian calendar.
-!
-! Absolute
-! value
-! of ioptn Input variable(s) Output variable(s)
-!
-! 1 iday,month,iyear idayct
-! Given a calendar date (iday,month,iyear), compute the day number
-! (idayct) during the year, where 1 January is day number 1 and
-! 31 December is day number 365 or 366, depending on whether it is
-! a leap year.
-!
-! 2 idayct,iyear iday,month
-! Given the day number of the year (idayct) and the year (iyear),
-! compute the day of the month (iday) and the month (month).
-!
-! 3 iday,month,iyear idayct
-! Given a calendar date (iday,month,iyear), compute the Julian Day
-! number (idayct) that starts at noon of the calendar date specified.
-!
-! 4 idayct iday,month,iyear
-! Given the Julian Day number (idayct) that starts at noon,
-! compute the corresponding calendar date (iday,month,iyear).
-!
-! 5 idayct iday,month,iyear
-! Given the Julian Day number (idayct) that starts at noon,
-! compute the corresponding day number for the year (iday)
-! and year (iyear). On return from calndr(), "month" will always
-! be set equal to 1 when ioptn=5.
-!
-! No inverse function is needed for ioptn=5 because it is
-! available through option 3. One simply calls calndr() with:
-! ioptn = 3,
-! iday = day number of the year instead of day of the month,
-! month = 1, and
-! iyear = whatever the desired year is.
-!
-!----------
-!
-! EXAMPLES
-! The first 6 examples are for the standard Gregorian calendar.
-! All the examples deal with 15 October 1582, which was the first day
-! of the Gregorian calendar. 15 October is the 288-th day of the year.
-! Julian Day number 2299161 began at noon on 15 October 1582.
-!
-! Find the day number during the year on 15 October 1582
-! ioptn = 1
-! call calndr (ioptn, 15, 10, 1582, idayct)
-! calndr() should return idayct=288
-!
-! Find the day of the month and month for day 288 in year 1582.
-! ioptn = 2
-! call calndr (ioptn, iday, month, 1582, 288)
-! calndr() should return iday=15 and month=10.
-!
-! Find the Julian Day number for 15 October 1582.
-! ioptn = 3
-! call calndr (ioptn, 15, 10, 1582, julian)
-! calndr() should return julian=2299161
-!
-! Find the Julian Day number for day 288 during 1582 AD.
-! When the input is day number of the year, one should specify month=1
-! ioptn = 3
-! call calndr (ioptn, 288, 1, 1582, julian)
-! calndr() should return dayct=2299161
-!
-! Find the date for Julian Day number 2299161.
-! ioptn = 4
-! call calndr (ioptn, iday, month, iyear, 2299161)
-! calndr() should return iday=15, month=10, and iyear=1582
-!
-! Find the day number during the year (iday) and year
-! for Julian Day number 2299161.
-! ioptn = 5
-! call calndr (ioptn, iday, month, iyear, 2299161)
-! calndr() should return iday=288, month=1, iyear=1582
-!
-! Given 15 October 1582 under the Gregorian calendar,
-! find the date (idayJ,imonthJ,iyearJ) under the Julian calendar.
-! To do this, we call calndr() twice, using the Julian Day number
-! as the intermediate value.
-! call calndr ( 3, 15, 10, 1582, julian)
-! call calndr (-4, idayJ, monthJ, iyearJ, julian)
-! The first call to calndr() should return julian=2299161, and
-! the second should return idayJ=5, monthJ=10, iyearJ=1582
-!
-!----------
-!
-! BASIC CALENDAR INFORMATION
-!
-! The Julian calendar was instituted by Julius Caesar in 45 BC.
-! Every fourth year is a leap year in which February has 29 days.
-! That is, the Julian calendar assumes that the year is exactly
-! 365.25 days long. Actually, the year is not quite this long.
-! The modern Gregorian calendar remedies this by omitting leap years
-! in years divisible by 100 except when the year is divisible by 400.
-! Thus, 1700, 1800, and 1900 are leap years under the Julian calendar
-! but not under the Gregorian calendar. The years 1600 and 2000 are
-! leap years under both the Julian and the Gregorian calendars.
-! Other years divisible by 4 are leap years under both calendars,
-! such as 1992, 1996, 2004, 2008, 2012, etc. For BC years, we recall
-! that year 0 was omitted, so 1 BC, 5 BC, 9 BC, 13 BC, etc., and 401 BC,
-! 801 BC, 1201 BC, etc., are leap years under both calendars, while
-! 101 BC, 201 BC, 301 BC, 501 BC, 601 BC, 701 BC, 901 BC, 1001 BC,
-! 1101 BC, etc., are leap years under the Julian calendar but not
-! the Gregorian calendar.
-!
-! The Gregorian calendar is named after Pope Gregory XIII. He declared
-! that the last day of the old Julian calendar would be Thursday,
-! 4 October 1582 and that the following day, Friday, would be reckoned
-! under the new calendar as 15 October 1582. The jump of 10 days was
-! included to make 21 March closer to the spring equinox.
-!
-! Only a few Catholic countries (Italy, Poland, Portugal, and Spain)
-! switched to the Gregorian calendar on the day after 4 October 1582.
-! It took other countries months to centuries to change to the
-! Gregorian calendar. For example, England's first day under the
-! Gregorian calendar was 14 September 1752. The same date applied to
-! the entire British empire, including America. Japan, Russia, and many
-! eastern European countries did not change to the Gregorian calendar
-! until the 20th century. The last country to change was Turkey,
-! which began using the Gregorian calendar on 1 January 1927.
-!
-! Therefore, between the years 1582 and 1926 AD, you must know
-! the country in which an event was dated to interpret the date
-! correctly. In Sweden, there was even a year (1712) when February
-! had 30 days. Consult a book on calendars for more details
-! about when various countries changed their calendars.
-!
-! DAY NUMBER DURING THE YEAR
-! The day number during the year is simply a counter equal to 1 on
-! 1 January, 32 on 1 February, etc., thorugh 365 or 366 on 31 December,
-! depending on whether the year is a leap year. Sometimes this is
-! called the Julian Day, but that term is better reserved for the
-! day counter explained below.
-!
-! JULIAN DAY NUMBER
-! The Julian Day numbering system was designed by Joseph Scaliger
-! in 1582 to remove ambiguity caused by varying calendar systems.
-! The name "Julian Day" was chosen to honor Scaliger's father,
-! Julius Caesar Scaliger (1484-1558), an Italian scholar and physician
-! who lived in France. Because Julian Day numbering was especially
-! designed for astronomers, Julian Days begin at noon so that the day
-! counter does not change in the middle of an astronmer's observing
-! period. Julian Day 0 began at noon on 1 January 4713 BC under the
-! Julian calendar. A modern reference point is that 23 May 1968
-! (Gregorian calendar) was Julian Day 2,440,000.
-!
-! JULIAN DAY NUMBER EXAMPLES
-!
-! The table below shows a few Julian Day numbers and their corresponding
-! dates, depending on which calendar is used. A negative 'iyear' refers
-! to BC (Before Christ).
-!
-! Julian Day under calendar:
-! iday month iyear Gregorian Julian
-! 24 11 -4714 0 -38
-! 1 1 -4713 38 0
-! 1 1 1 1721426 1721424
-! 4 10 1582 2299150 2299160
-! 15 10 1582 2299161 2299171
-! 1 3 1600 2305508 2305518
-! 23 5 1968 2440000 2440013
-! 5 7 1998 2451000 2451013
-! 1 3 2000 2451605 2451618
-! 1 1 2001 2451911 2451924
-!
-! From this table, we can see that the 10 day difference between the
-! two calendars in 1582 grew to 13 days by 1 March 1900, since 1900 was
-! a leap year under the Julian calendar but not under the Gregorian
-! calendar. The gap will widen to 14 days after 1 March 2100 for the
-! same reason.
-!
-!----------
-!
-! PORTABILITY
-!
-! This subroutine is written in standard FORTRAN 90.
-! It calls no external functions or subroutines and should run
-! without problem on any computer having a 32-bit word or longer.
-!
-!----------
-!
-! ALGORITHM
-!
-! The goal in coding calndr() was clear, clean code, not efficiency.
-! Calendar calculations usually take a trivial fraction of the time
-! in any program in which dates conversions are involved.
-! Data analysis usually takes the most time.
-!
-! Standard algorithms are followed in this subroutine. Internal to
-! this subroutine, we use a year counter "jyear" such that
-! jyear=iyear when iyear is positive
-! =iyear+1 when iyear is negative.
-! Thus, jyear does not experience a 1 year jump like iyear does
-! when going from BC to AD. Specifically, jyear=0 when iyear=-1,
-! i.e., when the year is 1 BC.
-!
-! For simplicity in dealing with February, inside this subroutine,
-! we let the year begin on 1 March so that the adjustable month,
-! February is the last month of the year.
-! It is clear that the calendar used to work this way because the
-! months September, October, November, and December refer to
-! 7, 8, 9, and 10. For consistency, jyear is incremented on 1 March
-! rather than on 1 January. Of course, everything is adjusted back to
-! standard practice of years beginning on 1 January before answers
-! are returned to the routine that calls calndr().
-!
-! Lastly, we use a trick to calculate the number of days from 1 March
-! until the end of the month that precedes the specified month.
-! That number of days is int(30.6001*(month+1))-122,
-! where 30.6001 is used to avoid the possibility of round-off and
-! truncation error. For example, if 30.6 were used instead,
-! 30.6*5 should be 153, but round-off error could make it 152.99999,
-! which would then truncated to 152, causing an error of 1 day.
-!
-! Algorithm reference:
-! Dershowitz, Nachum and Edward M. Reingold, 1990: Calendrical
-! Calculations. Software-Practice and Experience, vol. 20, number 9
-! (September 1990), pp. 899-928.
-!
-! Copyright (C) 1999 Jon Ahlquist.
-! Issued under the second GNU General Public License.
-! See www.gnu.org for details.
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-! If you find any errors, please notify:
-! Jon Ahlquist <ahlquist at met.fsu.edu>
-! Dept of Meteorology
-! Florida State University
-! Tallahassee, FL 32306-4520
-! 15 March 1999.
-!
-!-----
-
-! converted to Fortran90 by Dimitri Komatitsch,
-! University of Pau, France, January 2008.
-
-! Declare internal variables.
- integer jdref, jmonth, jyear, leap, n1yr, n4yr, n100yr, n400yr, ndays, ndy400, ndy100, nyrs, yr400, yrref
-!
-! Explanation of all internal variables.
-! jdref Julian Day on which 1 March begins in the reference year.
-! jmonth Month counter which equals month+1 if month .gt. 2
-! or month+13 if month .le. 2.
-! jyear Year index, jyear=iyear if iyear .gt. 0, jyear=iyear+1
-! if iyear .lt. 0. Thus, jyear does not skip year 0
-! like iyear does between BC and AD years.
-! leap =1 if the year is a leap year, =0 if not.
-! n1yr Number of complete individual years between iyear and
-! the reference year after all 4, 100,
-! and 400 year periods have been removed.
-! n4yr Number of complete 4 year cycles between iyear and
-! the reference year after all 100 and 400 year periods
-! have been removed.
-! n100yr Number of complete 100 year periods between iyear and
-! the reference year after all 400 year periods
-! have been removed.
-! n400yr Number of complete 400 year periods between iyear and
-! the reference year.
-! ndays Number of days since 1 March during iyear. (In intermediate
-! steps, it holds other day counts as well.)
-! ndy400 Number of days in 400 years. Under the Gregorian calendar,
-! this is 400*365 + 100 - 3 = 146097. Under the Julian
-! calendar, this is 400*365 + 100 = 146100.
-! ndy100 Number of days in 100 years, Under the Gregorian calendar,
-! this is 100*365 + 24 = 36524. Under the Julian calendar,
-! this is 100*365 + 25 = 36525.
-! nyrs Number of years from the beginning of yr400
-! to the beginning of jyear. (Used for option +/-3).
-! yr400 The largest multiple of 400 years that is .le. jyear.
-!
-!
-!----------------------------------------------------------------
-! Do preparation work.
-!
-! Look for out-of-range option values.
- if ((ioptn == 0) .or. (abs(ioptn) >= 6)) then
- write(*,*)'For calndr(), you specified ioptn = ', ioptn
- write(*,*) 'Allowable values are 1 to 5 for the Gregorian calendar'
- write(*,*) 'and -1 to -5 for the Julian calendar.'
- stop
- endif
-!
-! Options 1-3 have "iyear" as an input value.
-! Internally, we use variable "jyear" that does not have a jump
-! from -1 (for 1 BC) to +1 (for 1 AD).
- if (abs(ioptn) <= 3) then
- if (iyear > 0) then
- jyear = iyear
- elseif (iyear == 0) then
- write(*,*) 'For calndr(), you specified the nonexistent year 0'
- stop
- else
- jyear = iyear + 1
- endif
-!
-! Set "leap" equal to 0 if "jyear" is not a leap year
-! and equal to 1 if it is a leap year.
- leap = 0
- if ((jyear/4)*4 == jyear) then
- leap = 1
- endif
- if ((ioptn > 0) .and. &
- ((jyear/100)*100 == jyear) .and. &
- ((jyear/400)*400 /= jyear) ) then
- leap = 0
- endif
- endif
-!
-! Options 3-5 involve Julian Day numbers, which need a reference year
-! and the Julian Days that began at noon on 1 March of the reference
-! year under the Gregorian and Julian calendars. Any year for which
-! "jyear" is divisible by 400 can be used as a reference year.
-! We chose 1600 AD as the reference year because it is the closest
-! multiple of 400 to the institution of the Gregorian calendar, making
-! it relatively easy to compute the Julian Day for 1 March 1600
-! given that, on 15 October 1582 under the Gregorian calendar,
-! the Julian Day was 2299161. Similarly, we need to do the same
-! calculation for the Julian calendar. We can compute this Julian
-! Day knwoing that on 4 October 1582 under the Julian calendar,
-! the Julian Day number was 2299160. The details of these calculations
-! is next.
-! From 15 October until 1 March, the number of days is the remainder
-! of October plus the days in November, December, January, and February:
-! 17+30+31+31+28 = 137, so 1 March 1583 under the Gregorian calendar
-! was Julian Day 2,299,298. Because of the 10 day jump ahead at the
-! switch from the Julian calendar to the Gregorian calendar, 1 March
-! 1583 under the Julian calendar was Julian Day 2,299,308. Making use
-! of the rules for the two calendar systems, 1 March 1600 was Julian
-! Day 2,299,298 + (1600-1583)*365 + 5 (due to leap years) =
-! 2,305,508 under the Gregorian calendar and day 2,305,518 under the
-! Julian calendar.
-! We also set the number of days in 400 years and 100 years.
-! For reference, 400 years is 146097 days under the Gregorian calendar
-! and 146100 days under the Julian calendar. 100 years is 36524 days
-! under the Gregorian calendar and 36525 days under the Julian calendar.
- if (abs(ioptn) >= 3) then
-!
-! Julian calendar values.
- yrref = 1600
- jdref = 2305518
-! = Julian Day reference value for the day that begins
-! at noon on 1 March of the reference year "yrref".
- ndy400 = 400*365 + 100
- ndy100 = 100*365 + 25
-!
-! Adjust for Gregorian calendar values.
- if (ioptn > 0) then
- jdref = jdref - 10
- ndy400 = ndy400 - 3
- ndy100 = ndy100 - 1
- endif
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -1 and +1:
-! Given a calendar date (iday,month,iyear), compute the day number
-! of the year (idayct), where 1 January is day number 1 and 31 December
-! is day number 365 or 366, depending on whether it is a leap year.
- if (abs(ioptn) == 1) then
-!
-! Compute the day number during the year.
- if (month <= 2) then
- idayct = iday + (month-1)*31
- else
- idayct = iday + int(30.6001 * (month+1)) - 63 + leap
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -2 and +2:
-! Given the day number of the year (idayct) and the year (iyear),
-! compute the day of the month (iday) and the month (month).
- elseif (abs(ioptn) == 2) then
-!
- if (idayct < 60+leap) then
- month = (idayct-1)/31
- iday = idayct - month*31
- month = month + 1
- else
- ndays = idayct - (60+leap)
-! = number of days past 1 March of the current year.
- jmonth = (10*(ndays+31))/306 + 3
-! = month counter, =4 for March, =5 for April, etc.
- iday = (ndays+123) - int(30.6001*jmonth)
- month = jmonth - 1
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -3 and +3:
-! Given a calendar date (iday,month,iyear), compute the Julian Day
-! number (idayct) that starts at noon.
- elseif (abs(ioptn) == 3) then
-!
-! Shift to a system where the year starts on 1 March, so January
-! and February belong to the preceding year.
-! Define jmonth=4 for March, =5 for April, ..., =15 for February.
- if (month <= 2) then
- jyear = jyear - 1
- jmonth = month + 13
- else
- jmonth = month + 1
- endif
-!
-! Find the closest multiple of 400 years that is .le. jyear.
- yr400 = (jyear/400)*400
-! = multiple of 400 years at or less than jyear.
- if (jyear < yr400) then
- yr400 = yr400 - 400
- endif
-!
- n400yr = (yr400 - yrref)/400
-! = number of 400-year periods from yrref to yr400.
- nyrs = jyear - yr400
-! = number of years from the beginning of yr400
-! to the beginning of jyear.
-!
-! Compute the Julian Day number.
- idayct = iday + int(30.6001*jmonth) - 123 + 365*nyrs + nyrs/4 &
- + jdref + n400yr*ndy400
-!
-! If we are using the Gregorian calendar, we must not count
-! every 100-th year as a leap year. nyrs is less than 400 years,
-! so we do not need to consider the leap year that would occur if
-! nyrs were divisible by 400, i.e., we do not add nyrs/400.
- if (ioptn > 0) then
- idayct = idayct - nyrs/100
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -5, -4, +4, and +5:
-! Given the Julian Day number (idayct) that starts at noon,
-! compute the corresponding calendar date (iday,month,iyear)
-! (abs(ioptn)=4) or day number during the year (abs(ioptn)=5).
- else
-!
-! Create a new reference date which begins on the nearest
-! 400-year cycle less than or equal to the Julian Day for 1 March
-! in the year in which the given Julian Day number (idayct) occurs.
- ndays = idayct - jdref
- n400yr = ndays / ndy400
-! = integral number of 400-year periods separating
-! idayct and the reference date, jdref.
- jdref = jdref + n400yr*ndy400
- if (jdref > idayct) then
- n400yr = n400yr - 1
- jdref = jdref - ndy400
- endif
-!
- ndays = idayct - jdref
-! = number from the reference date to idayct.
-!
- n100yr = min(ndays/ndy100, 3)
-! = number of complete 100-year periods
-! from the reference year to the current year.
-! The min() function is necessary to avoid n100yr=4
-! on 29 February of the last year in the 400-year cycle.
-!
- ndays = ndays - n100yr*ndy100
-! = remainder after removing an integral number of
-! 100-year periods.
-!
- n4yr = ndays / 1461
-! = number of complete 4-year periods in the current century.
-! 4 years consists of 4*365 + 1 = 1461 days.
-!
- ndays = ndays - n4yr*1461
-! = remainder after removing an integral number
-! of 4-year periods.
-!
- n1yr = min(ndays/365, 3)
-! = number of complete years since the last leap year.
-! The min() function is necessary to avoid n1yr=4
-! when the date is 29 February on a leap year,
-! in which case ndays=1460, and 1460/365 = 4.
-!
- ndays = ndays - 365*n1yr
-! = number of days so far in the current year,
-! where ndays=0 on 1 March.
-!
- iyear = n1yr + 4*n4yr + 100*n100yr + 400*n400yr + yrref
-! = year, as counted in the standard way,
-! but relative to 1 March.
-!
-! At this point, we need to separate ioptn=abs(4), which seeks a
-! calendar date, and ioptn=abs(5), which seeks the day number during
-! the year. First compute the calendar date if desired (abs(ioptn)=4).
- if (abs(ioptn) == 4) then
- jmonth = (10*(ndays+31))/306 + 3
-! = offset month counter. jmonth=4 for March, =13 for
-! December, =14 for January, =15 for February.
- iday = (ndays+123) - int(30.6001*jmonth)
-! = day of the month, starting with 1 on the first day
-! of the month.
-!
-! Now adjust for the fact that the year actually begins
-! on 1 January.
- if (jmonth <= 13) then
- month = jmonth - 1
- else
- month = jmonth - 13
- iyear = iyear + 1
- endif
-!
-! This code handles abs(ioptn)=5, finding the day number during the year.
- else
-! ioptn=5 always returns month=1, which we set now.
- month = 1
-!
-! We need to determine whether this is a leap year.
- leap = 0
- if ((jyear/4)*4 == jyear) then
- leap = 1
- endif
- if ((ioptn > 0) .and. &
- ((jyear/100)*100 == jyear) .and. &
- ((jyear/400)*400 /= jyear) ) then
- leap = 0
- endif
-!
-! Now find the day number "iday".
-! ndays is the number of days since the most recent 1 March,
-! so ndays=0 on 1 March.
- if (ndays <=305) then
- iday = ndays + 60 + leap
- else
- iday = ndays - 305
- iyear = iyear + 1
- endif
- endif
-!
-! Adjust the year if it is .le. 0, and hence BC (Before Christ).
- if (iyear <= 0) then
- iyear = iyear - 1
- endif
-!
-! End the code for the last option, ioptn.
- endif
-
- end subroutine calndr
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/check_quality_external_mesh.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/check_quality_external_mesh.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/check_quality_external_mesh.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,689 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! read an external 2D mesh file and display statistics about mesh quality;
-! and create an OpenDX file showing a given range of elements or a single element
-
-! Dimitri Komatitsch, University of Toulouse, France, January 2011.
-! (adapted from the version that is available in our 3D code, SPECFEM3D)
-
-!! DK DK
-!! DK DK this routine could be improved by computing the mean in addition to min and max of ratios
-!! DK DK
-
- program check_quality_external_mesh
-
- implicit none
-
- include "constants.h"
-
- integer, parameter :: NGNOD = 4 ! quadrangles
-
- integer :: NPOIN ! number of nodes
- integer :: NSPEC ! number of elements
-
- double precision, dimension(:), allocatable :: x,y,z
-
- integer, dimension(:,:), allocatable :: ibool
-
- integer :: i,ispec,iformat,ispec_min_edge_length,ispec_max_edge_length, &
- ispec_begin,ispec_end,ispec_to_output,ispec_equiangle_skewness_max
-
-! for quality of mesh
- double precision :: equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio
- double precision :: equiangle_skewness_min,edge_aspect_ratio_min,diagonal_aspect_ratio_min
- double precision :: equiangle_skewness_max,edge_aspect_ratio_max,diagonal_aspect_ratio_max
- double precision :: skewness_AVS_DX_min,skewness_AVS_DX_max,distance_min,distance_max
- double precision :: distmin,distmax
-
-! for histogram
- integer, parameter :: NCLASS = 20
- integer classes_skewness(0:NCLASS-1)
- integer :: iclass
- double precision :: current_percent,total_percent
-
-! to export elements that have a certain skewness range to OpenDX
- integer :: ntotspecAVS_DX
- logical :: USE_OPENDX
-
- character(len=100) interfacesfile,title
-
- ! flag to save the last frame for kernels calculation purpose and type of simulation
- logical :: SAVE_FORWARD
- integer :: SIMULATION_TYPE
-
- ! parameters for external mesh
- logical :: read_external_mesh
- character(len=256) :: mesh_file, nodes_coords_file
-
- ! ignore variable name field (junk) at the beginning of each input line
- !logical, parameter :: IGNORE_JUNK = .true.
-
- integer :: NPOIN_unique_needed
- integer, dimension(:), allocatable :: ibool_reduced
- logical, dimension(:), allocatable :: mask_ibool
-
- if(NGNOD /= 4) stop 'NGNOD must be 4'
-
- ! ***
- ! *** read the parameter file
- ! ***
-
- print *,'Reading the parameter file ... '
- print *
-
- open(unit=IIN,file='DATA/Par_file',status='old')
-
- ! read and ignore file names and path for output
- call read_value_string(IIN,IGNORE_JUNK,title)
- call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
-
- ! read and ignore type of simulation
- call read_value_integer(IIN,IGNORE_JUNK,SIMULATION_TYPE)
- call read_value_logical(IIN,IGNORE_JUNK,SAVE_FORWARD)
-
- ! read info about external mesh
- call read_value_logical(IIN,IGNORE_JUNK,read_external_mesh)
- if(.not. read_external_mesh) stop 'this program is designed for read_external_mesh = .true.'
- call read_value_string(IIN,IGNORE_JUNK,mesh_file)
- call read_value_string(IIN,IGNORE_JUNK,nodes_coords_file)
-
- print *
- print *,'1 = output elements above a certain skewness threshold in OpenDX format'
- print *,'2 = output a given element in OpenDX format'
- print *,'3 = do not output any OpenDX file'
- print *
- print *,'enter value:'
- read(5,*) iformat
-
- if(iformat < 1 .or. iformat > 3) stop 'exiting...'
-
- if(iformat == 1 .or. iformat == 2) then
- USE_OPENDX = .true.
- else
- USE_OPENDX = .false.
- endif
-
-! read the nodes
- print *
- print *,'start reading the external node file: ',nodes_coords_file(1:len_trim(nodes_coords_file))
- open(unit=10,file=nodes_coords_file,status='unknown',action='read')
-
-! read the header
- read(10,*) NPOIN
-
-! read the mesh
- print *,'start reading the external mesh file: ',mesh_file(1:len_trim(mesh_file))
- open(unit=11,file=mesh_file,status='unknown',action='read')
-
-! read the header
- read(11,*) NSPEC
-
- allocate(x(NPOIN))
- allocate(y(NPOIN))
- allocate(z(NPOIN))
-
- allocate(ibool(NGNOD,NSPEC))
-
- if(USE_OPENDX) then
-
- if(iformat == 1) then
-
-! read range of skewness used for elements
- print *
- print *,'enter minimum skewness for OpenDX (between 0. and 0.99):'
- read(5,*) skewness_AVS_DX_min
- if(skewness_AVS_DX_min < 0.d0) skewness_AVS_DX_min = 0.d0
- if(skewness_AVS_DX_min > 0.99999d0) skewness_AVS_DX_min = 0.99999d0
-
-!!!!!!!! print *,'enter maximum skewness for OpenDX (between 0. and 1.):'
-!!!!!!!!!!!!! read(5,*) skewness_AVS_DX_max
- skewness_AVS_DX_max = 0.99999d0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- if(skewness_AVS_DX_max < 0.d0) skewness_AVS_DX_max = 0.d0
- if(skewness_AVS_DX_max > 0.99999d0) skewness_AVS_DX_max = 0.99999d0
-
- if(skewness_AVS_DX_min > skewness_AVS_DX_max) stop 'incorrect skewness range'
-
- else
- print *,'enter the element number to output in OpenDX format between 1 and ',NSPEC
- read(5,*) ispec_to_output
- if(ispec_to_output < 1 .or. ispec_to_output > NSPEC) stop 'incorrect element number to output'
- endif
-
- endif
-
-! read the points
- print *,'NPOIN = ',NPOIN
- do i = 1,NPOIN
- read(10,*) x(i),y(i)
-! the 2D mesh is flat, therefore the third coordinate is zero
- z(i) = 0
- enddo
- close(10)
-
-! read the elements
- print *,'NSPEC = ',NSPEC
- do i = 1,NSPEC
- read(11,*) ibool(1,i),ibool(2,i),ibool(3,i),ibool(4,i)
- enddo
- close(11)
-
- print *,'done reading the external files'
- print *
-
- print *,'start computing the minimum and maximum edge size'
-
-! ************* compute min and max of skewness and ratios ******************
-
-! erase minimum and maximum of quality numbers
- equiangle_skewness_min = + HUGEVAL
- edge_aspect_ratio_min = + HUGEVAL
- diagonal_aspect_ratio_min = + HUGEVAL
- distance_min = + HUGEVAL
-
- equiangle_skewness_max = - HUGEVAL
- edge_aspect_ratio_max = - HUGEVAL
- diagonal_aspect_ratio_max = - HUGEVAL
- distance_max = - HUGEVAL
-
- ispec_min_edge_length = -1
- ispec_max_edge_length = -1
-
-! loop on all the elements
- do ispec = 1,NSPEC
-
- if(mod(ispec,100000) == 0) print *,'processed ',ispec,' elements out of ',NSPEC
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! store element number in which the edge of minimum or maximum length is located
- if(distmin < distance_min) ispec_min_edge_length = ispec
- if(distmax > distance_max) ispec_max_edge_length = ispec
-
-! compute minimum and maximum of quality numbers
- equiangle_skewness_min = min(equiangle_skewness_min,equiangle_skewness)
- edge_aspect_ratio_min = min(edge_aspect_ratio_min,edge_aspect_ratio)
- diagonal_aspect_ratio_min = min(diagonal_aspect_ratio_min,diagonal_aspect_ratio)
- distance_min = min(distance_min,distmin)
-
- if(equiangle_skewness > equiangle_skewness_max) ispec_equiangle_skewness_max = ispec
- equiangle_skewness_max = max(equiangle_skewness_max,equiangle_skewness)
- edge_aspect_ratio_max = max(edge_aspect_ratio_max,edge_aspect_ratio)
- diagonal_aspect_ratio_max = max(diagonal_aspect_ratio_max,diagonal_aspect_ratio)
- distance_max = max(distance_max,distmax)
-
- enddo
- print *,'done processing ',NSPEC,' elements out of ',NSPEC
-
- print *
- print *,'------------'
- print *,'mesh quality parameter definitions:'
- print *
- print *,'equiangle skewness: 0. perfect, 1. bad'
- print *,'skewness max deviation angle: 0. perfect, 90. bad'
- print *,'edge aspect ratio: 1. perfect, above 1. gives stretching factor'
- print *,'diagonal aspect ratio: 1. perfect, above 1. gives stretching factor'
- print *,'------------'
-
- print *
- print *,'minimum length of an edge in the whole mesh (m) = ',distance_min,' in element ',ispec_min_edge_length
- print *
- print *,'maximum length of an edge in the whole mesh (m) = ',distance_max,' in element ',ispec_max_edge_length
- print *
- print *,'max equiangle skewness = ',equiangle_skewness_max
- print *,'in element ',ispec_equiangle_skewness_max
-! print *,'min equiangle skewness = ',equiangle_skewness_min
- print *
- print *,'max deviation angle from a right angle (90 degrees) is therefore = ',90.*equiangle_skewness_max
- print *
- print *,'worst angle in the mesh is therefore either ',90.*(1. - equiangle_skewness_max)
- print *,'or ',180. - 90.*(1. - equiangle_skewness_max),' degrees'
- print *
- print *,'max edge aspect ratio = ',edge_aspect_ratio_max
-! print *,'min edge aspect ratio = ',edge_aspect_ratio_min
- print *
- print *,'max diagonal aspect ratio = ',diagonal_aspect_ratio_max
-! print *,'min diagonal aspect ratio = ',diagonal_aspect_ratio_min
- print *
-
-! create statistics about mesh quality
- print *,'creating histogram and statistics of mesh quality'
-
-! erase histogram of skewness
- classes_skewness(:) = 0
-
-! loop on all the elements
- do ispec = 1,NSPEC
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! store skewness in histogram
- iclass = int(equiangle_skewness * dble(NCLASS))
- if(iclass < 0) iclass = 0
- if(iclass > NCLASS-1) iclass = NCLASS-1
- classes_skewness(iclass) = classes_skewness(iclass) + 1
-
- enddo
-
-! create histogram of skewness and save in Gnuplot file
- print *
- print *,'histogram of skewness (0. good - 1. bad):'
- print *
- total_percent = 0.
- open(unit=14,file='mesh_quality_histogram.txt',status='unknown')
- do iclass = 0,NCLASS-1
- current_percent = 100.*dble(classes_skewness(iclass))/dble(NSPEC)
- total_percent = total_percent + current_percent
- print *,real(iclass/dble(NCLASS)),' - ',real((iclass+1)/dble(NCLASS)),classes_skewness(iclass),' ',sngl(current_percent),' %'
- write(14,*) 0.5*(real(iclass/dble(NCLASS)) + real((iclass+1)/dble(NCLASS))),' ',sngl(current_percent)
- enddo
- close(14)
-
-! create script for Gnuplot histogram file
- open(unit=14,file='plot_mesh_quality_histogram.gnu',status='unknown')
- write(14,*) 'set term x11'
- write(14,*) '#set term gif'
- write(14,*) '#set output "mesh_quality_histogram.gif"'
- write(14,*)
- write(14,*) 'set xrange [0:1]'
- write(14,*) 'set xtics 0,0.1,1'
- write(14,*) 'set boxwidth ',1./real(NCLASS)
- write(14,*) 'set xlabel "Skewness range"'
- write(14,*) 'set ylabel "Percentage of elements (%)"'
- write(14,*) 'plot "mesh_quality_histogram.txt" with boxes'
- write(14,*) 'pause -1 "hit any key..."'
- close(14)
-
- print *
- print *,'total number of elements = ',NSPEC
- print *
-
-! display warning if maximum skewness is too high
- if(equiangle_skewness_max >= 0.75d0) then
- print *
- print *,'*********************************************'
- print *,'*********************************************'
- print *,' WARNING, mesh is bad (max skewness >= 0.75)'
- print *,'*********************************************'
- print *,'*********************************************'
- print *
- endif
-
- if(total_percent < 99.9d0 .or. total_percent > 100.1d0) then
- print *,'total percentage = ',total_percent,' %'
- stop 'total percentage should be 100%'
- endif
-
-! ************* create OpenDX file with elements in a certain range of skewness
-
- if(USE_OPENDX) then
-
- print *
- if(iformat == 1) then
- print *,'creating OpenDX file with subset of elements in skewness range'
- print *,'between ',skewness_AVS_DX_min,' and ',skewness_AVS_DX_max
- else
- print *,'creating OpenDX file with element #',ispec_to_output
- endif
- print *
-
-! ************* count number of elements in skewness range *************
-
-! erase number of elements belonging to skewness range for AVS_DX
- ntotspecAVS_DX = 0
-
-! loop on all the elements
- if(iformat == 1) then
-
- do ispec = 1,NSPEC
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! check if element belongs to requested skewness range
- if(equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max) &
- ntotspecAVS_DX = ntotspecAVS_DX + 1
-
- enddo
-
- else
-! outputing a single element
- ntotspecAVS_DX = 1
- endif
-
- if(ntotspecAVS_DX == 0) then
- stop 'no elements in skewness range, no file created'
- else if(iformat == 1) then
- print *
- print *,'there are ',ntotspecAVS_DX,' elements in AVS or DX skewness range ',skewness_AVS_DX_min,skewness_AVS_DX_max
- print *
- endif
-
- open(unit=11,file='DX_mesh_quality.dx',status='unknown')
-
-! generate the subset of points that are needed
-
-! count the number of unique points
- NPOIN_unique_needed = 0
- allocate(mask_ibool(NPOIN))
- mask_ibool(:) = .false.
-
-! loop on all the elements
- if(iformat == 1) then
- ispec_begin = 1
- ispec_end = NSPEC
- else
- ispec_begin = ispec_to_output
- ispec_end = ispec_to_output
- endif
-
- do ispec = ispec_begin,ispec_end
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! check if element needs to be output
- if(iformat == 2 .or. (iformat == 1 .and. &
- equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
-! create point for first corner of the element
- if(.not. mask_ibool(ibool(1,ispec))) then
- mask_ibool(ibool(1,ispec)) = .true.
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for second corner of the element
- if(.not. mask_ibool(ibool(2,ispec))) then
- mask_ibool(ibool(2,ispec)) = .true.
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for third corner of the element
- if(.not. mask_ibool(ibool(3,ispec))) then
- mask_ibool(ibool(3,ispec)) = .true.
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for fourth corner of the element
- if(.not. mask_ibool(ibool(4,ispec))) then
- mask_ibool(ibool(4,ispec)) = .true.
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
- endif
-
- enddo
-
-
-! ************* generate points ******************
-
-! write OpenDX header
- write(11,*) 'object 1 class array type float rank 1 shape 3 items ',NPOIN_unique_needed,' data follows'
-
- allocate(ibool_reduced(NPOIN))
-
-! count the number of unique points
- NPOIN_unique_needed = 0
- mask_ibool(:) = .false.
-
-! loop on all the elements
- if(iformat == 1) then
- ispec_begin = 1
- ispec_end = NSPEC
- else
- ispec_begin = ispec_to_output
- ispec_end = ispec_to_output
- endif
-
- do ispec = ispec_begin,ispec_end
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! check if element needs to be output
- if(iformat == 2 .or. (iformat == 1 .and. &
- equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
-! create point for first corner of the element
- if(.not. mask_ibool(ibool(1,ispec))) then
- mask_ibool(ibool(1,ispec)) = .true.
- ibool_reduced(ibool(1,ispec)) = NPOIN_unique_needed
- write(11,*) sngl(x(ibool(1,ispec))),sngl(y(ibool(1,ispec))),sngl(z(ibool(1,ispec)))
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for second corner of the element
- if(.not. mask_ibool(ibool(2,ispec))) then
- mask_ibool(ibool(2,ispec)) = .true.
- ibool_reduced(ibool(2,ispec)) = NPOIN_unique_needed
- write(11,*) sngl(x(ibool(2,ispec))),sngl(y(ibool(2,ispec))),sngl(z(ibool(2,ispec)))
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for third corner of the element
- if(.not. mask_ibool(ibool(3,ispec))) then
- mask_ibool(ibool(3,ispec)) = .true.
- ibool_reduced(ibool(3,ispec)) = NPOIN_unique_needed
- write(11,*) sngl(x(ibool(3,ispec))),sngl(y(ibool(3,ispec))),sngl(z(ibool(3,ispec)))
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for fourth corner of the element
- if(.not. mask_ibool(ibool(4,ispec))) then
- mask_ibool(ibool(4,ispec)) = .true.
- ibool_reduced(ibool(4,ispec)) = NPOIN_unique_needed
- write(11,*) sngl(x(ibool(4,ispec))),sngl(y(ibool(4,ispec))),sngl(z(ibool(4,ispec)))
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
- endif
-
- enddo
-
- deallocate(mask_ibool)
-
-! ************* generate elements ******************
-
- write(11,*) 'object 2 class array type int rank 1 shape ',NGNOD,' items ',ntotspecAVS_DX,' data follows'
-
-! loop on all the elements
- if(iformat == 1) then
- ispec_begin = 1
- ispec_end = NSPEC
- else
- ispec_begin = ispec_to_output
- ispec_end = ispec_to_output
- endif
-
- do ispec = ispec_begin,ispec_end
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! check if element needs to be output
- if(iformat == 2 .or. (iformat == 1 .and. &
- equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
-! point order in OpenDX in 2D is 1,4,2,3 *not* 1,2,3,4 as in AVS
-! point order in OpenDX in 3D is 4,1,8,5,3,2,7,6, *not* 1,2,3,4,5,6,7,8 as in AVS
-! in the case of OpenDX, node numbers start at zero
- write(11,"(i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9)") &
- ibool_reduced(ibool(1,ispec)), ibool_reduced(ibool(4,ispec)), &
- ibool_reduced(ibool(2,ispec)), ibool_reduced(ibool(3,ispec))
- if(iformat == 1) print *,'element ',ispec,' belongs to the range and has skewness = ',sngl(equiangle_skewness)
- endif
-
- enddo
-
-! ************* generate element data values ******************
-
-! output OpenDX header for data
- write(11,*) 'attribute "element type" string "quads"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
-
-! loop on all the elements
- do ispec = ispec_begin,ispec_end
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! check if element needs to be output
- if(iformat == 2 .or. (iformat == 1 .and. &
- equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) &
- write(11,*) sngl(equiangle_skewness)
-
- enddo
-
-! define OpenDX field
- write(11,*) 'attribute "dep" string "connections"'
- write(11,*) 'object "irregular positions irregular connections" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
-
-! close OpenDX file
- close(11)
-
- endif
-
- end program check_quality_external_mesh
-
-!
-!=====================================================================
-!
-
-! create mesh quality data for a given 2D spectral element
-
- subroutine create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
- implicit none
-
- include "constants.h"
-
- integer :: icorner,ispec,NSPEC,NPOIN,NGNOD,i
-
- double precision, dimension(NPOIN) :: x,y,z
-
- integer, dimension(NGNOD,NSPEC) :: ibool
-
- double precision, dimension(NGNOD) :: xelm,yelm,zelm
-
- double precision vectorA_x,vectorA_y,vectorA_z
- double precision vectorB_x,vectorB_y,vectorB_z
- double precision norm_A,norm_B,angle_vectors
- double precision distmin,distmax,dist,dist1,dist2
- double precision equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio
-
-! topology of faces of cube for skewness
-! only one face in 2D
- integer faces_topo(6)
-
-! store the corners of this element for the skewness routine
- do i = 1,NGNOD
- xelm(i) = x(ibool(i,ispec))
- yelm(i) = y(ibool(i,ispec))
- zelm(i) = z(ibool(i,ispec))
- enddo
-
-! define topology of faces of cube for skewness
-
-! only one face in 2D
- faces_topo(1) = 1
- faces_topo(2) = 2
- faces_topo(3) = 3
- faces_topo(4) = 4
-
-! define wraparound for angles for skewness calculation
- faces_topo(5) = faces_topo(1)
- faces_topo(6) = faces_topo(2)
-
-! compute equiangle skewness (as defined in Fluent/Gambit manual)
-! and compute edge aspect ratio using the corners of the element
- distmin = + HUGEVAL
- distmax = - HUGEVAL
- equiangle_skewness = - HUGEVAL
-
- do icorner = 1,4
-
-! first vector of angle
- vectorA_x = xelm(faces_topo(icorner)) - xelm(faces_topo(icorner+1))
- vectorA_y = yelm(faces_topo(icorner)) - yelm(faces_topo(icorner+1))
- vectorA_z = zelm(faces_topo(icorner)) - zelm(faces_topo(icorner+1))
-
-! second vector of angle
- vectorB_x = xelm(faces_topo(icorner+2)) - xelm(faces_topo(icorner+1))
- vectorB_y = yelm(faces_topo(icorner+2)) - yelm(faces_topo(icorner+1))
- vectorB_z = zelm(faces_topo(icorner+2)) - zelm(faces_topo(icorner+1))
-
-! norm of vectors A and B
- norm_A = sqrt(vectorA_x**2 + vectorA_y**2 + vectorA_z**2)
- norm_B = sqrt(vectorB_x**2 + vectorB_y**2 + vectorB_z**2)
-
-! angle formed by the two vectors
- angle_vectors = dacos((vectorA_x*vectorB_x + vectorA_y*vectorB_y + vectorA_z*vectorB_z) / (norm_A * norm_B))
-
-! compute equiangle skewness
- equiangle_skewness = max(equiangle_skewness,dabs(2.d0 * angle_vectors - PI) / PI)
-
-! compute min and max size of an edge
- dist = sqrt(vectorA_x**2 + vectorA_y**2 + vectorA_z**2)
-
- distmin = min(distmin,dist)
- distmax = max(distmax,dist)
-
- enddo
-
-! compute edge aspect ratio
- edge_aspect_ratio = distmax / distmin
-
-! compute diagonal aspect ratio
- dist1 = sqrt((xelm(1) - xelm(3))**2 + (yelm(1) - yelm(3))**2 + (zelm(1) - zelm(3))**2)
- dist2 = sqrt((xelm(2) - xelm(4))**2 + (yelm(2) - yelm(4))**2 + (zelm(2) - zelm(4))**2)
- diagonal_aspect_ratio = max(dist1,dist2) / min(dist1,dist2)
-
- end subroutine create_mesh_quality_data_2D
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/check_stability.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/check_stability.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/check_stability.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,305 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine check_stability(myrank,time,it,NSTEP, &
- npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- any_elastic_glob,any_elastic,displ_elastic, &
- any_poroelastic_glob,any_poroelastic, &
- displs_poroelastic,displw_poroelastic, &
- any_acoustic_glob,any_acoustic,potential_acoustic, &
- year_start,month_start,time_start)
-
-! checks simulation stability and outputs timerun infos
-
- implicit none
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: myrank,it,NSTEP
-
- double precision :: time
-
- logical :: any_elastic_glob,any_elastic
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
-
- logical :: any_poroelastic_glob,any_poroelastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
-
- logical :: any_acoustic_glob,any_acoustic
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
-
- double precision :: time_start
- integer :: year_start,month_start
-
- ! local parameters
- double precision displnorm_all,displnorm_all_glob
- ! timer to count elapsed time
- double precision :: time_end
- integer :: year_end,month_end
- double precision :: tCPU,t_remain,t_total
- integer :: ihours,iminutes,iseconds,int_tCPU, &
- ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
- ihours_total,iminutes_total,iseconds_total,int_t_total
- ! to determine date and time at which the run will finish
- character(len=8) datein
- character(len=10) timein
- character(len=5) :: zone
- integer, dimension(8) :: time_values
- character(len=3), dimension(12) :: month_name
- character(len=3), dimension(0:6) :: weekday_name
- data month_name /'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/
- data weekday_name /'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'/
- integer :: year,mon,day,hr,minutes,timestamp,julian_day_number,day_of_week
- integer, external :: idaywk
-#ifdef USE_MPI
- integer :: ier
-#endif
-
- ! user output
- 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
-
-
- ! elastic wavefield
- if(any_elastic_glob) then
- if(any_elastic) then
- displnorm_all = maxval(sqrt(displ_elastic(1,:)**2 &
- + displ_elastic(2,:)**2 &
- + displ_elastic(3,:)**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 solid (elastic) = ',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 (elastic)')
-
- endif
-
- ! poroelastic wavefield
- if(any_poroelastic_glob) then
- if(any_poroelastic) then
- displnorm_all = maxval(sqrt(displs_poroelastic(1,:)**2 &
- + displs_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 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
- ! 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
-
-
- ! acoustic wavefield
- if(any_acoustic_glob) then
- if(any_acoustic) then
- displnorm_all = maxval(abs(potential_acoustic(:)))
- 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 absolute value of scalar field in fluid (acoustic) = ',displnorm_all_glob
-
- ! check stability of the code in fluid, exit if unstable
- ! negative values can occur with some compilers when the unstable value is greater
- ! than the greatest possible floating-point number of the machine
- if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
- call exit_MPI('code became unstable and blew up in fluid (acoustic)')
-
- endif
-
- ! count elapsed wall-clock time
- call date_and_time(datein,timein,zone,time_values)
- ! time_values(1): year
- ! time_values(2): month of the year
- ! time_values(3): day of the month
- ! time_values(5): hour of the day
- ! time_values(6): minutes of the hour
- ! time_values(7): seconds of the minute
- ! time_values(8): milliseconds of the second
- ! this fails if we cross the end of the month
- time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
- 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
- month_end = time_values(2)
- year_end = time_values(1)
-
- ! elapsed time since beginning of the simulation
- if (myrank == 0) then
- if(month_end == month_start .and. year_end == year_start) then
- tCPU = time_end - time_start
- int_tCPU = int(tCPU)
- ihours = int_tCPU / 3600
- iminutes = (int_tCPU - 3600*ihours) / 60
- iseconds = int_tCPU - 3600*ihours - 60*iminutes
- 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)
-
- ! compute estimated remaining simulation time
- t_remain = (NSTEP - it) * (tCPU/dble(it))
- int_t_remain = int(t_remain)
- ihours_remain = int_t_remain / 3600
- iminutes_remain = (int_t_remain - 3600*ihours_remain) / 60
- iseconds_remain = int_t_remain - 3600*ihours_remain - 60*iminutes_remain
- write(IOUT,*) 'Time steps remaining = ',NSTEP - it
- write(IOUT,*) 'Estimated remaining time in seconds = ',t_remain
- write(IOUT,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- ihours_remain,iminutes_remain,iseconds_remain
-
- ! compute estimated total simulation time
- t_total = t_remain + tCPU
- int_t_total = int(t_total)
- ihours_total = int_t_total / 3600
- iminutes_total = (int_t_total - 3600*ihours_total) / 60
- iseconds_total = int_t_total - 3600*ihours_total - 60*iminutes_total
- write(IOUT,*) 'Estimated total run time in seconds = ',t_total
- write(IOUT,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- ihours_total,iminutes_total,iseconds_total
-
- if(it < NSTEP) then
- ! compute date and time at which the run should finish
- ! (useful for long runs); for simplicity only minutes
- ! are considered, seconds are ignored; in any case the prediction is not
- ! accurate down to seconds because of system and network fluctuations
- year = time_values(1)
- mon = time_values(2)
- day = time_values(3)
- hr = time_values(5)
- minutes = time_values(6)
-
- ! get timestamp in minutes of current date and time
- call convtime(timestamp,year,mon,day,hr,minutes)
-
- ! add remaining minutes
- timestamp = timestamp + nint(t_remain / 60.d0)
-
- ! get date and time of that future timestamp in minutes
- call invtime(timestamp,year,mon,day,hr,minutes)
-
- ! convert to Julian day to get day of the week
- call calndr(day,mon,year,julian_day_number)
- day_of_week = idaywk(julian_day_number)
-
- write(IOUT,"(' The run will finish approximately on: ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
- weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
-
- endif
- write(IOUT,*)
- else
- write(IOUT,*) 'The calendar has crossed the end of the month during the simulation,'
- write(IOUT,*) 'cannot produce accurate CPU time estimates any more.'
- write(IOUT,*)
- endif
- endif
-
- if (myrank == 0) write(IOUT,*)
-
- end subroutine check_stability
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/checkgrid.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/checkgrid.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/checkgrid.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,3102 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine checkgrid(vpext,vsext,rhoext,density,poroelastcoef, &
- porosity,tortuosity,permeability,ibool,kmato, &
- coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
- assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat, &
- f0,initialfield,time_function_type, &
- coorg,xinterp,zinterp,shapeint,knods,simulation_title, &
- npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,all_anisotropic, &
- myrank,nproc,NSOURCES,poroelastic, &
- freq0,Q0,TURN_VISCATTENUATION_ON)
-
-! check the mesh, stability and number of points per wavelength
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- 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
-
- integer :: npoin,nspec,numat
- 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(3,numat) :: permeability
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
-
- double precision coord(NDIM,npoin)
-
- integer :: NSOURCES
- integer, dimension(NSOURCES) :: time_function_type
- double precision, dimension(NSOURCES) :: f0
-
- integer :: pointsdisp,npgeo,ngnod
-
- integer :: knods(ngnod,nspec)
-
- double precision :: xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
- double precision :: shapeint(ngnod,pointsdisp,pointsdisp)
-
- double precision :: coorg(NDIM,npgeo)
-
-! title of the plot
- character(len=60) :: simulation_title
-
- double precision :: vpImin,vpImax
- double precision :: vpIImin,vpIImax
- double precision :: deltat
-
- logical :: assign_external_model,initialfield,any_elastic,any_poroelastic,all_anisotropic, &
- TURN_VISCATTENUATION_ON
-
- integer :: myrank,nproc
-
- ! local parameters
- double precision vpIImax_local,vpIImin_local
- double precision vsmin,vsmax,densmin,densmax,vpImax_local,vpImin_local,vsmin_local
- double precision kappa_s,kappa_f,kappa_fr,mu_s,mu_fr,denst_s,denst_f,denst,phi,tort,cpIloc,cpIIloc,csloc
- double precision D_biot,H_biot,C_biot,M_biot,cpIsquare,cpIIsquare,cssquare
- double precision f0min,f0max,freq0,Q0,w_c,eta_f,perm
- double precision lambdaplus2mu,mu
- double precision distance_min,distance_max,distance_min_local,distance_max_local
- double precision courant_stability_number_max,lambdaPImin,lambdaPImax,lambdaPIImin,lambdaPIImax, &
- lambdaSmin,lambdaSmax
- double precision distance_1,distance_2,distance_3,distance_4
-
-! for the stability condition
-! maximum polynomial degree for which we can compute the stability condition
- integer, parameter :: NGLLX_MAX_STABILITY = 15
- double precision :: percent_GLL(NGLLX_MAX_STABILITY)
-
-! color palette
- integer, parameter :: NUM_COLORS = 236
- double precision, dimension(NUM_COLORS) :: red,green,blue
-
- double precision :: xmax,zmax,height,usoffset,sizex,sizez,courant_stability_number
- double precision :: x1,z1,x2,z2,ratio_page,xmin,zmin,lambdaS_local,lambdaPI_local
-
-#ifdef USE_MPI
- integer :: icol
- double precision :: vpImin_glob,vpImax_glob,vsmin_glob,vsmax_glob,densmin_glob,densmax_glob
- double precision :: vpIImin_glob,vpIImax_glob
- double precision :: distance_min_glob,distance_max_glob
- double precision :: courant_stability_max_glob,lambdaPImin_glob,lambdaPImax_glob,&
- lambdaPIImin_glob,lambdaPIImax_glob,lambdaSmin_glob,lambdaSmax_glob
- double precision :: xmin_glob, xmax_glob, zmin_glob, zmax_glob
-#endif
-
- logical :: any_elastic_glob,any_poroelastic_glob
- double precision, dimension(2,nspec*5) :: coorg_send
- double precision, dimension(:,:), allocatable :: coorg_recv
- integer, dimension(nspec) :: RGB_send
- integer, dimension(:), allocatable :: RGB_recv
- real, dimension(nspec) :: greyscale_send
- real, dimension(:), allocatable :: greyscale_recv
- integer :: nspec_recv
- integer :: num_ispec
- integer :: iproc
- integer :: ier
- integer :: i,j,ispec,material
- integer :: is,ir,in,nnum
-
-#ifdef USE_MPI
- integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
-#endif
-
- ! check
- if(UPPER_LIMIT_DISPLAY > nspec) &
- call exit_MPI('cannot have UPPER_LIMIT_DISPLAY > nspec in checkgrid.F90')
-
-#ifndef USE_MPI
- allocate(coorg_recv(1,1))
- allocate(RGB_recv(1))
- allocate(greyscale_recv(1))
- nspec_recv = 0
- ier = 0
- iproc = nproc
- deallocate(coorg_recv)
- deallocate(RGB_recv)
- 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
- call checkgrid_setup_GLLper(percent_GLL,NGLLX_MAX_STABILITY)
-
-! define color palette in random order
- call checkgrid_setup_colorp(red,green,blue,NUM_COLORS)
-
-!---- compute parameters for the spectral elements
-
- vpImin = HUGEVAL
- vpImax = -HUGEVAL
-
- if(any_elastic .or. any_poroelastic) then
- vsmin = HUGEVAL
- vsmax = -HUGEVAL
- else
- vsmin = 0
- vsmax = 0
- endif
-
- if(any_poroelastic) then
- vpIImin = HUGEVAL
- vpIImax = -HUGEVAL
- else
- vpIImin = 0
- vpIImax = 0
- endif
-
- densmin = HUGEVAL
- densmax = -HUGEVAL
-
- distance_min = HUGEVAL
- distance_max = -HUGEVAL
-
- courant_stability_number_max = -HUGEVAL
-
- lambdaPImin = HUGEVAL
- lambdaPImax = -HUGEVAL
-
- if(any_elastic .or. any_poroelastic) then
- lambdaSmin = HUGEVAL
- lambdaSmax = -HUGEVAL
- else
- lambdaSmin = 0
- lambdaSmax = 0
- endif
-
- if(any_poroelastic) then
- lambdaPIImin = HUGEVAL
- lambdaPIImax = -HUGEVAL
- else
- lambdaPIImin = 0
- lambdaPIImax = 0
- endif
-
- do ispec=1,nspec
-
- material = kmato(ispec)
-
- if(poroelastic(ispec)) then
-
- ! poroelastic material
-
- phi = porosity(material)
- tort = tortuosity(material)
- perm = permeability(1,material)
- ! solid properties
- mu_s = poroelastcoef(2,1,material)
- kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
- denst_s = density(1,material)
- denst = denst_s
- ! fluid properties
- kappa_f = poroelastcoef(1,2,material)
- denst_f = density(2,material)
- eta_f = poroelastcoef(2,2,material)
- ! frame properties
- mu_fr = poroelastcoef(2,3,material)
- kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
- ! 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)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
- tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIloc = sqrt(cpIsquare)
- cpIIloc = sqrt(cpIIsquare)
- csloc = sqrt(cssquare)
- else
- mu = poroelastcoef(2,1,material)
- lambdaplus2mu = poroelastcoef(3,1,material)
- denst = density(1,material)
-
- cpIloc = sqrt(lambdaplus2mu/denst)
- cpIIloc = 0.d0
- csloc = sqrt(mu/denst)
- endif
-
- vpImax_local = -HUGEVAL
- vpImin_local = HUGEVAL
- vpIImax_local = -HUGEVAL
- vpIImin_local = HUGEVAL
- vsmin_local = HUGEVAL
-
- distance_min_local = HUGEVAL
- distance_max_local = -HUGEVAL
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
-!--- if heterogeneous formulation with external velocity model
- if(assign_external_model) then
- cpIloc = vpext(i,j,ispec)
- csloc = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- endif
-
-!--- compute min and max of velocity and density models
- vpImin = min(vpImin,cpIloc)
- vpImax = max(vpImax,cpIloc)
-
-! ignore acoustic and elastic regions with cpII = 0
- if(cpIIloc > 0.0001d0) vpIImin = min(vpIImin,cpIIloc)
- vpIImax = max(vpIImax,cpIIloc)
-
-! ignore fluid regions with Vs = 0
- if(csloc > 0.0001d0) vsmin = min(vsmin,csloc)
- vsmax = max(vsmax,csloc)
-
- densmin = min(densmin,denst)
- densmax = max(densmax,denst)
-
- vpImax_local = max(vpImax_local,vpImax)
- vpImin_local = min(vpImin_local,vpImin)
- vpIImax_local = max(vpIImax_local,vpIImax)
- vpIImin_local = min(vpIImin_local,vpIImin)
- vsmin_local = min(vsmin_local,vsmin)
-
- enddo
- enddo
-
-! compute minimum and maximum size of edges of this grid cell
- distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
- (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
-
- distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
-
- distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
-
- distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
- (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
-
- distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
- distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
-
- distance_min = min(distance_min,distance_min_local)
- distance_max = max(distance_max,distance_max_local)
-
- courant_stability_number_max = max(courant_stability_number_max, &
- vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX)))
-
-! ignore fluid regions with Vs = 0
- 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
-
- lambdaPImin = min(lambdaPImin,vpImin_local / (distance_max_local / (NGLLX - 1)))
- lambdaPImax = max(lambdaPImax,vpImin_local / (distance_max_local / (NGLLX - 1)))
-
- if(cpIIloc > 0.0001d0) then
- lambdaPIImin = min(lambdaPIImin,vpIImin_local / (distance_max_local / (NGLLX - 1)))
- lambdaPIImax = max(lambdaPIImax,vpIImin_local / (distance_max_local / (NGLLX - 1)))
- endif
-
- enddo
-
- any_elastic_glob = any_elastic
- any_poroelastic_glob = any_poroelastic
-#ifdef USE_MPI
- call MPI_ALLREDUCE (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 (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)
- call MPI_ALLREDUCE (densmax, densmax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (distance_min, distance_min_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (distance_max, distance_max_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (courant_stability_number_max, courant_stability_max_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPImin, lambdaPImin_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPImax, lambdaPImax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPIImin, lambdaPIImin_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPIImax, lambdaPIImax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaSmin, lambdaSmin_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaSmax, lambdaSmax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (any_elastic, any_elastic_glob, 1, MPI_LOGICAL, &
- MPI_LOR, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, &
- MPI_LOR, MPI_COMM_WORLD, ier)
- vpImin = vpImin_glob
- vpImax = vpImax_glob
- vpIImin = vpIImin_glob
- vpIImax = vpIImax_glob
- vsmin = vsmin_glob
- vsmax = vsmax_glob
- densmin = densmin_glob
- densmax = densmax_glob
- distance_min = distance_min_glob
- distance_max = distance_max_glob
- courant_stability_number_max = courant_stability_max_glob
- lambdaPImin = lambdaPImin_glob
- lambdaPImax = lambdaPImax_glob
- lambdaPIImin = lambdaPIImin_glob
- lambdaPIImax = lambdaPIImax_glob
- lambdaSmin = lambdaSmin_glob
- lambdaSmax = lambdaSmax_glob
-
-#endif
-
- if ( myrank == 0 ) then
- if(.not. all_anisotropic) then
- write(IOUT,*)
- write(IOUT,*) '********'
- 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
- write(IOUT,*) '********'
- write(IOUT,*)
-
- write(IOUT,*)
- write(IOUT,*) '*********************************************'
- write(IOUT,*) '*** Verification of simulation parameters ***'
- write(IOUT,*) '*********************************************'
- write(IOUT,*)
- write(IOUT,*) '*** Max grid size = ',distance_max
- write(IOUT,*) '*** Min grid size = ',distance_min
- write(IOUT,*) '*** Max/min ratio = ',distance_max/distance_min
- write(IOUT,*)
- write(IOUT,*) '*** Max stability for P wave velocity = ',courant_stability_number_max
- write(IOUT,*)
- end if
-
-! 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) then
- f0max = -HUGEVAL
- f0min = HUGEVAL
-! write(IOUT,*) ' USER_T0 = ',USER_T0
-
- do i = 1,NSOURCES
-
- ! excludes Dirac and Heaviside sources
- if(time_function_type(i) /= 4 .and. time_function_type(i) /= 5) then
-! write(IOUT,*) ' Onset time = ',t0+tshift_src(i)
-! write(IOUT,*) ' Fundamental period = ',1.d0/f0(i)
-! write(IOUT,*) ' Fundamental frequency = ',f0(i)
-! ! checks source onset time
-! if( t0+tshift_src(i) <= 1.d0/f0(i)) then
-! call exit_MPI('Onset time too small')
-! else
-! write(IOUT,*) ' --> onset time ok'
-! endif
-
- ! sets min/max frequency
- if(f0(i) > f0max) f0max = f0(i)
- if(f0(i) < f0min) f0min = f0(i)
-
- if( i == NSOURCES ) then
- write(IOUT,*) '----'
- 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*f0min)
- write(IOUT,*) ' Nb pts / lambdaPIImin_fmax min = ',lambdaPIImin/(2.5d0*f0max)
- write(IOUT,*) '----'
- 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
-
-!
-!--------------------------------------------------------------------------------
-!
-
-! A4 or US letter paper
- if(US_LETTER) then
- usoffset = 1.75d0
- sizex = 27.94d0
- sizez = 21.59d0
- else
- usoffset = 0.d0
- sizex = 29.7d0
- sizez = 21.d0
- endif
-
-! height of domain numbers in centimeters
- height = 0.25d0
-
-! get minimum and maximum values of mesh coordinates
- xmin = minval(coord(1,:))
- zmin = minval(coord(2,:))
- xmax = maxval(coord(1,:))
- zmax = maxval(coord(2,:))
-
-#ifdef USE_MPI
- call MPI_ALLREDUCE (xmin, xmin_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 (zmin, zmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (zmax, zmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- xmin = xmin_glob
- xmax = xmax_glob
- zmin = zmin_glob
- zmax = zmax_glob
-
-#endif
-
-! ratio of physical page size/size of the domain meshed
- ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
-
-
- if (myrank == 0) then
-
- write(IOUT,*)
- write(IOUT,*) 'Creating PostScript file with stability condition'
-
-!
-!---- open PostScript file
-!
- open(unit=24,file='OUTPUT_FILES/mesh_stability.ps',status='unknown')
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- write(24,*) '%'
- write(24,*) '/vshift ',-height/2,' CM def'
- write(24,*) '/Rshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop neg vshift MR show } def'
- write(24,*) '/Cshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
- write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
- !
- !--- write captions of PostScript figure
- !
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- write(24,*) '.4 .9 .9 setrgbcolor'
- write(24,*) '11 CM 1.1 CM MV'
- write(24,*) '(X axis) show'
- write(24,*) '%'
- write(24,*) '1.4 CM 9.5 CM MV'
- write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
- write(24,*) '(Z axis) show'
- write(24,*) 'grestore'
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.7 CM scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- 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,*) 'grestore'
- write(24,*) '25.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,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 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,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
- !
- !---- draw the spectral element mesh
- !
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- num_ispec = 0
- endif
-
- do ispec = 1, nspec
- if ( myrank == 0 ) then
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- endif
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- if ( myrank == 0 ) then
- write(24,*) 'mark'
- write(24,681) x1,z1
- else
- coorg_send(1,(ispec-1)*5+1) = x1
- coorg_send(2,(ispec-1)*5+1) = z1
- endif
-
- ! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+2) = x2
- coorg_send(2,(ispec-1)*5+2) = z2
- endif
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+3) = x2
- coorg_send(2,(ispec-1)*5+3) = z2
- endif
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+4) = x2
- coorg_send(2,(ispec-1)*5+4) = z2
- endif
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- write(24,*) 'CO'
- else
- coorg_send(1,(ispec-1)*5+5) = x2
- coorg_send(2,(ispec-1)*5+5) = z2
- endif
-
- material = kmato(ispec)
-
- if(poroelastic(ispec)) then
-
- ! poroelastic material
-
- phi=porosity(material)
- tort=tortuosity(material)
- perm=permeability(1,material)
- ! solid properties
- mu_s = poroelastcoef(2,1,material)
- kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
- denst_s = density(1,material)
- denst = denst_s
- ! fluid properties
- kappa_f = poroelastcoef(1,2,material)
- denst_f = density(2,material)
- eta_f = poroelastcoef(2,2,material)
- ! frame properties
- mu_fr = poroelastcoef(2,3,material)
- kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
- ! 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)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
- tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- 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
- distance_max_local = -HUGEVAL
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
- !--- if heterogeneous formulation with external velocity model
- if(assign_external_model) then
- cpIloc = vpext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- endif
-
- vpImax_local = max(vpImax_local,cpIloc)
-
- enddo
- enddo
-
-! compute minimum and maximum size of edges of this grid cell
- distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
- (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
-
- distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
-
- distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
-
- distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
- (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
-
- distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
- distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
-
- distance_min = min(distance_min,distance_min_local)
- distance_max = max(distance_max,distance_max_local)
-
- courant_stability_number = vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX))
-
-! display bad elements that are above 80% of the threshold
- if(courant_stability_number >= 0.80 * courant_stability_number_max) then
- if ( myrank == 0 ) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- else
- RGB_send(ispec) = 1
- endif
- else
-! do not color the elements if below the threshold
- if ( myrank == 0 ) then
- write(24,*) 'ST'
- else
- RGB_send(ispec) = 0
- endif
- endif
-
- enddo ! end of loop on all the spectral elements
-
-#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*5))
- allocate(RGB_recv(nspec_recv))
- call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (RGB_recv(1), nspec_recv, MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- do ispec = 1, nspec_recv
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- write(24,*) 'mark'
- write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
- write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
- write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
- write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
- write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
- write(24,*) 'CO'
- if ( RGB_recv(ispec) == 1) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- else
- write(24,*) 'ST'
- endif
- enddo
- deallocate(coorg_recv)
- deallocate(RGB_recv)
-
- 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)
- endif
-
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- write(IOUT,*) 'End of creation of PostScript file with stability condition'
- endif
-
-!
-!--------------------------------------------------------------------------------
-!
-
- if (myrank == 0) then
-
- write(IOUT,*)
- write(IOUT,*) 'Creating PostScript file with mesh dispersion'
-
-!
-!---- open PostScript file
-!
- 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')
- endif
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- write(24,*) '%'
- write(24,*) '/vshift ',-height/2,' CM def'
- write(24,*) '/Rshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop neg vshift MR show } def'
- write(24,*) '/Cshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
- write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- write(24,*) '.4 .9 .9 setrgbcolor'
- write(24,*) '11 CM 1.1 CM MV'
- write(24,*) '(X axis) show'
- write(24,*) '%'
- write(24,*) '1.4 CM 9.5 CM MV'
- write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
- write(24,*) '(Z axis) show'
- write(24,*) 'grestore'
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.7 CM scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- 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'
- if(any_elastic_glob) then
- write(24,*) '(Mesh elastic S-wave dispersion \(red = good, blue = bad\)) show'
- else
- write(24,*) '(Mesh acoustic P-wave dispersion \(red = good, blue = bad\)) show'
- endif
- write(24,*) 'grestore'
- write(24,*) '25.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,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 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,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- draw the spectral element mesh
-!
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- num_ispec = 0
- endif
-
- do ispec = 1, nspec
- if ( myrank == 0 ) then
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- endif
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- if ( myrank == 0 ) then
- write(24,*) 'mark'
- write(24,681) x1,z1
- else
- coorg_send(1,(ispec-1)*5+1) = x1
- coorg_send(2,(ispec-1)*5+1) = z1
- endif
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+2) = x2
- coorg_send(2,(ispec-1)*5+2) = z2
- endif
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+3) = x2
- coorg_send(2,(ispec-1)*5+3) = z2
- endif
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+4) = x2
- coorg_send(2,(ispec-1)*5+4) = z2
- endif
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- write(24,*) 'CO'
- else
- coorg_send(1,(ispec-1)*5+5) = x2
- coorg_send(2,(ispec-1)*5+5) = z2
- endif
-
- material = kmato(ispec)
-
- if(poroelastic(ispec)) then
- phi = porosity(material)
- tort = tortuosity(material)
- perm = permeability(1,material)
-!solid properties
- mu_s = poroelastcoef(2,1,material)
- kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
- denst_s = density(1,material)
- denst = denst_s
-!fluid properties
- kappa_f = poroelastcoef(1,2,material)
- denst_f = density(2,material)
- eta_f = poroelastcoef(2,2,material)
-!frame properties
- mu_fr = poroelastcoef(2,3,material)
- kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
-!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)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
- tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIloc = sqrt(cpIsquare)
- csloc = sqrt(cssquare)
- else
- mu = poroelastcoef(2,1,material)
- lambdaplus2mu = poroelastcoef(3,1,material)
- denst = density(1,material)
-
- cpIloc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
- endif
-
- vpImax_local = -HUGEVAL
- vpImin_local = HUGEVAL
- vsmin_local = HUGEVAL
-
- distance_min_local = HUGEVAL
- distance_max_local = -HUGEVAL
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
-!--- if heterogeneous formulation with external velocity model
- if(assign_external_model) then
- cpIloc = vpext(i,j,ispec)
- csloc = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- endif
-
- vpImax_local = max(vpImax_local,cpIloc)
- vpImin_local = min(vpImin_local,cpIloc)
- vsmin_local = min(vsmin_local,csloc)
-
- enddo
- enddo
-
-! compute minimum and maximum size of edges of this grid cell
- distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
- (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
-
- distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
-
- distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
-
- distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
- (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
-
- distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
- distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
-
- distance_min = min(distance_min,distance_min_local)
- distance_max = max(distance_max,distance_max_local)
-
-! display mesh dispersion for S waves if there is at least one elastic element in the mesh
- if(any_elastic_glob .or. any_poroelastic_glob) then
-
-! ignore fluid regions with Vs = 0
- if(csloc > 0.0001d0) then
-
- lambdaS_local = vsmin_local / (distance_max_local / (NGLLX - 1))
-
-! display very good elements that are above 80% of the threshold in red
- if(lambdaS_local >= 0.80 * lambdaSmax) then
- if ( myrank == 0 ) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- else
- RGB_send(ispec) = 1
- endif
-
-! display bad elements that are below 120% of the threshold in blue
- else if(lambdaS_local <= 1.20 * lambdaSmin) then
- if ( myrank == 0 ) then
- write(24,*) '0 0 1 RG GF 0 setgray ST'
- else
- RGB_send(ispec) = 3
- endif
-
- else
-! do not color the elements if not close to the threshold
- if ( myrank == 0 ) then
- write(24,*) 'ST'
- else
- RGB_send(ispec) = 0
- endif
- endif
-
- else
-! do not color the elements if S-wave velocity undefined
- if ( myrank == 0 ) then
- write(24,*) 'ST'
- else
- RGB_send(ispec) = 0
- endif
- endif
-
-! 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))
-
-! display very good elements that are above 80% of the threshold in red
- if(lambdaPI_local >= 0.80 * lambdaPImax) then
- if ( myrank == 0 ) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- else
- RGB_send(ispec) = 1
- endif
-
-! display bad elements that are below 120% of the threshold in blue
- else if(lambdaPI_local <= 1.20 * lambdaPImin) then
- if ( myrank == 0 ) then
- write(24,*) '0 0 1 RG GF 0 setgray ST'
- else
- RGB_send(ispec) = 3
- endif
-
- else
-! do not color the elements if not close to the threshold
- if ( myrank == 0 ) then
- write(24,*) 'ST'
- else
- RGB_send(ispec) = 0
- endif
- endif
-
- endif
-
- enddo ! end of loop on all the spectral elements
-
-#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*5))
- allocate(RGB_recv(nspec_recv))
- call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (RGB_recv(1), nspec_recv, MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- do ispec = 1, nspec_recv
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- write(24,*) 'mark'
- write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
- write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
- write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
- write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
- write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
- write(24,*) 'CO'
- if ( RGB_recv(ispec) == 1) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- endif
- if ( RGB_recv(ispec) == 3) then
- write(24,*) '0 0 1 RG GF 0 setgray ST'
- endif
- if ( RGB_recv(ispec) == 0) then
- write(24,*) 'ST'
- endif
-
- enddo
- deallocate(coorg_recv)
- deallocate(RGB_recv)
-
- 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)
-
- endif
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- write(IOUT,*) 'End of creation of PostScript file with mesh dispersion'
-
- endif
-
-!
-!--------------------------------------------------------------------------------
-!
-
- if (myrank == 0) then
-
- write(IOUT,*)
- write(IOUT,*) 'Creating PostScript file with velocity model'
-
-!
-!---- open PostScript file
-!
- open(unit=24,file='OUTPUT_FILES/P_velocity_model.ps',status='unknown')
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- write(24,*) '%'
- write(24,*) '/vshift ',-height/2,' CM def'
- write(24,*) '/Rshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop neg vshift MR show } def'
- write(24,*) '/Cshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
- write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- write(24,*) '.4 .9 .9 setrgbcolor'
- write(24,*) '11 CM 1.1 CM MV'
- write(24,*) '(X axis) show'
- write(24,*) '%'
- write(24,*) '1.4 CM 9.5 CM MV'
- write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
- write(24,*) '(Z axis) show'
- write(24,*) 'grestore'
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.7 CM scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- 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,*) '(P-velocity model \(dark = fast, light = slow\)) show'
- write(24,*) 'grestore'
- write(24,*) '25.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,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 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,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- draw the spectral element mesh
-!
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- num_ispec = 0
-endif
-
- do ispec = 1, UPPER_LIMIT_DISPLAY
- if ( myrank == 0 ) then
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- endif
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- if ( myrank == 0 ) then
- write(24,*) 'mark'
- write(24,681) x1,z1
- else
- coorg_send(1,(ispec-1)*5+1) = x1
- coorg_send(2,(ispec-1)*5+1) = z1
- endif
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+2) = x2
- coorg_send(2,(ispec-1)*5+2) = z2
- endif
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+3) = x2
- coorg_send(2,(ispec-1)*5+3) = z2
- endif
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+4) = x2
- coorg_send(2,(ispec-1)*5+4) = z2
- endif
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- write(24,*) 'CO'
- else
- coorg_send(1,(ispec-1)*5+5) = x2
- coorg_send(2,(ispec-1)*5+5) = z2
- endif
-
- if((vpImax-vpImin)/vpImin > 0.02d0) then
- if(assign_external_model) then
-! use lower-left corner
- x1 = (vpext(1,1,ispec)-vpImin) / (vpImax-vpImin)
- else
- material = kmato(ispec)
- if(poroelastic(ispec)) then
- phi = porosity(material)
- tort = tortuosity(material)
- perm = permeability(1,material)
-!solid properties
- mu_s = poroelastcoef(2,1,material)
- kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
- denst_s = density(1,material)
-!fluid properties
- kappa_f = poroelastcoef(1,2,material)
- denst_f = density(2,material)
- eta_f = poroelastcoef(2,2,material)
-!frame properties
- mu_fr = poroelastcoef(2,3,material)
- kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
-!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)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
- tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIloc = sqrt(cpIsquare)
- else
- lambdaplus2mu = poroelastcoef(3,1,material)
- denst = density(1,material)
- cpIloc = sqrt(lambdaplus2mu/denst)
- endif
- x1 = (cpIloc-vpImin)/(vpImax-vpImin)
- endif
- else
- x1 = 0.5d0
- endif
-
-! rescale to avoid very dark gray levels
- x1 = x1*0.7 + 0.2
- if(x1 > 1.d0) x1=1.d0
-
-! invert scale: white = vpmin, dark gray = vpmax
- x1 = 1.d0 - x1
-
-! display P-velocity model using gray levels
- if ( myrank == 0 ) then
- write(24,*) sngl(x1),' setgray GF 0 setgray ST'
- else
- greyscale_send(ispec) = sngl(x1)
- endif
- enddo ! end of loop on all the spectral elements
-
-#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*5))
- allocate(greyscale_recv(nspec_recv))
- call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (greyscale_recv(1), nspec_recv, MPI_REAL, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- do ispec = 1, nspec_recv
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- write(24,*) 'mark'
- write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
- write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
- write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
- write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
- write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
- write(24,*) 'CO'
- write(24,*) greyscale_recv(ispec), ' setgray GF 0 setgray ST'
-
- enddo
- deallocate(coorg_recv)
- deallocate(greyscale_recv)
-
- enddo
-
- else
- 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
-
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- write(IOUT,*) 'End of creation of PostScript file with velocity model'
-
- endif
-
- if (myrank == 0) then
-
- write(IOUT,*)
- write(IOUT,*) 'Creating PostScript file with mesh partitioning'
-
-!
-!---- open PostScript file
-!
- open(unit=24,file='OUTPUT_FILES/mesh_partitioning.ps',status='unknown')
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- write(24,*) '%'
- write(24,*) '/vshift ',-height/2,' CM def'
- write(24,*) '/Rshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop neg vshift MR show } def'
- write(24,*) '/Cshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
- write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- write(24,*) '.4 .9 .9 setrgbcolor'
- write(24,*) '11 CM 1.1 CM MV'
- write(24,*) '(X axis) show'
- write(24,*) '%'
- write(24,*) '1.4 CM 9.5 CM MV'
- write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
- write(24,*) '(Z axis) show'
- write(24,*) 'grestore'
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.7 CM scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- write(24,*) '24.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(Mesh partitioning) show'
- write(24,*) 'grestore'
- write(24,*) '25.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,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 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,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- draw the spectral element mesh
-!
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- num_ispec = 0
- endif
-
- do ispec = 1, UPPER_LIMIT_DISPLAY
-
- if ( myrank == 0 ) then
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- endif
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- if ( myrank == 0 ) then
- write(24,*) 'mark'
- write(24,681) x1,z1
- else
- coorg_send(1,(ispec-1)*5+1) = x1
- coorg_send(2,(ispec-1)*5+1) = z1
- endif
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+2) = x2
- coorg_send(2,(ispec-1)*5+2) = z2
- endif
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+3) = x2
- coorg_send(2,(ispec-1)*5+3) = z2
- endif
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+4) = x2
- coorg_send(2,(ispec-1)*5+4) = z2
- endif
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- write(24,*) 'CO'
- else
- coorg_send(1,(ispec-1)*5+5) = x2
- coorg_send(2,(ispec-1)*5+5) = z2
- endif
-
- if ( myrank == 0 ) then
- write(24,*) red(1), green(1), blue(1), 'RG GF 0 setgray ST'
- endif
-
- enddo ! end of loop on all the spectral elements
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
-
-! use a different color for each material set
- icol = mod(iproc, NUM_COLORS) + 1
-
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- allocate(coorg_recv(2,nspec_recv*5))
- call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- do ispec = 1, nspec_recv
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- write(24,*) 'mark'
- write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
- write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
- write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
- write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
- write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
- write(24,*) 'CO'
-
- write(24,*) red(icol), green(icol), blue(icol), ' RG GF 0 setgray ST'
-
- enddo
- deallocate(coorg_recv)
-
- enddo
-
- else
- 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)
-
- endif
-#endif
-
- if (myrank == 0) then
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- write(IOUT,*) 'End of creation of PostScript file with partitioning'
- write(IOUT,*)
- endif
-
- 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a100,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
-
- 681 format(f6.2,1x,f6.2)
-
- end subroutine checkgrid
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine checkgrid_setup_GLLper(percent_GLL,NGLLX_MAX_STABILITY)
-
- implicit none
- include "constants.h"
-
- integer :: NGLLX_MAX_STABILITY
- double precision :: percent_GLL(NGLLX_MAX_STABILITY)
-
- if( NGLLX_MAX_STABILITY /= 15 ) call exit_MPI('check NGLLX_MAX_STABILITY in checkgrid.f90')
-
-! 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
- percent_GLL(3) = 50.d0
- percent_GLL(4) = 27.639320225002102d0
- percent_GLL(5) = 17.267316464601141d0
- percent_GLL(6) = 11.747233803526763d0
- percent_GLL(7) = 8.4888051860716516d0
- percent_GLL(8) = 6.4129925745196719d0
- percent_GLL(9) = 5.0121002294269914d0
- percent_GLL(10) = 4.0233045916770571d0
- percent_GLL(11) = 3.2999284795970416d0
- percent_GLL(12) = 2.7550363888558858d0
- percent_GLL(13) = 2.3345076678918053d0
- percent_GLL(14) = 2.0032477366369594d0
- percent_GLL(15) = 1.7377036748080721d0
-
-! convert to real percentage
- percent_GLL(:) = percent_GLL(:) / 100.d0
-
- if(NGLLX > NGLLX_MAX_STABILITY) then
- call exit_MPI('cannot estimate the stability condition for that degree')
- endif
-
- end subroutine checkgrid_setup_GLLper
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine checkgrid_setup_colorp(red,green,blue,NUM_COLORS)
-
-! color palette
-
- implicit none
- integer :: NUM_COLORS
- double precision, dimension(NUM_COLORS) :: red,green,blue
-
- if( NUM_COLORS /= 236 ) call exit_MPI('check NUM_COLORS in checkgrid.f90')
-
-! red
- red(1) = 1.00000000000000
- green(1) = 0.000000000000000E+000
- blue(1) = 0.000000000000000E+000
-
-! DodgerBlue2
- red(2) = 0.109803921568627
- green(2) = 0.525490196078431
- blue(2) = 0.933333333333333
-
-! gold
- red(3) = 1.00000000000000
- green(3) = 0.840000000000000
- blue(3) = 0.000000000000000E+000
-
-! springgreen
- red(4) = 0.000000000000000E+000
- green(4) = 1.00000000000000
- blue(4) = 0.500000000000000
-
-! NavajoWhite
- red(5) = 1.00000000000000
- green(5) = 0.870588235294118
- blue(5) = 0.678431372549020
-
-! SteelBlue3
- red(6) = 0.309803921568627
- green(6) = 0.580392156862745
- blue(6) = 0.803921568627451
-
-! Ivory3
- red(7) = 0.803921568627451
- green(7) = 0.803921568627451
- blue(7) = 0.756862745098039
-
-! SkyBlue4
- red(8) = 0.290196078431373
- green(8) = 0.439215686274510
- blue(8) = 0.545098039215686
-
-! Snow
- red(9) = 0.980392156862745
- green(9) = 0.980392156862745
- blue(9) = 0.980392156862745
-
-! SteelBlue
- red(10) = 0.274509803921569
- green(10) = 0.509803921568627
- blue(10) = 0.705882352941177
-
-! Bisque3
- red(11) = 0.803921568627451
- green(11) = 0.717647058823529
- blue(11) = 0.619607843137255
-
-! Salmon
- red(12) = 0.980392156862745
- green(12) = 0.501960784313725
- blue(12) = 0.447058823529412
-
-! SlateBlue2
- red(13) = 0.478431372549020
- green(13) = 0.403921568627451
- blue(13) = 0.933333333333333
-
-! NavajoWhite2
- red(14) = 0.933333333333333
- green(14) = 0.811764705882353
- blue(14) = 0.631372549019608
-
-! MediumBlue
- red(15) = 0.000000000000000E+000
- green(15) = 0.000000000000000E+000
- blue(15) = 0.803921568627451
-
-! LightCoral
- red(16) = 0.941176470588235
- green(16) = 0.501960784313725
- blue(16) = 0.501960784313725
-
-! FloralWhite
- red(17) = 1.00000000000000
- green(17) = 0.980392156862745
- blue(17) = 0.941176470588235
-
-! Cornsilk3
- red(18) = 0.803921568627451
- green(18) = 0.784313725490196
- blue(18) = 0.694117647058824
-
-! GhostWhite
- red(19) = 0.972549019607843
- green(19) = 0.972549019607843
- blue(19) = 1.00000000000000
-
-! blue
- red(20) = 0.000000000000000E+000
- green(20) = 0.000000000000000E+000
- blue(20) = 1.00000000000000
-
-! Linen
- red(21) = 0.980392156862745
- green(21) = 0.941176470588235
- blue(21) = 0.901960784313726
-
-! peachpuff
- red(22) = 1.00000000000000
- green(22) = 0.850000000000000
- blue(22) = 0.730000000000000
-
-! Cornsilk1
- red(23) = 1.00000000000000
- green(23) = 0.972549019607843
- blue(23) = 0.862745098039216
-
-! LightSalmon
- red(24) = 1.00000000000000
- green(24) = 0.627450980392157
- blue(24) = 0.478431372549020
-
-! DeepSkyBlue1
- red(25) = 0.000000000000000E+000
- green(25) = 0.749019607843137
- blue(25) = 1.00000000000000
-
-! LemonChiffon4
- red(26) = 0.545098039215686
- green(26) = 0.537254901960784
- blue(26) = 0.439215686274510
-
-! PeachPuff1
- red(27) = 1.00000000000000
- green(27) = 0.854901960784314
- blue(27) = 0.725490196078431
-
-! BlanchedAlmond
- red(28) = 1.00000000000000
- green(28) = 0.921568627450980
- blue(28) = 0.803921568627451
-
-! SlateBlue3
- red(29) = 0.411764705882353
- green(29) = 0.349019607843137
- blue(29) = 0.803921568627451
-
-! LightSkyBlue1
- red(30) = 0.690196078431373
- green(30) = 0.886274509803922
- blue(30) = 1.00000000000000
-
-! DarkViolet
- red(31) = 0.580392156862745
- green(31) = 0.000000000000000E+000
- blue(31) = 0.827450980392157
-
-! Azure3
- red(32) = 0.756862745098039
- green(32) = 0.803921568627451
- blue(32) = 0.803921568627451
-
-! LavenderBlush3
- red(33) = 0.803921568627451
- green(33) = 0.756862745098039
- blue(33) = 0.772549019607843
-
-! Honeydew1
- red(34) = 0.941176470588235
- green(34) = 1.00000000000000
- blue(34) = 0.941176470588235
-
-! Ivory2
- red(35) = 0.933333333333333
- green(35) = 0.933333333333333
- blue(35) = 0.878431372549020
-
-! RosyBrown
- red(36) = 0.737254901960784
- green(36) = 0.560784313725490
- blue(36) = 0.560784313725490
-
-! Thistle
- red(37) = 0.847058823529412
- green(37) = 0.749019607843137
- blue(37) = 0.847058823529412
-
-! Orange
- red(38) = 1.00000000000000
- green(38) = 0.647058823529412
- blue(38) = 0.000000000000000E+000
-
-! DarkSeaGreen
- red(39) = 0.560784313725490
- green(39) = 0.737254901960784
- blue(39) = 0.560784313725490
-
-! Moccasin
- red(40) = 1.00000000000000
- green(40) = 0.894117647058824
- blue(40) = 0.709803921568627
-
-! DeepSkyBlue2
- red(41) = 0.000000000000000E+000
- green(41) = 0.698039215686274
- blue(41) = 0.933333333333333
-
-! SlateGray4
- red(42) = 0.423529411764706
- green(42) = 0.482352941176471
- blue(42) = 0.545098039215686
-
-! Beige
- red(43) = 0.960784313725490
- green(43) = 0.960784313725490
- blue(43) = 0.862745098039216
-
-! Gold
- red(44) = 1.00000000000000
- green(44) = 0.843137254901961
- blue(44) = 0.000000000000000E+000
-
-! SlateBlue
- red(45) = 0.415686274509804
- green(45) = 0.352941176470588
- blue(45) = 0.803921568627451
-
-! SteelBlue1
- red(46) = 0.388235294117647
- green(46) = 0.721568627450980
- blue(46) = 1.00000000000000
-
-! SaddleBrown
- red(47) = 0.545098039215686
- green(47) = 0.270588235294118
- blue(47) = 7.450980392156863E-002
-
-! Pink
- red(48) = 1.00000000000000
- green(48) = 0.752941176470588
- blue(48) = 0.796078431372549
-
-! Black
- red(49) = 0.000000000000000E+000
- green(49) = 0.000000000000000E+000
- blue(49) = 0.000000000000000E+000
-
-! SlateGrey
- red(50) = 0.439215686274510
- green(50) = 0.501960784313725
- blue(50) = 0.564705882352941
-
-! Ivory
- red(51) = 1.00000000000000
- green(51) = 1.00000000000000
- blue(51) = 0.941176470588235
-
-! OliveDrab
- red(52) = 0.419607843137255
- green(52) = 0.556862745098039
- blue(52) = 0.137254901960784
-
-! Ivory1
- red(53) = 1.00000000000000
- green(53) = 1.00000000000000
- blue(53) = 0.941176470588235
-
-! SkyBlue
- red(54) = 0.529411764705882
- green(54) = 0.807843137254902
- blue(54) = 0.921568627450980
-
-! MistyRose3
- red(55) = 0.803921568627451
- green(55) = 0.717647058823529
- blue(55) = 0.709803921568627
-
-! LimeGreen
- red(56) = 0.196078431372549
- green(56) = 0.803921568627451
- blue(56) = 0.196078431372549
-
-! Purple
- red(57) = 0.627450980392157
- green(57) = 0.125490196078431
- blue(57) = 0.941176470588235
-
-! SkyBlue2
- red(58) = 0.494117647058824
- green(58) = 0.752941176470588
- blue(58) = 0.933333333333333
-
-! Red
- red(59) = 1.00000000000000
- green(59) = 0.000000000000000E+000
- blue(59) = 0.000000000000000E+000
-
-! DarkKhaki
- red(60) = 0.741176470588235
- green(60) = 0.717647058823529
- blue(60) = 0.419607843137255
-
-! MediumTurquoise
- red(61) = 0.282352941176471
- green(61) = 0.819607843137255
- blue(61) = 0.800000000000000
-
-! Grey
- red(62) = 0.745098039215686
- green(62) = 0.745098039215686
- blue(62) = 0.745098039215686
-
-! Coral
- red(63) = 1.00000000000000
- green(63) = 0.498039215686275
- blue(63) = 0.313725490196078
-
-! NavajoWhite4
- red(64) = 0.545098039215686
- green(64) = 0.474509803921569
- blue(64) = 0.368627450980392
-
-! SlateBlue4
- red(65) = 0.278431372549020
- green(65) = 0.235294117647059
- blue(65) = 0.545098039215686
-
-! RoyalBlue4
- red(66) = 0.152941176470588
- green(66) = 0.250980392156863
- blue(66) = 0.545098039215686
-
-! YellowGreen
- red(67) = 0.603921568627451
- green(67) = 0.803921568627451
- blue(67) = 0.196078431372549
-
-! DeepSkyBlue3
- red(68) = 0.000000000000000E+000
- green(68) = 0.603921568627451
- blue(68) = 0.803921568627451
-
-! goldenrod
- red(69) = 0.854901960784314
- green(69) = 0.647058823529412
- blue(69) = 0.125490196078431
-
-! AntiqueWhite4
- red(70) = 0.545098039215686
- green(70) = 0.513725490196078
- blue(70) = 0.470588235294118
-
-! lemonchiffon
- red(71) = 1.00000000000000
- green(71) = 0.980000000000000
- blue(71) = 0.800000000000000
-
-! GreenYellow
- red(72) = 0.678431372549020
- green(72) = 1.00000000000000
- blue(72) = 0.184313725490196
-
-! LightSlateGray
- red(73) = 0.466666666666667
- green(73) = 0.533333333333333
- blue(73) = 0.600000000000000
-
-! RoyalBlue
- red(74) = 0.254901960784314
- green(74) = 0.411764705882353
- blue(74) = 0.882352941176471
-
-! DarkGreen
- red(75) = 0.000000000000000E+000
- green(75) = 0.392156862745098
- blue(75) = 0.000000000000000E+000
-
-! NavajoWhite3
- red(76) = 0.803921568627451
- green(76) = 0.701960784313725
- blue(76) = 0.545098039215686
-
-! Azure1
- red(77) = 0.941176470588235
- green(77) = 1.00000000000000
- blue(77) = 1.00000000000000
-
-! PowderBlue
- red(78) = 0.690196078431373
- green(78) = 0.878431372549020
- blue(78) = 0.901960784313726
-
-! slateblue
- red(79) = 0.420000000000000
- green(79) = 0.350000000000000
- blue(79) = 0.800000000000000
-
-! MediumOrchid
- red(80) = 0.729411764705882
- green(80) = 0.333333333333333
- blue(80) = 0.827450980392157
-
-! turquoise
- red(81) = 0.250000000000000
- green(81) = 0.880000000000000
- blue(81) = 0.820000000000000
-
-! Snow1
- red(82) = 1.00000000000000
- green(82) = 0.980392156862745
- blue(82) = 0.980392156862745
-
-! violet
- red(83) = 0.930000000000000
- green(83) = 0.510000000000000
- blue(83) = 0.930000000000000
-
-! DeepPink
- red(84) = 1.00000000000000
- green(84) = 7.843137254901961E-002
- blue(84) = 0.576470588235294
-
-! MistyRose4
- red(85) = 0.545098039215686
- green(85) = 0.490196078431373
- blue(85) = 0.482352941176471
-
-! PeachPuff3
- red(86) = 0.803921568627451
- green(86) = 0.686274509803922
- blue(86) = 0.584313725490196
-
-! MediumSeaGreen
- red(87) = 0.235294117647059
- green(87) = 0.701960784313725
- blue(87) = 0.443137254901961
-
-! Honeydew4
- red(88) = 0.513725490196078
- green(88) = 0.545098039215686
- blue(88) = 0.513725490196078
-
-! Tan
- red(89) = 0.823529411764706
- green(89) = 0.705882352941177
- blue(89) = 0.549019607843137
-
-! DarkGoldenrod
- red(90) = 0.721568627450980
- green(90) = 0.525490196078431
- blue(90) = 4.313725490196078E-002
-
-! Blue2
- red(91) = 0.000000000000000E+000
- green(91) = 0.000000000000000E+000
- blue(91) = 0.933333333333333
-
-! Maroon
- red(92) = 0.690196078431373
- green(92) = 0.188235294117647
- blue(92) = 0.376470588235294
-
-! LightSkyBlue3
- red(93) = 0.552941176470588
- green(93) = 0.713725490196078
- blue(93) = 0.803921568627451
-
-! LemonChiffon2
- red(94) = 0.933333333333333
- green(94) = 0.913725490196078
- blue(94) = 0.749019607843137
-
-! Snow3
- red(95) = 0.803921568627451
- green(95) = 0.788235294117647
- blue(95) = 0.788235294117647
-
-! Ivory4
- red(96) = 0.545098039215686
- green(96) = 0.545098039215686
- blue(96) = 0.513725490196078
-
-! AntiqueWhite3
- red(97) = 0.803921568627451
- green(97) = 0.752941176470588
- blue(97) = 0.690196078431373
-
-! Bisque4
- red(98) = 0.545098039215686
- green(98) = 0.490196078431373
- blue(98) = 0.419607843137255
-
-! Snow2
- red(99) = 0.933333333333333
- green(99) = 0.913725490196078
- blue(99) = 0.913725490196078
-
-! SlateGray1
- red(100) = 0.776470588235294
- green(100) = 0.886274509803922
- blue(100) = 1.00000000000000
-
-! Seashell2
- red(101) = 0.933333333333333
- green(101) = 0.898039215686275
- blue(101) = 0.870588235294118
-
-! Aquamarine
- red(102) = 0.498039215686275
- green(102) = 1.00000000000000
- blue(102) = 0.831372549019608
-
-! SlateGray2
- red(103) = 0.725490196078431
- green(103) = 0.827450980392157
- blue(103) = 0.933333333333333
-
-! White
- red(104) = 1.00000000000000
- green(104) = 1.00000000000000
- blue(104) = 1.00000000000000
-
-! LavenderBlush
- red(105) = 1.00000000000000
- green(105) = 0.941176470588235
- blue(105) = 0.960784313725490
-
-! DodgerBlue3
- red(106) = 9.411764705882353E-002
- green(106) = 0.454901960784314
- blue(106) = 0.803921568627451
-
-! RoyalBlue3
- red(107) = 0.227450980392157
- green(107) = 0.372549019607843
- blue(107) = 0.803921568627451
-
-! LightYellow
- red(108) = 1.00000000000000
- green(108) = 1.00000000000000
- blue(108) = 0.878431372549020
-
-! DeepSkyBlue
- red(109) = 0.000000000000000E+000
- green(109) = 0.749019607843137
- blue(109) = 1.00000000000000
-
-! AntiqueWhite2
- red(110) = 0.933333333333333
- green(110) = 0.874509803921569
- blue(110) = 0.800000000000000
-
-! CornflowerBlue
- red(111) = 0.392156862745098
- green(111) = 0.584313725490196
- blue(111) = 0.929411764705882
-
-! PeachPuff4
- red(112) = 0.545098039215686
- green(112) = 0.466666666666667
- blue(112) = 0.396078431372549
-
-! SpringGreen
- red(113) = 0.000000000000000E+000
- green(113) = 1.00000000000000
- blue(113) = 0.498039215686275
-
-! Honeydew
- red(114) = 0.941176470588235
- green(114) = 1.00000000000000
- blue(114) = 0.941176470588235
-
-! Honeydew2
- red(115) = 0.878431372549020
- green(115) = 0.933333333333333
- blue(115) = 0.878431372549020
-
-! LightSeaGreen
- red(116) = 0.125490196078431
- green(116) = 0.698039215686274
- blue(116) = 0.666666666666667
-
-! NavyBlue
- red(117) = 0.000000000000000E+000
- green(117) = 0.000000000000000E+000
- blue(117) = 0.501960784313725
-
-! Azure4
- red(118) = 0.513725490196078
- green(118) = 0.545098039215686
- blue(118) = 0.545098039215686
-
-! MediumAquamarine
- red(119) = 0.400000000000000
- green(119) = 0.803921568627451
- blue(119) = 0.666666666666667
-
-! SkyBlue3
- red(120) = 0.423529411764706
- green(120) = 0.650980392156863
- blue(120) = 0.803921568627451
-
-! LavenderBlush2
- red(121) = 0.933333333333333
- green(121) = 0.878431372549020
- blue(121) = 0.898039215686275
-
-! Bisque1
- red(122) = 1.00000000000000
- green(122) = 0.894117647058824
- blue(122) = 0.768627450980392
-
-! DarkOrange
- red(123) = 1.00000000000000
- green(123) = 0.549019607843137
- blue(123) = 0.000000000000000E+000
-
-! LightSteelBlue
- red(124) = 0.690196078431373
- green(124) = 0.768627450980392
- blue(124) = 0.870588235294118
-
-! SteelBlue2
- red(125) = 0.360784313725490
- green(125) = 0.674509803921569
- blue(125) = 0.933333333333333
-
-! LemonChiffon3
- red(126) = 0.803921568627451
- green(126) = 0.788235294117647
- blue(126) = 0.647058823529412
-
-! DarkSlateBlue
- red(127) = 0.282352941176471
- green(127) = 0.239215686274510
- blue(127) = 0.545098039215686
-
-! Seashell
- red(128) = 1.00000000000000
- green(128) = 0.960784313725490
- blue(128) = 0.933333333333333
-
-! Firebrick
- red(129) = 0.698039215686274
- green(129) = 0.133333333333333
- blue(129) = 0.133333333333333
-
-! LightGray
- red(130) = 0.827450980392157
- green(130) = 0.827450980392157
- blue(130) = 0.827450980392157
-
-! Blue
- red(131) = 0.000000000000000E+000
- green(131) = 0.000000000000000E+000
- blue(131) = 1.00000000000000
-
-! Bisque2
- red(132) = 0.933333333333333
- green(132) = 0.835294117647059
- blue(132) = 0.717647058823529
-
-! WhiteSmoke
- red(133) = 0.960784313725490
- green(133) = 0.960784313725490
- blue(133) = 0.960784313725490
-
-! SeaGreen
- red(134) = 0.180392156862745
- green(134) = 0.545098039215686
- blue(134) = 0.341176470588235
-
-! Burlywood
- red(135) = 0.870588235294118
- green(135) = 0.721568627450980
- blue(135) = 0.529411764705882
-
-! RoyalBlue2
- red(136) = 0.262745098039216
- green(136) = 0.431372549019608
- blue(136) = 0.933333333333333
-
-! RoyalBlue1
- red(137) = 0.282352941176471
- green(137) = 0.462745098039216
- blue(137) = 1.00000000000000
-
-! SteelBlue4
- red(138) = 0.211764705882353
- green(138) = 0.392156862745098
- blue(138) = 0.545098039215686
-
-! AliceBlue
- red(139) = 0.941176470588235
- green(139) = 0.972549019607843
- blue(139) = 1.00000000000000
-
-! LightSlateBlue
- red(140) = 0.517647058823529
- green(140) = 0.439215686274510
- blue(140) = 1.00000000000000
-
-! MistyRose1
- red(141) = 1.00000000000000
- green(141) = 0.894117647058824
- blue(141) = 0.882352941176471
-
-! SandyBrown
- red(142) = 0.956862745098039
- green(142) = 0.643137254901961
- blue(142) = 0.376470588235294
-
-! DarkOliveGreen
- red(143) = 0.333333333333333
- green(143) = 0.419607843137255
- blue(143) = 0.184313725490196
-
-! Yellow
- red(144) = 1.00000000000000
- green(144) = 1.00000000000000
- blue(144) = 0.000000000000000E+000
-
-! SlateGray3
- red(145) = 0.623529411764706
- green(145) = 0.713725490196078
- blue(145) = 0.803921568627451
-
-! HotPink
- red(146) = 1.00000000000000
- green(146) = 0.411764705882353
- blue(146) = 0.705882352941177
-
-! Violet
- red(147) = 0.933333333333333
- green(147) = 0.509803921568627
- blue(147) = 0.933333333333333
-
-! LightSkyBlue
- red(148) = 0.529411764705882
- green(148) = 0.807843137254902
- blue(148) = 0.980392156862745
-
-! Cornsilk2
- red(149) = 0.933333333333333
- green(149) = 0.909803921568627
- blue(149) = 0.803921568627451
-
-! MidnightBlue
- red(150) = 9.803921568627451E-002
- green(150) = 9.803921568627451E-002
- blue(150) = 0.439215686274510
-
-! AntiqueWhite
- red(151) = 0.980392156862745
- green(151) = 0.921568627450980
- blue(151) = 0.843137254901961
-
-! PaleGreen
- red(152) = 0.596078431372549
- green(152) = 0.984313725490196
- blue(152) = 0.596078431372549
-
-! MedSpringGreen
- red(153) = 0.000000000000000E+000
- green(153) = 0.980392156862745
- blue(153) = 0.603921568627451
-
-! DodgerBlue1
- red(154) = 0.117647058823529
- green(154) = 0.564705882352941
- blue(154) = 1.00000000000000
-
-! Blue3
- red(155) = 0.000000000000000E+000
- green(155) = 0.000000000000000E+000
- blue(155) = 0.803921568627451
-
-! Cyan
- red(156) = 0.000000000000000E+000
- green(156) = 1.00000000000000
- blue(156) = 1.00000000000000
-
-! LemonChiffon
- red(157) = 1.00000000000000
- green(157) = 0.980392156862745
- blue(157) = 0.803921568627451
-
-! mediumorchid
- red(158) = 0.730000000000000
- green(158) = 0.330000000000000
- blue(158) = 0.830000000000000
-
-! Turquoise
- red(159) = 0.250980392156863
- green(159) = 0.878431372549020
- blue(159) = 0.815686274509804
-
-! IndianRed
- red(160) = 0.803921568627451
- green(160) = 0.360784313725490
- blue(160) = 0.360784313725490
-
-! DodgerBlue
- red(161) = 0.117647058823529
- green(161) = 0.564705882352941
- blue(161) = 1.00000000000000
-
-! Seashell3
- red(162) = 0.803921568627451
- green(162) = 0.772549019607843
- blue(162) = 0.749019607843137
-
-! BlueViolet
- red(163) = 0.541176470588235
- green(163) = 0.168627450980392
- blue(163) = 0.886274509803922
-
-! DeepSkyBlue4
- red(164) = 0.000000000000000E+000
- green(164) = 0.407843137254902
- blue(164) = 0.545098039215686
-
-! PaleVioletRed
- red(165) = 0.858823529411765
- green(165) = 0.439215686274510
- blue(165) = 0.576470588235294
-
-! Azure2
- red(166) = 0.878431372549020
- green(166) = 0.933333333333333
- blue(166) = 0.933333333333333
-
-! greenyellow
- red(167) = 0.680000000000000
- green(167) = 1.00000000000000
- blue(167) = 0.180000000000000
-
-! LightGoldenrod
- red(168) = 0.933333333333333
- green(168) = 0.866666666666667
- blue(168) = 0.509803921568627
-
-! MistyRose
- red(169) = 1.00000000000000
- green(169) = 0.894117647058824
- blue(169) = 0.882352941176471
-
-! LightSkyBlue4
- red(170) = 0.376470588235294
- green(170) = 0.482352941176471
- blue(170) = 0.545098039215686
-
-! OrangeRed
- red(171) = 1.00000000000000
- green(171) = 0.270588235294118
- blue(171) = 0.000000000000000E+000
-
-! DimGrey
- red(172) = 0.411764705882353
- green(172) = 0.411764705882353
- blue(172) = 0.411764705882353
-
-! MediumVioletRed
- red(173) = 0.780392156862745
- green(173) = 8.235294117647059E-002
- blue(173) = 0.521568627450980
-
-! DarkSlateGray
- red(174) = 0.184313725490196
- green(174) = 0.309803921568627
- blue(174) = 0.309803921568627
-
-! yellow
- red(175) = 1.00000000000000
- green(175) = 1.00000000000000
- blue(175) = 0.000000000000000E+000
-
-! Plum
- red(176) = 0.866666666666667
- green(176) = 0.627450980392157
- blue(176) = 0.866666666666667
-
-! DarkTurquoise
- red(177) = 0.000000000000000E+000
- green(177) = 0.807843137254902
- blue(177) = 0.819607843137255
-
-! DodgerBlue4
- red(178) = 6.274509803921569E-002
- green(178) = 0.305882352941176
- blue(178) = 0.545098039215686
-
-! Cornsilk
- red(179) = 1.00000000000000
- green(179) = 0.972549019607843
- blue(179) = 0.862745098039216
-
-! SkyBlue1
- red(180) = 0.529411764705882
- green(180) = 0.807843137254902
- blue(180) = 1.00000000000000
-
-! Seashell1
- red(181) = 1.00000000000000
- green(181) = 0.960784313725490
- blue(181) = 0.933333333333333
-
-! lavender
- red(182) = 0.901960784313726
- green(182) = 0.901960784313726
- blue(182) = 0.980392156862745
-
-! Snow4
- red(183) = 0.545098039215686
- green(183) = 0.537254901960784
- blue(183) = 0.537254901960784
-
-! Peru
- red(184) = 0.803921568627451
- green(184) = 0.521568627450980
- blue(184) = 0.247058823529412
-
-! PeachPuff
- red(185) = 1.00000000000000
- green(185) = 0.854901960784314
- blue(185) = 0.725490196078431
-
-! Green
- red(186) = 0.000000000000000E+000
- green(186) = 1.00000000000000
- blue(186) = 0.000000000000000E+000
-
-! Blue1
- red(187) = 0.000000000000000E+000
- green(187) = 0.000000000000000E+000
- blue(187) = 1.00000000000000
-
-! Seashell4
- red(188) = 0.545098039215686
- green(188) = 0.525490196078431
- blue(188) = 0.509803921568627
-
-! dodgerblue
- red(189) = 0.120000000000000
- green(189) = 0.560000000000000
- blue(189) = 1.00000000000000
-
-! MistyRose2
- red(190) = 0.933333333333333
- green(190) = 0.835294117647059
- blue(190) = 0.823529411764706
-
-! Tomato
- red(191) = 1.00000000000000
- green(191) = 0.388235294117647
- blue(191) = 0.278431372549020
-
-! Wheat
- red(192) = 0.960784313725490
- green(192) = 0.870588235294118
- blue(192) = 0.701960784313725
-
-! LightBlue
- red(193) = 0.678431372549020
- green(193) = 0.847058823529412
- blue(193) = 0.901960784313726
-
-! Chocolate
- red(194) = 0.823529411764706
- green(194) = 0.411764705882353
- blue(194) = 0.117647058823529
-
-! Blue4
- red(195) = 0.000000000000000E+000
- green(195) = 0.000000000000000E+000
- blue(195) = 0.545098039215686
-
-! LavenderBlush1
- red(196) = 1.00000000000000
- green(196) = 0.941176470588235
- blue(196) = 0.960784313725490
-
-! Magenta
- red(197) = 1.00000000000000
- green(197) = 0.000000000000000E+000
- blue(197) = 1.00000000000000
-
-! darkturquoise
- red(198) = 0.000000000000000E+000
- green(198) = 0.810000000000000
- blue(198) = 0.820000000000000
-
-! blueviolet
- red(199) = 0.540000000000000
- green(199) = 0.170000000000000
- blue(199) = 0.890000000000000
-
-! MintCream
- red(200) = 0.960784313725490
- green(200) = 1.00000000000000
- blue(200) = 0.980392156862745
-
-! PaleGoldenrod
- red(201) = 0.933333333333333
- green(201) = 0.909803921568627
- blue(201) = 0.666666666666667
-
-! MediumPurple
- red(202) = 0.576470588235294
- green(202) = 0.439215686274510
- blue(202) = 0.858823529411765
-
-! PapayaWhip
- red(203) = 1.00000000000000
- green(203) = 0.937254901960784
- blue(203) = 0.835294117647059
-
-! LavenderBlush4
- red(204) = 0.545098039215686
- green(204) = 0.513725490196078
- blue(204) = 0.525490196078431
-
-! Cornsilk4
- red(205) = 0.545098039215686
- green(205) = 0.533333333333333
- blue(205) = 0.470588235294118
-
-! LtGoldenrodYello
- red(206) = 0.980392156862745
- green(206) = 0.980392156862745
- blue(206) = 0.823529411764706
-
-! limegreen
- red(207) = 0.200000000000000
- green(207) = 0.800000000000000
- blue(207) = 0.200000000000000
-
-! LemonChiffon1
- red(208) = 1.00000000000000
- green(208) = 0.980392156862745
- blue(208) = 0.803921568627451
-
-! DarkOrchid
- red(209) = 0.600000000000000
- green(209) = 0.196078431372549
- blue(209) = 0.800000000000000
-
-! SlateBlue1
- red(210) = 0.513725490196078
- green(210) = 0.435294117647059
- blue(210) = 1.00000000000000
-
-! chartreuse
- red(211) = 0.500000000000000
- green(211) = 1.00000000000000
- blue(211) = 0.000000000000000E+000
-
-! PaleTurquoise
- red(212) = 0.686274509803922
- green(212) = 0.933333333333333
- blue(212) = 0.933333333333333
-
-! NavajoWhite1
- red(213) = 1.00000000000000
- green(213) = 0.870588235294118
- blue(213) = 0.678431372549020
-
-! LightSkyBlue2
- red(214) = 0.643137254901961
- green(214) = 0.827450980392157
- blue(214) = 0.933333333333333
-
-! VioletRed
- red(215) = 0.815686274509804
- green(215) = 0.125490196078431
- blue(215) = 0.564705882352941
-
-! mocassin
- red(216) = 1.00000000000000
- green(216) = 0.890000000000000
- blue(216) = 0.710000000000000
-
-! OldLace
- red(217) = 0.992156862745098
- green(217) = 0.960784313725490
- blue(217) = 0.901960784313726
-
-! deeppink
- red(218) = 1.00000000000000
- green(218) = 8.000000000000000E-002
- blue(218) = 0.580000000000000
-
-! Honeydew3
- red(219) = 0.756862745098039
- green(219) = 0.803921568627451
- blue(219) = 0.756862745098039
-
-! Gainsboro
- red(220) = 0.862745098039216
- green(220) = 0.862745098039216
- blue(220) = 0.862745098039216
-
-! DarkSalmon
- red(221) = 0.913725490196078
- green(221) = 0.588235294117647
- blue(221) = 0.478431372549020
-
-! AntiqueWhite1
- red(222) = 1.00000000000000
- green(222) = 0.937254901960784
- blue(222) = 0.858823529411765
-
-! LightCyan
- red(223) = 0.878431372549020
- green(223) = 1.00000000000000
- blue(223) = 1.00000000000000
-
-! ForestGreen
- red(224) = 0.133333333333333
- green(224) = 0.545098039215686
- blue(224) = 0.133333333333333
-
-! Orchid
- red(225) = 0.854901960784314
- green(225) = 0.439215686274510
- blue(225) = 0.839215686274510
-
-! PeachPuff2
- red(226) = 0.933333333333333
- green(226) = 0.796078431372549
- blue(226) = 0.678431372549020
-
-! LightPink
- red(227) = 1.00000000000000
- green(227) = 0.713725490196078
- blue(227) = 0.756862745098039
-
-! Sienna
- red(228) = 0.627450980392157
- green(228) = 0.321568627450980
- blue(228) = 0.176470588235294
-
-! darkorchid
- red(229) = 0.600000000000000
- green(229) = 0.200000000000000
- blue(229) = 0.800000000000000
-
-! MediumSlateBlue
- red(230) = 0.482352941176471
- green(230) = 0.407843137254902
- blue(230) = 0.933333333333333
-
-! CadetBlue
- red(231) = 0.372549019607843
- green(231) = 0.619607843137255
- blue(231) = 0.627450980392157
-
-! LawnGreen
- red(232) = 0.486274509803922
- green(232) = 0.988235294117647
- blue(232) = 0.000000000000000E+000
-
-! Chartreuse
- red(233) = 0.498039215686275
- green(233) = 1.00000000000000
- blue(233) = 0.000000000000000E+000
-
-! Brown
- red(234) = 0.647058823529412
- green(234) = 0.164705882352941
- blue(234) = 0.164705882352941
-
-! Azure
- red(235) = 0.941176470588235
- green(235) = 1.00000000000000
- blue(235) = 1.00000000000000
-
-! Bisque
- red(236) = 1.00000000000000
- green(236) = 0.894117647058824
- blue(236) = 0.768627450980392
-
- end subroutine checkgrid_setup_colorp
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_Bielak_conditions.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_Bielak_conditions.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_Bielak_conditions.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,237 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! compute analytical initial plane wave for Bielak's conditions
-
-subroutine 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)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: iglob,npoin,it
-
- double precision, intent(in) :: deltat
-
- double precision, intent(out) :: dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert
-
- double precision, dimension(NDIM,npoin), intent(in) :: coord
-
- double precision :: time_veloc,time_traction,t,x,z
-
- double precision, external :: ricker_Bielak_veloc
-
- double precision x0_source, z0_source, angleforce, angleforce_refl
- double precision c_inc, c_refl, time_offset, f0
- double precision, dimension(NDIM) :: A_plane, B_plane, C_plane
-
-
-! get the coordinates of the mesh point
- x = coord(1,iglob) - x0_source
- z = z0_source - coord(2,iglob)
-
-! times for velocity and traction are staggered i.e. separated by deltat/2.d0
- time_veloc = (it-1)*deltat + deltat/2.d0 + time_offset
- time_traction = time_veloc + deltat/2.d0
-
- t = time_traction
-
-!!$!SV30
-!!$
-!!$!analytical expression of the displacement for a SV 30 degrees and 0.3333 poisson ratio
-!!$! Ux = sqrt(3.d0)/2.d0 * rickertest(t - x/2.d0 + (9 - z) * sqrt(3.d0)/2.d0) &
-!!$! + sqrt(3.d0)/2.d0 * rickertest(t - x/2.d0 - (9 - z) * sqrt(3.d0)/2.d0) &
-!!$! + sqrt(3.d0) * rickertest(t - x/2.d0)
-!!$! Uz = - HALF * rickertest(t - x/2.d0 + (9 - z) * sqrt(3.d0)/2.d0) &
-!!$! + HALF * rickertest(t - x/2.d0 - (9 - z) * sqrt(3.d0)/2.d0)
-!!$
-!!$
-!!$! derivatives of analytical expression of horizontal and vertical displacements,
-!!$! computed using the "Mathematica" script in UTILS/deriv_ricker_spatial.m
-!!$ dxUx = (sqrt(3.d0)*a*((-8*t + 4*x)*exp(-a*(t - x/2.d0)**2) + &
-!!$ ((2*t - x)*(-2 + a*(-2*t + x)**2))*exp(-a*(t - x/2.d0)**2) + &
-!!$ (2*(-2*t + x - sqrt(3.d0)*(-9 + z)))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ ((1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (-2*t + x - sqrt(3.d0)*(-9 + z)))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (2*(-2*t + x + sqrt(3.d0)*(-9 + z)))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (-2*t + x + sqrt(3.d0)*(-9 + z)))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/4.d0
-!!$
-!!$ dzUx = (3*a*(((t + (-x + sqrt(3.d0)*(-9 + z))/2.d0)* &
-!!$ (1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) - &
-!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (t - x/2.d0 - (sqrt(3.d0)*(-9 + z))/2.d0))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (2*t - x + sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (-2*t + x + sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
-!!$
-!!$ dxUz = (a*((2*t - x - sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (-2*t + x - sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ ((1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (-2*t + x - sqrt(3.d0)*(-9 + z)))/2.d0*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) - &
-!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (-2*t + x + sqrt(3.d0)*(-9 + z)))/2.d0*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
-!!$
-!!$ dzUz = (sqrt(3.d0)*a*(((t + (-x + sqrt(3.d0)*(-9 + z))/2.d0)* &
-!!$ (1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (2*t - x - sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (t - x/2.d0 - (sqrt(3.d0)*(-9 + z))/2.d0))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (2*t - x + sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
-
-! to ompute the derivative of the displacement, we take the velocity ricker expression and we multiply by
-! the derivative of the interior argument of ricker_Bielak_veloc
-
- dxUx = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
- + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
- + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
- * (-sin(angleforce_refl)/c_refl)
-
- dzUx = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-cos(angleforce)/c_inc)&
- + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (cos(angleforce)/c_inc)&
- + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
- * (cos(angleforce_refl)/c_refl)
-
- dxUz = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
- + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
- + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
- * (-sin(angleforce_refl)/c_refl)
-
- dzUz = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-cos(angleforce)/c_inc)&
- + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (cos(angleforce)/c_inc)&
- + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
- * (cos(angleforce_refl)/c_refl)
-
- t = time_veloc
-
-!!$!SV30
-!!$! analytical expression of the two components of the velocity vector
-!!$ veloc_horiz = (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_vert = - 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))
-
- veloc_horiz = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- veloc_vert = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
-
-end subroutine compute_Bielak_conditions
-
-! ********
-
-! compute time variation of the source for analytical initial plane wave
-double precision function ricker_Bielak_integrale_displ(t,f0)
-
- implicit none
-
- include "constants.h"
-
- double precision :: t,f0,a
-
- a = pi*pi*f0*f0
-
-! Ricker
- ricker_Bielak_integrale_displ = t*exp(-a*t**2)
-
-end function ricker_Bielak_integrale_displ
-
-! ********
-
-! compute time variation of the source for analytical initial plane wave
-double precision function ricker_Bielak_displ(t,f0)
-
- implicit none
-
- include "constants.h"
-
- double precision :: t,f0,a
-
- a = pi*pi*f0*f0
-
-! Ricker
- ricker_Bielak_displ = (1 - 2*a*t**2)*exp(-a*t**2)
-
-end function ricker_Bielak_displ
-
-! *******
-
-! compute time variation of the source for analytical initial plane wave
-double precision function ricker_Bielak_veloc(t,f0)
-
- implicit none
-
- include "constants.h"
-
- double precision :: t,f0,a
-
- a = pi*pi*f0*f0
-
-! first time derivative of a Ricker
- ricker_Bielak_veloc = - 2*a*t*(3 - 2*a*t**2)*exp(-a*t**2)
-
-end function ricker_Bielak_veloc
-
-! *******
-
-! compute time variation of the source for analytical initial plane wave
-double precision function ricker_Bielak_accel(t,f0)
-
- implicit none
-
- include "constants.h"
-
- double precision :: t,f0,a
-
- a = pi*pi*f0*f0
-
-! second time derivative of a Ricker
- ricker_Bielak_accel = - 2*a*(3 - 12*a*t**2 + 4*a**2*t**4)* exp(-a*t**2)
-
-end function ricker_Bielak_accel
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_arrays_source.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_arrays_source.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_arrays_source.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,190 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
- Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer ispec_selected_source
- integer nspec
-
- double precision xi_source,gamma_source
- double precision Mxx,Mzz,Mxz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
-
- double precision xixd,xizd,gammaxd,gammazd
-
-! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLZ) :: zigll
-
-! source arrays
- double precision, dimension(NGLLX,NGLLZ) :: G11,G13,G31,G33
- double precision, dimension(NGLLX) :: hxis,hpxis
- double precision, dimension(NGLLZ) :: hgammas,hpgammas
-
- integer k,m
- integer ir,iv
-
-! calculate G_ij for general source location
-! the source does not necessarily correspond to a Gauss-Lobatto point
- do m=1,NGLLZ
- do k=1,NGLLX
-
- xixd = xix(k,m,ispec_selected_source)
- xizd = xiz(k,m,ispec_selected_source)
- gammaxd = gammax(k,m,ispec_selected_source)
- gammazd = gammaz(k,m,ispec_selected_source)
-
- G11(k,m) = Mxx*xixd+Mxz*xizd
- G13(k,m) = Mxx*gammaxd+Mxz*gammazd
- G31(k,m) = Mxz*xixd+Mzz*xizd
- G33(k,m) = Mxz*gammaxd+Mzz*gammazd
-
-!!!! G21(k,m) = Mxy*xixd+Myz*xizd
-!!!! G23(k,m) = Mxy*gammaxd+Myz*gammazd
-
- enddo
- enddo
-
-! compute Lagrange polynomials at the source location
- call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
- call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
-
-! calculate source array
- do m=1,NGLLZ
- do k=1,NGLLX
-
- sourcearray(:,k,m) = ZERO
-
- do iv=1,NGLLZ
- do ir=1,NGLLX
-
- sourcearray(1,k,m) = sourcearray(1,k,m) + hxis(ir)*hgammas(iv) &
- *(G11(ir,iv)*hpxis(k)*hgammas(m) &
- +G13(ir,iv)*hxis(k)*hpgammas(m))
-
-! sourcearray(2,k,m) = sourcearray(2,k,m) + hxis(ir)*hgammas(iv) &
-! *(G21(ir,iv)*hpxis(k)*hgammas(m) &
-! +G23(ir,iv)*hxis(k)*hpgammas(m))
-
- sourcearray(2,k,m) = sourcearray(2,k,m) + hxis(ir)*hgammas(iv) &
- *(G31(ir,iv)*hpxis(k)*hgammas(m) &
- +G33(ir,iv)*hxis(k)*hpgammas(m))
-
- enddo
- enddo
-
- enddo
- enddo
-
- end subroutine compute_arrays_source
-
-! ------------------------------------------------------------------------------------------------------
-
-
- subroutine compute_arrays_adj_source(adj_source_file,xi_receiver,gamma_receiver,adj_sourcearray, &
- xigll,zigll,NSTEP)
-
- implicit none
-
- include 'constants.h'
-
-! input
- integer NSTEP
-
- double precision xi_receiver, gamma_receiver
-
- character(len=*) adj_source_file
-
-! output
- real(kind=CUSTOM_REAL), dimension(NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearray
-
-! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLZ) :: zigll
-
-
- double precision :: hxir(NGLLX), hpxir(NGLLX), hgammar(NGLLZ), hpgammar(NGLLZ)
- real(kind=CUSTOM_REAL) :: adj_src_s(NSTEP,3)
-
- integer icomp, itime, i, k, ios
- double precision :: junk
- character(len=3) :: comp(3)
- character(len=150) :: filename
-
- call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
- call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
-
- adj_sourcearray(:,:,:,:) = 0.
-
- comp = (/"BHX","BHY","BHZ"/)
-
- do icomp = 1,3
-
- filename = 'OUTPUT_FILES/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
- open(unit = IIN, file = trim(filename), iostat = ios)
- if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')
-
- do itime = 1, NSTEP
- read(IIN,*) junk, adj_src_s(itime,icomp)
- enddo
- close(IIN)
-
- enddo
-
- do k = 1, NGLLZ
- do i = 1, NGLLX
- adj_sourcearray(:,:,i,k) = hxir(i) * hgammar(k) * adj_src_s(:,:)
- enddo
- enddo
-
-
-end subroutine compute_arrays_adj_source
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_curl_one_element.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_curl_one_element.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_curl_one_element.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,164 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_curl_one_element(curl_element,displ_elastic, &
- displs_poroelastic,elastic,poroelastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
- nspec,npoin_elastic,npoin_poroelastic,ispec)
-
- ! compute curl in (poro)elastic elements (for rotational study)
-
- implicit none
-
- include "constants.h"
-
- integer nspec,ispec
-
- integer, dimension(NGLLX,NGLLX,nspec) :: ibool
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
- ! curl in this element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
-
- logical, dimension(nspec) :: elastic,poroelastic
-
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic
-
- ! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
- ! local variables
- integer :: i,j,k
-
- ! jacobian
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
-
- ! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
- real(kind=CUSTOM_REAL) :: duz_dxl,dux_dzl
-
- if(elastic(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 + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,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(3,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
-
- 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')
-
- endif ! end of test if acoustic or elastic element
-
-end subroutine compute_curl_one_element
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_energy.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_energy.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_energy.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,403 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- 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_acoustic,npoin_elastic,npoin_poroelastic, &
- assign_external_model,it,deltat,t0,kmato,poroelastcoef,density, &
- porosity,tortuosity, &
- vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext, &
- anisotropic,anisotropy,wxgll,wzgll,numat, &
- pressure_element,vector_field_element,e1,e11, &
- potential_dot_acoustic,potential_dot_dot_acoustic, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS,p_sv)
-
-! compute kinetic and potential energy in the solid (acoustic elements are excluded)
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,numat
-
-! vector field in an element
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
-
-! pressure in an element
- integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
-
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: &
- potential_dot_acoustic,potential_dot_dot_acoustic
-
- logical :: TURN_ATTENUATION_ON,p_sv
-
- integer :: it
- double precision :: t0,deltat
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- logical, dimension(nspec) :: elastic,poroelastic,anisotropic
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- integer, dimension(nspec) :: kmato
- logical :: assign_external_model
- double precision, dimension(2,numat) :: density
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(6,numat) :: anisotropy
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
- double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext, &
- c33ext,c35ext,c55ext
-
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic,veloc_elastic
-
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,velocs_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displw_poroelastic,velocw_poroelastic
-
-! Gauss-Lobatto-Legendre points and weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
-! local variables
- integer :: i,j,k,ispec
-
-! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
- real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
- real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
-
-! jacobian
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
- real(kind=CUSTOM_REAL) :: kinetic_energy,potential_energy
- real(kind=CUSTOM_REAL) :: cpl,csl,rhol,mul_relaxed,lambdal_relaxed, &
- lambdalplus2mul_relaxed,kappal
- real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
- real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
- real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
- real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
- real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
-
- kinetic_energy = ZERO
- potential_energy = ZERO
-
-! loop over spectral elements
- do ispec = 1,nspec
-
- !---
- !--- elastic spectral element
- !---
- if(elastic(ispec)) then
-
- ! checks wave type
- if( .not. p_sv ) then
- call exit_MPI('output energy for SH waves not implemented yet')
- endif
-
- ! 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))
- rhol = density(1,kmato(ispec))
-
- ! double loop over GLL points
- 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)
- rhol = rhoext(i,j,ispec)
- mul_relaxed = rhol*csl*csl
- lambdal_relaxed = rhol*cpl*cpl - TWO*mul_relaxed
- lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
- endif
-
- ! derivative along x and along z
- dux_dxi = 0._CUSTOM_REAL
- duz_dxi = 0._CUSTOM_REAL
-
- dux_dgamma = 0._CUSTOM_REAL
- duz_dgamma = 0._CUSTOM_REAL
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,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(3,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)
- jacobianl = jacobian(i,j,ispec)
-
- ! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- ! compute kinetic energy
- kinetic_energy = kinetic_energy &
- + rhol*(veloc_elastic(1,ibool(i,j,ispec))**2 &
- + veloc_elastic(3,ibool(i,j,ispec))**2) *wxgll(i)*wzgll(j)*jacobianl / TWO
-
- ! compute potential energy
- potential_energy = potential_energy &
- + (lambdalplus2mul_relaxed*dux_dxl**2 &
- + lambdalplus2mul_relaxed*duz_dzl**2 &
- + two*lambdal_relaxed*dux_dxl*duz_dzl &
- + mul_relaxed*(dux_dzl + duz_dxl)**2)*wxgll(i)*wzgll(j)*jacobianl / TWO
-
- enddo
- enddo
-
- !---
- !--- poroelastic spectral element
- !---
- elseif(poroelastic(ispec)) then
-
- ! get relaxed elastic parameters of current spectral element
- !for now replaced by solid, fluid, and frame parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- !solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
- rhol_s = density(1,kmato(ispec))
- !fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
- !frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
- rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
- !Biot coefficients for the input phi
- D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
- + kappal_fr + FOUR_THIRDS*mul_fr
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
- !The RHS has the form : div T -phi/c div T_f + phi/ceta_fk^-1.partial t w
- !where T = G:grad u_s + C div w I
- !and T_f = C div u_s I + M div w I
- !we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
- mul_G = mul_fr
- lambdal_G = H_biot - TWO*mul_fr
- lambdalplus2mul_G = lambdal_G + TWO*mul_G
-
- ! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- ! derivative along x and along z
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
- jacobianl = jacobian(i,j,ispec)
-
- ! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
-
- dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
- ! compute potential energy
- potential_energy = potential_energy &
- + ( lambdalplus2mul_G*dux_dxl**2 &
- + lambdalplus2mul_G*duz_dzl**2 &
- + two*lambdal_G*dux_dxl*duz_dzl + mul_G*(dux_dzl + duz_dxl)**2 &
- + two*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 &
- + ( rhol_bar*(velocs_poroelastic(1,ibool(i,j,ispec))**2 &
- + velocs_poroelastic(2,ibool(i,j,ispec))**2) &
- + rhol_f*tortl/phil*(velocw_poroelastic(1,ibool(i,j,ispec))**2 &
- + velocw_poroelastic(2,ibool(i,j,ispec))**2) &
- + rhol_f*(velocs_poroelastic(1,ibool(i,j,ispec))*velocw_poroelastic(1,ibool(i,j,ispec)) &
- + velocs_poroelastic(2,ibool(i,j,ispec))*velocw_poroelastic(2,ibool(i,j,ispec))) &
- )*wxgll(i)*wzgll(j)*jacobianl / TWO
- else
- kinetic_energy = kinetic_energy &
- + rhol_s*(velocs_poroelastic(1,ibool(i,j,ispec))**2 &
- + velocs_poroelastic(2,ibool(i,j,ispec))**2)*wxgll(i)*wzgll(j)*jacobianl / TWO
- endif
- enddo
- enddo
-
- !---
- !--- acoustic spectral element
- !---
- else
-
- ! for the definition of potential energy in an acoustic fluid, see for instance
- ! equation (23) of M. Maess et al., Journal of Sound and Vibration 296 (2006) 264-276
-
- ! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
- ! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
- ! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
- ! This permits acoustic-elastic coupling based on a non-iterative time scheme.
- ! Displacement is then: u = grad(Chi) / rho
- ! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
- ! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
-
- ! compute pressure in this element
- 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_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
- TURN_ATTENUATION_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_acoustic,npoin_elastic,npoin_poroelastic, &
- ispec,numat,kmato,density,rhoext,assign_external_model)
-
- ! get density of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(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
- do i = 1,NGLLX
-
- !--- if external medium, get density of current grid point
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
-
- jacobianl = jacobian(i,j,ispec)
-
- ! compute kinetic energy
- kinetic_energy = kinetic_energy &
- + 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 * cpl**2)
-
- enddo
- enddo
-
- endif
-
- enddo
-
- ! save kinetic, potential and total energy for this time step in external file
- write(IOUT_ENERGY,*) real(dble(it-1)*deltat - t0,4),real(kinetic_energy,4), &
- real(potential_energy,4),real(kinetic_energy + potential_energy,4)
-
- end subroutine compute_energy
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_forces_acoustic.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_forces_acoustic.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_forces_acoustic.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,762 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- 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,poroelastcoef,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,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top)
-
-! compute forces for the acoustic elements
-
- implicit none
-
- include "constants.h"
-
- integer :: npoin,nspec,nelemabs,numat,it,NSTEP,SIMULATION_TYPE
-
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(nelemabs) :: ib_left
- integer, dimension(nelemabs) :: ib_right
- integer, dimension(nelemabs) :: ib_bottom
- integer, dimension(nelemabs) :: ib_top
-
- 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
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
-
- 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
-
-! Gauss-Lobatto-Legendre weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-!---
-!--- local variables
-!---
-
- 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
- real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_dux_dxl,b_dux_dzl
- real(kind=CUSTOM_REAL) :: weight,xxi,zxi,xgamma,zgamma,jacobian1D
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2
-
-! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,kappal,cpl,rhol
-
- integer :: ifirstelem,ilastelem
-
- 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
-
-! derivative along x and along z
- dux_dxi = ZERO
- dux_dgamma = ZERO
-
- if(SIMULATION_TYPE == 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
- do k = 1,NGLLX
- dux_dxi = dux_dxi + potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
-
- if(SIMULATION_TYPE == 2) then
- 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)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
-! derivatives of potential
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
- endif
-
- jacobianl = jacobian(i,j,ispec)
-
-! if external density model
- if(assign_external_model) rhol = rhoext(i,j,ispec)
-
-! for acoustic medium
-! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl) / rhol
- tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl) / rhol
-
- if(SIMULATION_TYPE == 2) then
- 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
- enddo
-
-!
-! second double-loop over GLL to compute all the terms
-!
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
-! along x direction and z direction
-! and assemble the contributions
- 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(SIMULATION_TYPE == 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))
- endif
- enddo
-
- enddo ! second loop over the GLL points
- enddo
-
- endif ! end of test if acoustic element
-
- enddo ! end of loop over all spectral elements
-
-!
-!--- absorbing boundaries
-!
- if(anyabs) then
-
- do ispecabs=1,nelemabs
-
- ispec = numabs(ispecabs)
-
-! get elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
- rhol = density(1,kmato(ispec))
-
- cpl = sqrt(kappal/rhol)
-
-!--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
-
- i = 1
-
- jbegin = jbegin_left(ispecabs)
- jend = jend_left(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
-! external velocity model
- if(assign_external_model) then
- cpl = vpext(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)
-
- 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/rhol
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- b_absorb_acoustic_left(j,ib_left(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = &
- b_potential_dot_dot_acoustic(iglob) - &
- b_absorb_acoustic_left(j,ib_left(ispecabs),NSTEP-it+1)
- endif
- endif
-
- enddo
-
- endif ! end of left absorbing boundary
-
-!--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
-
- i = NGLLX
-
- jbegin = jbegin_right(ispecabs)
- jend = jend_right(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
-! external velocity model
- if(assign_external_model) then
- cpl = vpext(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)
-
- 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/rhol
-
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- b_absorb_acoustic_right(j,ib_right(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = &
- b_potential_dot_dot_acoustic(iglob) - &
- b_absorb_acoustic_right(j,ib_right(ispecabs),NSTEP-it+1)
- endif
- endif
-
- enddo
-
- endif ! end of right absorbing boundary
-
-!--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
-
- j = 1
-
- ibegin = ibegin_bottom(ispecabs)
- iend = iend_bottom(ispecabs)
-
-! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
-! external velocity model
- if(assign_external_model) then
- cpl = vpext(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)
-
- 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/rhol
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = &
- b_potential_dot_dot_acoustic(iglob) - &
- b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),NSTEP-it+1)
- endif
- endif
-
- enddo
-
- endif ! end of bottom absorbing boundary
-
-!--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
-
- j = NGLLZ
-
- ibegin = ibegin_top(ispecabs)
- iend = iend_top(ispecabs)
-
-! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
-! external velocity model
- if(assign_external_model) then
- cpl = vpext(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)
-
- 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/rhol
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- b_absorb_acoustic_top(i,ib_top(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = &
- b_potential_dot_dot_acoustic(iglob) - &
- b_absorb_acoustic_top(i,ib_top(ispecabs),NSTEP-it+1)
- endif
- endif
-
- enddo
-
- endif ! end of top absorbing boundary
-
- enddo
-
- endif ! end of absorbing boundaries
-
- end subroutine compute_forces_acoustic
-
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine compute_forces_acoustic_2(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, &
- density,poroelastcoef,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, &
- SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
- nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
- b_absorb_acoustic_left,b_absorb_acoustic_right, &
- b_absorb_acoustic_bottom,b_absorb_acoustic_top)
-
-! compute forces for the acoustic elements
-
- implicit none
-
- include "constants.h"
-
- integer :: npoin,nspec,nelemabs,numat,it,NSTEP,SIMULATION_TYPE
-
- 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
-
- double precision, dimension(2,numat) :: density
- double precision, dimension(4,3,numat) :: poroelastcoef
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
-
- logical :: anyabs,assign_external_model
- logical :: SAVE_FORWARD
-
-! 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
-
-! Gauss-Lobatto-Legendre weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(nelemabs) :: ib_left
- integer, dimension(nelemabs) :: ib_right
- integer, dimension(nelemabs) :: ib_bottom
- integer, dimension(nelemabs) :: ib_top
-
- 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
-
-!---
-!--- local variables
-!---
-
- 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
- real(kind=CUSTOM_REAL) :: weight,xxi,zxi,xgamma,zgamma,jacobian1D
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2
-
-! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,kappal,cpl,rhol
-
- integer :: ifirstelem,ilastelem
-
- 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
-
- ! derivative along x and along z
- dux_dxi = ZERO
- dux_dgamma = ZERO
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- ! derivatives of potential
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
- jacobianl = jacobian(i,j,ispec)
-
- ! if external density model
- if(assign_external_model) rhol = rhoext(i,j,ispec)
-
- ! for acoustic medium
- ! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl) / rhol
- tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl) / rhol
- enddo
- enddo
-
-!
-! second double-loop over GLL to compute all the terms
-!
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- ! along x direction and z direction
- ! and assemble the contributions
- 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))
- enddo
-
- enddo ! second loop over the GLL points
- enddo
-
- endif ! end of test if acoustic element
-
- enddo ! end of loop over all spectral elements
-
-!
-!--- absorbing boundaries
-!
- if(anyabs) then
-
- do ispecabs=1,nelemabs
-
- ispec = numabs(ispecabs)
-
- ! Sommerfeld condition if acoustic
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
-
- ! get elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
- rhol = density(1,kmato(ispec))
-
- cpl = sqrt(kappal/rhol)
-
- !--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
- i = 1
- jbegin = jbegin_left(ispecabs)
- jend = jend_left(ispecabs)
- do j = jbegin,jend
- iglob = ibool(i,j,ispec)
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(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)
- weight = jacobian1D * wzgll(j)
-
- if( SIMULATION_TYPE == 1 ) then
- ! adds absorbing boundary contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- ! adds (previously) stored contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - b_absorb_acoustic_left(j,ib_left(ispecabs),NSTEP-it+1)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- ! saves contribution
- b_absorb_acoustic_left(j,ib_left(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- endif
-
- enddo
-
- endif ! end of left absorbing boundary
-
- !--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
- i = NGLLX
- jbegin = jbegin_right(ispecabs)
- jend = jend_right(ispecabs)
- do j = jbegin,jend
- iglob = ibool(i,j,ispec)
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(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)
- weight = jacobian1D * wzgll(j)
-
- if( SIMULATION_TYPE == 1 ) then
- ! adds absorbing boundary contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - b_absorb_acoustic_right(j,ib_right(ispecabs),NSTEP-it+1)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- ! saves contribution
- b_absorb_acoustic_right(j,ib_right(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- endif
- enddo
- endif ! end of right absorbing boundary
-
- !--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
- j = 1
- ibegin = ibegin_bottom(ispecabs)
- iend = iend_bottom(ispecabs)
- ! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
- do i = ibegin,iend
- iglob = ibool(i,j,ispec)
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(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)
- weight = jacobian1D * wxgll(i)
-
- if( SIMULATION_TYPE == 1 ) then
- ! adds absorbing boundary contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),NSTEP-it+1)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- ! saves contribution
- b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- endif
- enddo
- endif ! end of bottom absorbing boundary
-
- !--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
- j = NGLLZ
- ibegin = ibegin_top(ispecabs)
- iend = iend_top(ispecabs)
- ! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
- do i = ibegin,iend
- iglob = ibool(i,j,ispec)
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(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)
- weight = jacobian1D * wxgll(i)
-
- if( SIMULATION_TYPE == 1 ) then
- ! adds absorbing boundary contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - b_absorb_acoustic_top(i,ib_top(ispecabs),NSTEP-it+1)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- ! saves contribution
- b_absorb_acoustic_top(i,ib_top(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- endif
- enddo
- endif ! end of top absorbing boundary
-
- endif ! acoustic ispec
- enddo
- endif ! end of absorbing boundaries
-
- end subroutine compute_forces_acoustic_2
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_fluid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_fluid.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_fluid.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,940 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.3
-! ------------------------------
-!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_forces_poro_fluid(npoin,nspec,myrank,nelemabs,numat, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
- source_type,it,NSTEP,anyabs, &
- initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
- accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
- b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
- density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
- jacobian,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_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,&
- C_k,M_k,NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,f0,freq0,Q0)
-
-! compute forces for the fluid poroelastic part
-
- implicit none
-
- include "constants.h"
- integer :: NSOURCES, i_source
- integer, dimension(NSOURCES) ::ispec_selected_source,source_type,is_proc_source
- integer :: npoin,nspec,nelemabs,numat,it,NSTEP
- integer :: nrec,SIMULATION_TYPE,myrank
- integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(nelemabs) :: ib_left
- integer, dimension(nelemabs) :: ib_right
- integer, dimension(nelemabs) :: ib_bottom
- integer, dimension(nelemabs) :: ib_top
-
- logical :: anyabs,initialfield,TURN_ATTENUATION_ON
- logical :: SAVE_FORWARD
-
- double precision ::deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
-
- 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
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic
- double precision, dimension(2,numat) :: density
- double precision, dimension(3,numat) :: permeability
- 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
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
- real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
- real(kind=CUSTOM_REAL), dimension(npoin) :: C_k,M_k
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_poro_w_left
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_poro_w_right
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmax,NSTEP) :: b_absorb_poro_w_top
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmin,NSTEP) :: b_absorb_poro_w_bottom
- real(kind=CUSTOM_REAL), dimension(npoin) :: b_viscodampx,b_viscodampz
-
- integer :: N_SLS
- 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) :: &
- dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
-
-! viscous attenuation
- double precision, dimension(NGLLX,NGLLZ,nspec) :: rx_viscous
- double precision, dimension(NGLLX,NGLLZ,nspec) :: rz_viscous
- double precision :: theta_e,theta_s
- logical TURN_VISCATTENUATION_ON
- double precision, dimension(3):: bl_unrelaxed,bl_relaxed
-
-! 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
-
-! Gauss-Lobatto-Legendre weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-!
- double precision :: f0,freq0,Q0,w_c
-
-
-!---
-!--- local variables
-!---
-
- 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
- real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
- real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
- real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
- real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
- real(kind=CUSTOM_REAL) :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
- real(kind=CUSTOM_REAL) :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
- real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xz,sigma_zz
- real(kind=CUSTOM_REAL) :: sigmap
- real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xz,b_sigma_zz
- real(kind=CUSTOM_REAL) :: b_sigmap
- real(kind=CUSTOM_REAL) :: nx,nz,vx,vz,vn,vxf,vzf,vnf,rho_vpI,rho_vpII,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1p,tempx2p,tempz1p,tempz2p
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempz1,b_tempz2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1p,b_tempx2p,b_tempz1p,b_tempz2p
-
-
-! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the poroelastic medium
- real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
- 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
- real(kind=CUSTOM_REAL) :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
- real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
-
- real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
- real(kind=CUSTOM_REAL) :: cpIsquare,cpIIsquare,cssquare,cpIl,cpIIl,csl
-
-! for attenuation
- real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
-
-! 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)
-
-! loop over spectral elements
- do ispec = 1,nspec
-
-!---
-!--- poroelastic spectral element
-!---
-
- if(poroelastic(ispec)) then
-
-! get poroelastic properties 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)
-!The RHS has the form : div T_f -rho_f/rho_bar div T - eta_fk^-1.partial t w
-!where T = G:grad u_s + C_biot div w I
-!and T_f = C_biot div u_s I + M_biot div w I
- mul_G = mul_fr
- lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
- lambdalplus2mul_G = lambdal_G + TWO*mul_G
-
-! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
-
-! derivative along x and along z for u_s and w
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
-
- b_dwx_dxi = ZERO
- b_dwz_dxi = ZERO
-
- b_dwx_dgamma = ZERO
- b_dwz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- if(SIMULATION_TYPE == 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)
- b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
-
- dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
-
- b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
- b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
-
- b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
- b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
- endif
-
-! compute stress tensor (include attenuation 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
-! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
-! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
-
-! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_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 + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
- 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
- e11_sum = 0._CUSTOM_REAL
- e13_sum = 0._CUSTOM_REAL
-
- do i_sls = 1,N_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 + TWO * mul_G * e11_sum
- sigma_xz = sigma_xz + mul_G * e13_sum
- sigma_zz = sigma_zz - TWO * mul_G * e11_sum
-
- else
-
-! no attenuation
- sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = mul_G*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
- b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
-
- b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
- endif
- endif
-
-! kernels calculation
- if(SIMULATION_TYPE == 2) then
- iglob = ibool(i,j,ispec)
- C_k(iglob) = ((dux_dxl + duz_dzl) * (b_dwx_dxl + b_dwz_dzl) + &
- (dwx_dxl + dwz_dzl) * (b_dux_dxl + b_duz_dzl)) * C_biot
- M_k(iglob) = (dwx_dxl + dwz_dzl) * (b_dwx_dxl + b_dwz_dzl) * M_biot
- endif
-
- jacobianl = jacobian(i,j,ispec)
-
-! weak formulation term based on stress tensor (non-symmetric form)
-! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
- tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
-
- tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
- tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
-
- tempx1p(i,j) = wzgll(j)*jacobianl*sigmap*xixl
- tempz1p(i,j) = wzgll(j)*jacobianl*sigmap*xizl
-
- tempx2p(i,j) = wxgll(i)*jacobianl*sigmap*gammaxl
- tempz2p(i,j) = wxgll(i)*jacobianl*sigmap*gammazl
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
- b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
-
- b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
- b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
-
- b_tempx1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xixl
- b_tempz1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xizl
-
- b_tempx2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammaxl
- b_tempz2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammazl
- endif
-
- enddo
- enddo
-
-!
-! second double-loop over GLL to compute all the terms
-!
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
-! along x direction and z direction
-! and assemble the contributions
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) + ( (rhol_f/rhol_bar*tempx1(k,j) - tempx1p(k,j)) &
- *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*tempx2(i,k) - tempx2p(i,k))*hprimewgll_zz(k,j) )
-
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + ( (rhol_f/rhol_bar*tempz1(k,j) - tempz1p(k,j)) &
- *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*tempz2(i,k) - tempz2p(i,k))*hprimewgll_zz(k,j) )
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) + ( (rhol_f/rhol_bar*b_tempx1(k,j) - b_tempx1p(k,j)) &
- *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*b_tempx2(i,k) - b_tempx2p(i,k))*hprimewgll_zz(k,j) )
-
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + ( (rhol_f/rhol_bar*b_tempz1(k,j) - b_tempz1p(k,j)) &
- *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*b_tempz2(i,k) - b_tempz2p(i,k))*hprimewgll_zz(k,j) )
- endif
-
- enddo
-
- enddo ! second loop over the GLL points
- enddo
-
- endif ! end of test if poroelastic element
-
- enddo ! end of loop over all spectral elements
-
-!
-!---- viscous damping
-!
-! add - eta_f k^-1 dot(w)
-
-! loop over spectral elements
- do ispec = 1,nspec
-
- etal_f = poroelastcoef(2,2,kmato(ispec))
-
- if(poroelastic(ispec) .and. etal_f > 0.d0) then
-
- permlxx = permeability(1,kmato(ispec))
- permlxz = permeability(2,kmato(ispec))
- permlzz = permeability(3,kmato(ispec))
-
-! calcul of the inverse of k
- detk = permlxx*permlzz - permlxz*permlxz
-
- if(detk /= ZERO) then
- invpermlxx = permlzz/detk
- invpermlxz = -permlxz/detk
- invpermlzz = permlxx/detk
- else
- stop 'Permeability matrix is not invertible'
- endif
-
-! relaxed viscous coef
- bl_relaxed(1) = etal_f*invpermlxx
- bl_relaxed(2) = etal_f*invpermlxz
- bl_relaxed(3) = etal_f*invpermlzz
-
- if(TURN_VISCATTENUATION_ON) then
- bl_unrelaxed(1) = etal_f*invpermlxx*theta_e/theta_s
- bl_unrelaxed(2) = etal_f*invpermlxz*theta_e/theta_s
- bl_unrelaxed(3) = etal_f*invpermlzz*theta_e/theta_s
- endif
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- if(TURN_VISCATTENUATION_ON) then
-! compute the viscous damping term with the unrelaxed viscous coef and add memory variable
- viscodampx = velocw_poroelastic(1,iglob)*bl_unrelaxed(1) + velocw_poroelastic(2,iglob)*bl_unrelaxed(2)&
- - rx_viscous(i,j,ispec)
- viscodampz = velocw_poroelastic(1,iglob)*bl_unrelaxed(2) + velocw_poroelastic(2,iglob)*bl_unrelaxed(3)&
- - rz_viscous(i,j,ispec)
- else
-! no viscous attenuation
- viscodampx = velocw_poroelastic(1,iglob)*bl_relaxed(1) + velocw_poroelastic(2,iglob)*bl_relaxed(2)
- viscodampz = velocw_poroelastic(1,iglob)*bl_relaxed(2) + velocw_poroelastic(2,iglob)*bl_relaxed(3)
- endif
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
- viscodampx
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
- viscodampz
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_viscodampx(iglob) = wxgll(i)*wzgll(j)*jacobian(i,j,ispec) * viscodampx
- b_viscodampz(iglob) = wxgll(i)*wzgll(j)*jacobian(i,j,ispec) * viscodampz
- elseif(SIMULATION_TYPE == 2) then ! kernels calculation
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - b_viscodampx(iglob)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - b_viscodampz(iglob)
- endif
-
- enddo
- enddo
-
- endif ! end of test if poroelastic element
-
- enddo ! end of loop over all spectral elements
-
-
-!
-!--- absorbing boundaries
-!
- if(anyabs) then
-
- do ispecabs=1,nelemabs
-
- ispec = numabs(ispecabs)
-
- if (poroelastic(ispec)) then
-! get poroelastic parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- permlxx = permeability(1,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))
- etal_f = poroelastcoef(2,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)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
- tortl,rhol_s,rhol_f,etal_f,permlxx,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIl = sqrt(cpIsquare)
- cpIIl = sqrt(cpIIsquare)
- csl = sqrt(cssquare)
-
-!--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
-
- i = 1
-
- jbegin = jbegin_left_poro(ispecabs)
- jend = jend_left_poro(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
- 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)
-
- rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
- rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
- rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
- tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_w_left(1,j,ib_left(ispecabs),it) = tx*weight
- b_absorb_poro_w_left(2,j,ib_left(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
- b_absorb_poro_w_left(1,j,ib_left(ispecabs),NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
- b_absorb_poro_w_left(2,j,ib_left(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of left absorbing boundary
-
-!--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
-
- i = NGLLX
-
- jbegin = jbegin_right_poro(ispecabs)
- jend = jend_right_poro(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
- 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)
-
-
- rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
- rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
- rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
- tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_w_right(1,j,ib_right(ispecabs),it) = tx*weight
- b_absorb_poro_w_right(2,j,ib_right(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
- b_absorb_poro_w_right(1,j,ib_right(ispecabs),NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
- b_absorb_poro_w_right(2,j,ib_right(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of right absorbing boundary
-
-!--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
-
- 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(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)
- 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)
-
-
- rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
- rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
- rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
- tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_w_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
- b_absorb_poro_w_bottom(2,i,ib_bottom(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
- b_absorb_poro_w_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
- b_absorb_poro_w_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of bottom absorbing boundary
-
-!--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
-
- 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(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)
- 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)
-
-
- rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
- rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
- rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
- tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_w_top(1,i,ib_top(ispecabs),it) = tx*weight
- b_absorb_poro_w_top(2,i,ib_top(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
- b_absorb_poro_w_top(1,i,ib_top(ispecabs),NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
- b_absorb_poro_w_top(2,i,ib_top(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of top absorbing boundary
-
- endif ! if poroelastic(ispec)
- enddo
-
- endif ! end of absorbing boundaries
-
-
-! --- add the source
- if(.not. initialfield) then
- do i_source=1,NSOURCES
-! 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
-
- phil = porosity(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
-
-! moment tensor
- if(source_type(i_source) == 2) then
-
-! add source array
- if(SIMULATION_TYPE == 1) then ! forward wavefield
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- accelw_poroelastic(:,iglob) = accelw_poroelastic(:,iglob) + &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
- enddo
- enddo
- else ! backward wavefield
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- b_accelw_poroelastic(:,iglob) = b_accelw_poroelastic(:,iglob) + &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*sourcearray(i_source,:,i,j)*source_time_function(i_source,NSTEP-it+1)
- enddo
- enddo
- endif !endif SIMULATION_TYPE == 1
-
- endif !if(source_type(i_source) == 2)
-
- endif ! if this processor carries the source and the source element is poroelastic
- enddo
-
- if(SIMULATION_TYPE == 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
-
- irec_local = irec_local + 1
- if(poroelastic(ispec_selected_rec(irec))) then
- phil = porosity(kmato(ispec_selected_rec(irec)))
- rhol_s = density(1,kmato(ispec_selected_rec(irec)))
- rhol_f = density(2,kmato(ispec_selected_rec(irec)))
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-! add source array
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_rec(irec))
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - &
- rhol_f/rhol_bar*adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - &
- rhol_f/rhol_bar*adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
- enddo
- enddo
- endif ! if element is poroelastic
-
- endif ! if this processor carries the adjoint source and the source element is poroelastic
- enddo ! irec = 1,nrec
- endif ! SIMULATION_TYPE == 2 adjoint wavefield
-
- endif ! if not using an initial field
-
-! implement attenuation
- if(TURN_ATTENUATION_ON) then
-
-! 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)
-
-! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
-! loop over spectral elements
- do ispec = 1,nspec
-
- if (poroelastic(ispec)) then
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
- theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
- theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
-
-! loop on all the standard linear solids
- do i_sls = 1,N_SLS
-
-! 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,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,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) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e11(i,j,ispec,i_sls) = Unp1
-
-! evolution e13
- Un = e13(i,j,ispec,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,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) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e13(i,j,ispec,i_sls) = Unp1
-
- enddo
-
- enddo
- enddo
- endif
- enddo
-
- endif ! end of test on attenuation
-
- end subroutine compute_forces_poro_fluid
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_solid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_solid.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_solid.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,957 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.3
-! ------------------------------
-!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_forces_poro_solid(npoin,nspec,myrank,nelemabs,numat, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
- source_type,it,NSTEP,anyabs, &
- initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,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_displw_poroelastic,&
- density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
- 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_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,&
- mufr_k,B_k,NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,f0,freq0,Q0)
-
-! compute forces for the solid poroelastic part
-
- implicit none
-
- include "constants.h"
- integer :: NSOURCES, i_source
- integer, dimension(NSOURCES) :: ispec_selected_source,source_type,is_proc_source
- integer :: npoin,nspec,nelemabs,numat,it,NSTEP
- integer :: nrec,SIMULATION_TYPE,myrank
- integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(nelemabs) :: ib_left
- integer, dimension(nelemabs) :: ib_right
- integer, dimension(nelemabs) :: ib_bottom
- integer, dimension(nelemabs) :: ib_top
-
- logical :: anyabs,initialfield,TURN_ATTENUATION_ON
- logical :: SAVE_FORWARD
-
- double precision :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
-
- 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
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accels_poroelastic,b_displs_poroelastic,b_displw_poroelastic
- double precision, dimension(2,numat) :: density
- double precision, dimension(3,numat) :: permeability
- 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
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
- real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
- real(kind=CUSTOM_REAL), dimension(npoin) :: mufr_k,B_k
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_poro_s_left
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_poro_s_right
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmax,NSTEP) :: b_absorb_poro_s_top
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmin,NSTEP) :: b_absorb_poro_s_bottom
- real(kind=CUSTOM_REAL), dimension(npoin) :: b_viscodampx,b_viscodampz
-
- integer :: N_SLS
- 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) :: &
- dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
-
-! viscous attenuation (poroelastic media)
- double precision, dimension(NGLLX,NGLLZ,nspec) :: rx_viscous
- double precision, dimension(NGLLX,NGLLZ,nspec) :: rz_viscous
- double precision :: theta_e,theta_s
- logical TURN_VISCATTENUATION_ON
- double precision, dimension(3):: bl_unrelaxed,bl_relaxed
-
-! 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
-
-! Gauss-Lobatto-Legendre weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-!
- double precision :: f0,freq0,Q0,w_c
-
-!---
-!--- local variables
-!---
-
- 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
- real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
- real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
- real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
- real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
- real(kind=CUSTOM_REAL) :: dsxx,dsxz,dszz
- real(kind=CUSTOM_REAL) :: b_dsxx,b_dsxz,b_dszz
- real(kind=CUSTOM_REAL) :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
- real(kind=CUSTOM_REAL) :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
- real(kind=CUSTOM_REAL) :: dwxx,dwxz,dwzz
- real(kind=CUSTOM_REAL) :: b_dwxx,b_dwxz,b_dwzz
- real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xz,sigma_zz
- real(kind=CUSTOM_REAL) :: sigmap
- real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xz,b_sigma_zz
- real(kind=CUSTOM_REAL) :: b_sigmap
- real(kind=CUSTOM_REAL) :: nx,nz,vx,vz,vn,vxf,vzf,vnf,rho_vpI,rho_vpII,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1p,tempx2p,tempz1p,tempz2p
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempz1,b_tempz2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1p,b_tempx2p,b_tempz1p,b_tempz2p
-
-! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the poroelastic medium
- real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
- 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
- real(kind=CUSTOM_REAL) :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
- real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
-
- real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
- real(kind=CUSTOM_REAL) :: cpIsquare,cpIIsquare,cssquare,cpIl,cpIIl,csl
-
-! for attenuation
- real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
-
-! 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)
-
-! loop over spectral elements
- do ispec = 1,nspec
-
-!---
-!--- poroelastic spectral element
-!---
-
- if(poroelastic(ispec)) then
-
-! get poroelastic parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - 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)
-!The RHS has the form : div T -phi/c div T_f + phi/ceta_fk^-1.partial t w
-!where T = G:grad u_s + C_biot div w I
-!and T_f = C_biot div u_s I + M_biot div w I
- mul_G = mul_fr
- lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
- lambdalplus2mul_G = lambdal_G + TWO*mul_G
-
-! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
-! derivative along x and along z for u_s and w
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
-
- b_dwx_dxi = ZERO
- b_dwz_dxi = ZERO
-
- b_dwx_dgamma = ZERO
- b_dwz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- if(SIMULATION_TYPE == 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)
- b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
-
- dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
-
- b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
- b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
-
- b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
- b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
- endif
-
-! 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
-! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
-! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
-
-! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_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 + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
- 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
- e11_sum = 0._CUSTOM_REAL
- e13_sum = 0._CUSTOM_REAL
-
- do i_sls = 1,N_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 + TWO * mul_G * e11_sum
- sigma_xz = sigma_xz + mul_G * e13_sum
- sigma_zz = sigma_zz - TWO * mul_G * e11_sum
-
- else
-
-! no attenuation
- sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = mul_G*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
- b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
-
- b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
- endif
- endif
-
-! kernels calculation
- if(SIMULATION_TYPE == 2) then
- iglob = ibool(i,j,ispec)
- dsxx = dux_dxl
- dsxz = HALF * (duz_dxl + dux_dzl)
- dszz = duz_dzl
-
- dwxx = dwx_dxl
- dwxz = HALF * (dwz_dxl + dwx_dzl)
- dwzz = dwz_dzl
-
- b_dsxx = b_dux_dxl
- b_dsxz = HALF * (b_duz_dxl + b_dux_dzl)
- b_dszz = b_duz_dzl
-
- b_dwxx = b_dwx_dxl
- b_dwxz = HALF * (b_dwz_dxl + b_dwx_dzl)
- b_dwzz = b_dwz_dzl
-
- B_k(iglob) = (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl) * (H_biot - FOUR_THIRDS * mul_fr)
- mufr_k(iglob) = (dsxx * b_dsxx + dszz * b_dszz + &
- 2._CUSTOM_REAL * dsxz * b_dsxz - &
- 1._CUSTOM_REAL/3._CUSTOM_REAL * (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl) ) * mul_fr
- endif
-
- jacobianl = jacobian(i,j,ispec)
-
-! weak formulation term based on stress tensor (non-symmetric form)
-! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
- tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
-
- tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
- tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
-
- tempx1p(i,j) = wzgll(j)*jacobianl*sigmap*xixl
- tempz1p(i,j) = wzgll(j)*jacobianl*sigmap*xizl
-
- tempx2p(i,j) = wxgll(i)*jacobianl*sigmap*gammaxl
- tempz2p(i,j) = wxgll(i)*jacobianl*sigmap*gammazl
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
- b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
-
- b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
- b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
-
- b_tempx1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xixl
- b_tempz1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xizl
-
- b_tempx2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammaxl
- b_tempz2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammazl
- endif
-
- enddo
- enddo
-
-!
-! second double-loop over GLL to compute all the terms
-!
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
-! along x direction and z direction
-! and assemble the contributions
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - ( (tempx1(k,j) - phil/tortl*tempx1p(k,j)) &
- *hprimewgll_xx(k,i) + (tempx2(i,k) - phil/tortl*tempx2p(i,k))*hprimewgll_zz(k,j) )
-
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - ( (tempz1(k,j) - phil/tortl*tempz1p(k,j)) &
- *hprimewgll_xx(k,i) + (tempz2(i,k) - phil/tortl*tempz2p(i,k))*hprimewgll_zz(k,j) )
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - ( (b_tempx1(k,j) - phil/tortl*b_tempx1p(k,j)) &
- *hprimewgll_xx(k,i) + (b_tempx2(i,k) - phil/tortl*b_tempx2p(i,k))*hprimewgll_zz(k,j) )
-
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - ( (b_tempz1(k,j) - phil/tortl*b_tempz1p(k,j)) &
- *hprimewgll_xx(k,i) + (b_tempz2(i,k) - phil/tortl*b_tempz2p(i,k))*hprimewgll_zz(k,j) )
- endif
-
- enddo
-
- enddo ! second loop over the GLL points
- enddo
-
- endif ! end of test if poroelastic element
-
- enddo ! end of loop over all spectral elements
-
-!
-!---- viscous damping
-!
-! add + phi/tort eta_f k^-1 dot(w)
-
-! loop over spectral elements
- do ispec = 1,nspec
-
- etal_f = poroelastcoef(2,2,kmato(ispec))
-
- if(poroelastic(ispec) .and. etal_f >0.d0) then
-
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- permlxx = permeability(1,kmato(ispec))
- permlxz = permeability(2,kmato(ispec))
- permlzz = permeability(3,kmato(ispec))
-
-! calcul of the inverse of k
- detk = permlxx*permlzz - permlxz*permlxz
-
- if(detk /= ZERO) then
- invpermlxx = permlzz/detk
- invpermlxz = -permlxz/detk
- invpermlzz = permlxx/detk
- else
- stop 'Permeability matrix is not invertible'
- endif
-
-! relaxed viscous coef
- bl_relaxed(1) = etal_f*invpermlxx
- bl_relaxed(2) = etal_f*invpermlxz
- bl_relaxed(3) = etal_f*invpermlzz
-
- if(TURN_VISCATTENUATION_ON) then
- bl_unrelaxed(1) = etal_f*invpermlxx*theta_e/theta_s
- bl_unrelaxed(2) = etal_f*invpermlxz*theta_e/theta_s
- bl_unrelaxed(3) = etal_f*invpermlzz*theta_e/theta_s
- endif
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- if(TURN_VISCATTENUATION_ON) then
-! compute the viscous damping term with the unrelaxed viscous coef and add memory variable
- viscodampx = velocw_poroelastic(1,iglob)*bl_unrelaxed(1) + velocw_poroelastic(2,iglob)*bl_unrelaxed(2)&
- - rx_viscous(i,j,ispec)
- viscodampz = velocw_poroelastic(1,iglob)*bl_unrelaxed(2) + velocw_poroelastic(2,iglob)*bl_unrelaxed(3)&
- - rz_viscous(i,j,ispec)
- else
-! no viscous attenuation
- viscodampx = velocw_poroelastic(1,iglob)*bl_relaxed(1) + velocw_poroelastic(2,iglob)*bl_relaxed(2)
- viscodampz = velocw_poroelastic(1,iglob)*bl_relaxed(2) + velocw_poroelastic(2,iglob)*bl_relaxed(3)
- endif
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + phil/tortl*wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
- viscodampx
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + phil/tortl*wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
- viscodampz
-
-! if SIMULATION_TYPE == 1 .and. SAVE_FORWARD then b_viscodamp is saved in compute_forces_poro_fluid.f90
- if(SIMULATION_TYPE == 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)
- endif
-
- enddo
- enddo
-
- endif ! end of test if poroelastic element
-
- enddo ! end of loop over all spectral elements
-
-
-!
-!--- absorbing boundaries
-!
- if(anyabs) then
-
- do ispecabs = 1,nelemabs
-
- ispec = numabs(ispecabs)
-
- if (poroelastic(ispec)) then
-
-! get poroelastic parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- permlxx = permeability(1,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))
- etal_f = poroelastcoef(2,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)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
- tortl,rhol_s,rhol_f,etal_f,permlxx,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIl = sqrt(cpIsquare)
- cpIIl = sqrt(cpIIsquare)
- csl = sqrt(cssquare)
-
-!--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
-
- i = 1
-
- jbegin = jbegin_left_poro(ispecabs)
- jend = jend_left_poro(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
-
- 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)
-
- 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
-
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
- tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_s_left(1,j,ib_left(ispecabs),it) = tx*weight
- b_absorb_poro_s_left(2,j,ib_left(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
- b_absorb_poro_s_left(1,j,ib_left(ispecabs),NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
- b_absorb_poro_s_left(2,j,ib_left(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of left absorbing boundary
-
-!--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
-
- i = NGLLX
-
- jbegin = jbegin_right_poro(ispecabs)
- jend = jend_right_poro(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
- 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)
-
-
- 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
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
- tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_s_right(1,j,ib_right(ispecabs),it) = tx*weight
- b_absorb_poro_s_right(2,j,ib_right(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
- b_absorb_poro_s_right(1,j,ib_right(ispecabs),NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
- b_absorb_poro_s_right(2,j,ib_right(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of right absorbing boundary
-
-!--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
-
- 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(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)
- 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)
-
-
- 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
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
- tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_s_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
- b_absorb_poro_s_bottom(2,i,ib_bottom(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
- b_absorb_poro_s_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
- b_absorb_poro_s_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of bottom absorbing boundary
-
-!--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
-
- 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(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)
- 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)
-
-
- 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
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
- tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_s_top(1,i,ib_top(ispecabs),it) = tx*weight
- b_absorb_poro_s_top(2,i,ib_top(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
- b_absorb_poro_s_top(1,i,ib_top(ispecabs),NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
- b_absorb_poro_s_top(2,i,ib_top(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of top absorbing boundary
-
- endif ! if poroelastic(ispec)
-
- enddo
-
- endif ! end of absorbing boundaries
-
-
-! --- add the source
- if(.not. initialfield) then
- do i_source=1,NSOURCES
-
-! 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
-
- phil = porosity(kmato(ispec_selected_source(i_source)))
- tortl = tortuosity(kmato(ispec_selected_source(i_source)))
-
-! moment tensor
- if(source_type(i_source) == 2) then
-
-! add source array
- if(SIMULATION_TYPE == 1) then ! forward wavefield
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- accels_poroelastic(:,iglob) = accels_poroelastic(:,iglob) + &
- (1._CUSTOM_REAL - phil/tortl)*sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
- enddo
- enddo
- else ! backward wavefield
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- 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
- endif !endif SIMULATION_TYPE == 1
-
- endif !if(source_type(i_source) == 2)
-
- endif ! if this processor carries the source and the source element is poroelastic
- enddo
-
- if(SIMULATION_TYPE == 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
-
- irec_local = irec_local + 1
- if(poroelastic(ispec_selected_rec(irec))) then
-! add source array
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_rec(irec))
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
- enddo
- enddo
- endif ! if element is poroelastic
-
- endif ! if this processor carries the adjoint source and the source element is poroelastic
- enddo ! irec = 1,nrec
- endif ! SIMULATION_TYPE == 2 adjoint wavefield
-
- endif ! if not using an initial field
-
-! implement attenuation
- if(TURN_ATTENUATION_ON) then
-
-! 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)
-
-! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
-! loop over spectral elements
- do ispec = 1,nspec
-
- if (poroelastic(ispec)) then
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
- theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
- theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
-
-! loop on all the standard linear solids
- do i_sls = 1,N_SLS
-
-! 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,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,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) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e11(i,j,ispec,i_sls) = Unp1
-
-! evolution e13
- Un = e13(i,j,ispec,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,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) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e13(i,j,ispec,i_sls) = Unp1
-
- enddo
-
- enddo
- enddo
- endif
- enddo
-
- endif ! end of test on attenuation
-
-
- end subroutine compute_forces_poro_solid
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_forces_viscoelastic.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_forces_viscoelastic.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_forces_viscoelastic.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,988 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-subroutine compute_forces_viscoelastic(p_sv,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,angleforce,deltatcube, &
- 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,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy, &
- 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, &
- 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,NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,mu_k,kappa_k)
-
- ! compute forces for the elastic elements
-
- implicit none
-
- include "constants.h"
-
- logical :: p_sv
- integer :: NSOURCES, i_source
- integer :: npoin,nspec,myrank,nelemabs,numat,it,NSTEP
- integer, dimension(NSOURCES) :: ispec_selected_source,is_proc_source,source_type
-
- integer :: nrec,SIMULATION_TYPE
- integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(nelemabs) :: ib_left
- integer, dimension(nelemabs) :: ib_right
- integer, dimension(nelemabs) :: ib_bottom
- integer, dimension(nelemabs) :: ib_top
-
- logical :: anyabs,assign_external_model,initialfield,TURN_ATTENUATION_ON,add_Bielak_conditions
-
- logical :: SAVE_FORWARD
-
- double precision :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
- double precision, dimension(NSOURCES) :: angleforce
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: kmato
- integer, dimension(nelemabs) :: numabs
-
- logical, dimension(nspec) :: elastic,anisotropic
- logical, dimension(4,nelemabs) :: codeabs
-
- real(kind=CUSTOM_REAL), dimension(3,npoin) :: accel_elastic,veloc_elastic,displ_elastic
- double precision, dimension(2,numat) :: density
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(6,numat) :: anisotropy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
- double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
-
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
-
- real(kind=CUSTOM_REAL), dimension(3,npoin) :: b_accel_elastic,b_displ_elastic
- real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
- real(kind=CUSTOM_REAL), dimension(npoin) :: mu_k,kappa_k
- real(kind=CUSTOM_REAL), dimension(3,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_elastic_left
- real(kind=CUSTOM_REAL), dimension(3,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_elastic_right
- real(kind=CUSTOM_REAL), dimension(3,NGLLX,nspec_zmax,NSTEP) :: b_absorb_elastic_top
- real(kind=CUSTOM_REAL), dimension(3,NGLLX,nspec_zmin,NSTEP) :: b_absorb_elastic_bottom
-
- integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11,e13
- 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
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: &
- dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
-
- ! 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
-
- ! Gauss-Lobatto-Legendre weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-
- !---
- !--- local variables
- !---
-
- integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,irec,irec_local
-
- ! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duy_dxi,duy_dgamma,duz_dxi,duz_dgamma
- real(kind=CUSTOM_REAL) :: dux_dxl,duy_dxl,duz_dxl,dux_dzl,duy_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duy_dxi,b_duy_dgamma,b_duz_dxi,b_duz_dgamma
- real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duy_dxl,b_duz_dxl,b_dux_dzl,b_duy_dzl,b_duz_dzl
- real(kind=CUSTOM_REAL) :: dsxx,dsxz,dszz
- real(kind=CUSTOM_REAL) :: b_dsxx,b_dsxz,b_dszz
- real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xy,sigma_xz,sigma_zy,sigma_zz
- real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xy,b_sigma_xz,b_sigma_zy,b_sigma_zz
- real(kind=CUSTOM_REAL) :: nx,nz,vx,vy,vz,vn,rho_vp,rho_vs,tx,ty,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempy1,tempy2,tempz1,tempz2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempy1,b_tempy2,b_tempz1,b_tempz2
-
- ! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
- ! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal,cpl,csl,rhol, &
- lambdal_unrelaxed,mul_unrelaxed,lambdalplus2mul_unrelaxed
-
- ! for attenuation
- real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
-
- ! for anisotropy
- double precision :: c11,c15,c13,c33,c35,c55
-
- ! for analytical initial plane wave for Bielak's conditions
- double precision :: veloc_horiz,veloc_vert,dxUx,dzUx,dxUz,dzUz,traction_x_t0,traction_z_t0,deltat
- 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_bottom
-
- integer :: ifirstelem,ilastelem
-
- ! compute Grad(displ_elastic) at time step n for attenuation
- if(TURN_ATTENUATION_ON) then
- 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 = ifirstelem,ilastelem
-
- tempx1(:,:) = ZERO
- tempy1(:,:) = ZERO
- tempz1(:,:) = ZERO
- tempx2(:,:) = ZERO
- tempy2(:,:) = ZERO
- tempz2(:,:) = ZERO
- if(SIMULATION_TYPE ==2)then
- b_tempx1(:,:) = ZERO
- b_tempy1(:,:) = ZERO
- b_tempz1(:,:) = ZERO
- b_tempx2(:,:) = ZERO
- b_tempy2(:,:) = ZERO
- b_tempz2(:,:) = ZERO
- endif
-
- !---
- !--- elastic spectral element
- !---
- 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))
-
- ! first double loop over GLL points to compute and store gradients
- 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)
- rhol = rhoext(i,j,ispec)
- mul_relaxed = rhol*csl*csl
- lambdal_relaxed = rhol*cpl*cpl - TWO*mul_relaxed
- lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
- endif
-
- ! derivative along x and along z
- dux_dxi = ZERO
- duy_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duy_dgamma = ZERO
- duz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
- b_dux_dxi = ZERO
- b_duy_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duy_dgamma = ZERO
- b_duz_dgamma = ZERO
- endif
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duy_dxi = duy_dxi + displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duy_dgamma = duy_dgamma + displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
-
- if(SIMULATION_TYPE == 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_duy_dxi = b_duy_dxi + b_displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- b_duz_dxi = b_duz_dxi + b_displ_elastic(3,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_duy_dgamma = b_duy_dgamma + b_displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- ! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duy_dxl = duy_dxi*xixl + duy_dgamma*gammaxl
- duy_dzl = duy_dxi*xizl + duy_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 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
-
- b_duy_dxl = b_duy_dxi*xixl + b_duy_dgamma*gammaxl
- b_duy_dzl = b_duy_dxi*xizl + b_duy_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
- endif
-
- ! compute stress tensor (include attenuation or anisotropy if needed)
-
- if(TURN_ATTENUATION_ON) then
-
- ! attenuation is implemented following the memory variable formulation of
- ! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
- ! vol. 58(1), p. 110-120 (1993). More details can be found in
- ! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
- ! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
-
- ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(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)
- sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
- sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
-
- ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
- ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
- e1_sum = 0._CUSTOM_REAL
- e11_sum = 0._CUSTOM_REAL
- 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
-
- else
-
- ! no attenuation
- sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
- sigma_xy = mul_relaxed*duy_dxl
- sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
- sigma_zy = mul_relaxed*duy_dzl
- sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
- b_sigma_xx = lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
- b_sigma_xy = mul_relaxed*b_duy_dxl
- b_sigma_xz = mul_relaxed*(b_duz_dxl + b_dux_dzl)
- b_sigma_zy = mul_relaxed*b_duy_dzl
- b_sigma_zz = lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
- endif
-
- endif
-
- ! full anisotropy
- if(anisotropic(ispec)) then
- if(assign_external_model) then
- c11 = c11ext(i,j,ispec)
- c13 = c13ext(i,j,ispec)
- c15 = c15ext(i,j,ispec)
- c33 = c33ext(i,j,ispec)
- c35 = c35ext(i,j,ispec)
- c55 = c55ext(i,j,ispec)
- else
- c11 = anisotropy(1,kmato(ispec))
- c13 = anisotropy(2,kmato(ispec))
- c15 = anisotropy(3,kmato(ispec))
- c33 = anisotropy(4,kmato(ispec))
- c35 = anisotropy(5,kmato(ispec))
- c55 = anisotropy(6,kmato(ispec))
- end if
-
- ! implement anisotropy in 2D
- sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
- sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
- sigma_xz = c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
-
- endif
-
- ! Pre-kernels calculation
- if(SIMULATION_TYPE == 2) then
- iglob = ibool(i,j,ispec)
- if(p_sv)then !P-SV waves
- dsxx = dux_dxl
- dsxz = HALF * (duz_dxl + dux_dzl)
- dszz = duz_dzl
-
- b_dsxx = b_dux_dxl
- b_dsxz = HALF * (b_duz_dxl + b_dux_dzl)
- b_dszz = b_duz_dzl
-
- kappa_k(iglob) = (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl)
- mu_k(iglob) = dsxx * b_dsxx + dszz * b_dszz + &
- 2._CUSTOM_REAL * dsxz * b_dsxz - 1._CUSTOM_REAL/3._CUSTOM_REAL * kappa_k(iglob)
- else !SH (membrane) waves
- mu_k(iglob) = duy_dxl * b_duy_dxl + duy_dzl * b_duy_dzl
- endif
- endif
-
- jacobianl = jacobian(i,j,ispec)
-
- ! weak formulation term based on stress tensor (non-symmetric form)
- ! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
- tempy1(i,j) = wzgll(j)*jacobianl*(sigma_xy*xixl+sigma_zy*xizl)
- tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
-
- tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
- tempy2(i,j) = wxgll(i)*jacobianl*(sigma_xy*gammaxl+sigma_zy*gammazl)
- tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
- b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
- b_tempy1(i,j) = wzgll(j)*jacobianl*(b_sigma_xy*xixl+b_sigma_zy*xizl)
- b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
-
- b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
- b_tempy2(i,j) = wxgll(i)*jacobianl*(b_sigma_xy*gammaxl+b_sigma_zy*gammazl)
- b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
- endif
-
- enddo
- enddo
-
- !
- ! second double-loop over GLL to compute all the terms
- !
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- ! along x direction and z direction
- ! and assemble the contributions
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
- accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tempy1(k,j)*hprimewgll_xx(k,i) + tempy2(i,k)*hprimewgll_zz(k,j))
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tempz1(k,j)*hprimewgll_xx(k,i) + tempz2(i,k)*hprimewgll_zz(k,j))
-
- if(SIMULATION_TYPE == 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_tempy1(k,j)*hprimewgll_xx(k,i) + b_tempy2(i,k)*hprimewgll_zz(k,j))
- b_accel_elastic(3,iglob) = b_accel_elastic(3,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
- enddo
-
- endif ! end of test if elastic element
-
- enddo ! end of loop over all spectral elements
-
- !
- !--- absorbing boundaries
- !
- if(anyabs) then
-
- count_left=1
- count_right=1
- count_bottom=1
-
- do ispecabs = 1,nelemabs
-
- ispec = numabs(ispecabs)
-
- ! get elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- rhol = density(1,kmato(ispec))
- kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
- cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
- csl = sqrt(mul_relaxed/rhol)
-
- !--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
-
- i = 1
-
- do j = 1,NGLLZ
-
- iglob = ibool(i,j,ispec)
-
- ! for analytical initial plane wave for Bielak's conditions
- ! left or right edge, horizontal normal vector
- if(add_Bielak_conditions .and. initialfield) then
- if (.not.over_critical_angle) then
- call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
- traction_z_t0 = mul_relaxed*(dxUz + dzUx)
- else
- veloc_horiz=v0x_left(count_left)
- veloc_vert=v0z_left(count_left)
- traction_x_t0=t0x_left(count_left)
- traction_z_t0=t0z_left(count_left)
- count_left=count_left+1
- end if
- else
- veloc_horiz = 0
- veloc_vert = 0
- traction_x_t0 = 0
- traction_z_t0 = 0
- endif
-
- ! 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_vp = rhol*cpl
- rho_vs = rhol*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)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
-
- weight = jacobian1D * wzgll(j)
-
- ! Clayton-Engquist condition if elastic
- if(elastic(ispec)) then
- vx = veloc_elastic(1,iglob) - veloc_horiz
- vy = veloc_elastic(2,iglob)
- vz = veloc_elastic(3,iglob) - veloc_vert
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- ty = rho_vs*vy
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
- accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz + traction_z_t0)*weight
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- if(p_sv)then !P-SV waves
- b_absorb_elastic_left(1,j,ib_left(ispecabs),it) = tx*weight
- b_absorb_elastic_left(3,j,ib_left(ispecabs),it) = tz*weight
- else !SH (membrane) waves
- b_absorb_elastic_left(2,j,ib_left(ispecabs),it) = ty*weight
- endif
- elseif(SIMULATION_TYPE == 2) then
- if(p_sv)then !P-SV waves
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
- b_absorb_elastic_left(1,j,ib_left(ispecabs),NSTEP-it+1)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
- b_absorb_elastic_left(3,j,ib_left(ispecabs),NSTEP-it+1)
- else !SH (membrane) waves
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
- b_absorb_elastic_left(2,j,ib_left(ispecabs),NSTEP-it+1)
- endif
- endif
-
- endif
-
- enddo
-
- endif ! end of left absorbing boundary
-
- !--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
-
- i = NGLLX
-
- do j = 1,NGLLZ
-
- iglob = ibool(i,j,ispec)
-
- ! for analytical initial plane wave for Bielak's conditions
- ! left or right edge, horizontal normal vector
- if(add_Bielak_conditions .and. initialfield) then
- if (.not.over_critical_angle) then
- call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
- traction_z_t0 = mul_relaxed*(dxUz + dzUx)
- else
- veloc_horiz=v0x_right(count_right)
- veloc_vert=v0z_right(count_right)
- traction_x_t0=t0x_right(count_right)
- traction_z_t0=t0z_right(count_right)
- count_right=count_right+1
- end if
- else
- veloc_horiz = 0
- veloc_vert = 0
- traction_x_t0 = 0
- traction_z_t0 = 0
- endif
-
- ! 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_vp = rhol*cpl
- rho_vs = rhol*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)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
-
- weight = jacobian1D * wzgll(j)
-
- ! Clayton-Engquist condition if elastic
- if(elastic(ispec)) then
- vx = veloc_elastic(1,iglob) - veloc_horiz
- vy = veloc_elastic(2,iglob)
- vz = veloc_elastic(3,iglob) - veloc_vert
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- ty = rho_vs*vy
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
- accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz - traction_z_t0)*weight
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- if(p_sv)then !P-SV waves
- b_absorb_elastic_right(1,j,ib_right(ispecabs),it) = tx*weight
- b_absorb_elastic_right(3,j,ib_right(ispecabs),it) = tz*weight
- else! SH (membrane) waves
- b_absorb_elastic_right(2,j,ib_right(ispecabs),it) = ty*weight
- endif
- elseif(SIMULATION_TYPE == 2) then
- if(p_sv)then !P-SV waves
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
- b_absorb_elastic_right(1,j,ib_right(ispecabs),NSTEP-it+1)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
- b_absorb_elastic_right(3,j,ib_right(ispecabs),NSTEP-it+1)
- else! SH (membrane) waves
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
- b_absorb_elastic_right(2,j,ib_right(ispecabs),NSTEP-it+1)
- endif
- endif
-
- endif
-
- enddo
-
- endif ! end of right absorbing boundary
-
- !--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
-
- j = 1
-
- ! exclude corners to make sure there is no contradiction on the normal
- ibegin = 1
- iend = NGLLX
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
- ! for analytical initial plane wave for Bielak's conditions
- ! top or bottom edge, vertical normal vector
- if(add_Bielak_conditions .and. initialfield) then
- if (.not.over_critical_angle) then
- call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = mul_relaxed*(dxUz + dzUx)
- traction_z_t0 = lambdal_relaxed*dxUx + (lambdal_relaxed+2*mul_relaxed)*dzUz
- else
- veloc_horiz=v0x_bot(count_bottom)
- veloc_vert=v0z_bot(count_bottom)
- traction_x_t0=t0x_bot(count_bottom)
- traction_z_t0=t0z_bot(count_bottom)
- count_bottom=count_bottom+1
- end if
- else
- veloc_horiz = 0
- veloc_vert = 0
- traction_x_t0 = 0
- traction_z_t0 = 0
- endif
-
- ! 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_vp = rhol*cpl
- rho_vs = rhol*csl
-
- 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)
-
- ! Clayton-Engquist condition if elastic
- if(elastic(ispec)) then
- vx = veloc_elastic(1,iglob) - veloc_horiz
- vy = veloc_elastic(2,iglob)
- vz = veloc_elastic(3,iglob) - veloc_vert
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- ty = rho_vs*vy
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
- accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz + traction_z_t0)*weight
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- if(p_sv)then !P-SV waves
- b_absorb_elastic_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
- b_absorb_elastic_bottom(3,i,ib_bottom(ispecabs),it) = tz*weight
- else!SH (membrane) waves
- b_absorb_elastic_bottom(2,i,ib_bottom(ispecabs),it) = ty*weight
- endif
- elseif(SIMULATION_TYPE == 2) then
- if(p_sv)then !P-SV waves
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
- b_absorb_elastic_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
- b_absorb_elastic_bottom(3,i,ib_bottom(ispecabs),NSTEP-it+1)
- else!SH (membrane) waves
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
- b_absorb_elastic_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
- endif
- endif
-
- endif
-
- enddo
-
- endif ! end of bottom absorbing boundary
-
- !--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
-
- j = NGLLZ
-
- ! exclude corners to make sure there is no contradiction on the normal
- ibegin = 1
- iend = NGLLX
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
- ! 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, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = mul_relaxed*(dxUz + dzUx)
- traction_z_t0 = lambdal_relaxed*dxUx + (lambdal_relaxed+2*mul_relaxed)*dzUz
- else
- veloc_horiz = 0
- veloc_vert = 0
- traction_x_t0 = 0
- traction_z_t0 = 0
- endif
-
- ! 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_vp = rhol*cpl
- rho_vs = rhol*csl
-
- 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)
-
- ! Clayton-Engquist condition if elastic
- if(elastic(ispec)) then
- vx = veloc_elastic(1,iglob) - veloc_horiz
- vy = veloc_elastic(2,iglob)
- vz = veloc_elastic(3,iglob) - veloc_vert
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- ty = rho_vs*vy
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
- accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz - traction_z_t0)*weight
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- if(p_sv)then !P-SV waves
- b_absorb_elastic_top(1,i,ib_top(ispecabs),it) = tx*weight
- b_absorb_elastic_top(3,i,ib_top(ispecabs),it) = tz*weight
- else!SH (membrane) waves
- b_absorb_elastic_top(2,i,ib_top(ispecabs),it) = ty*weight
- endif
- elseif(SIMULATION_TYPE == 2) then
- if(p_sv)then !P-SV waves
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_top(1,i,ib_top(ispecabs),NSTEP-it+1)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - b_absorb_elastic_top(3,i,ib_top(ispecabs),NSTEP-it+1)
- else!SH (membrane) waves
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_top(2,i,ib_top(ispecabs),NSTEP-it+1)
- endif
- endif
-
- endif
-
- enddo
-
- endif ! end of top absorbing boundary
-
- enddo
-
- endif ! end of absorbing boundaries
-
- ! --- add the source if it is a moment tensor
- if(.not. initialfield) then
-
- do i_source=1,NSOURCES
- ! 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
-
- ! moment tensor
- if(source_type(i_source) == 2) then
-
- if(.not.p_sv) call exit_MPI('cannot have moment tensor source in SH (membrane) waves calculation')
-
- if(SIMULATION_TYPE == 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(1,iglob) = accel_elastic(1,iglob) + &
- sourcearray(i_source,1,i,j)*source_time_function(i_source,it)
- accel_elastic(3,iglob) = accel_elastic(3,iglob) + &
- sourcearray(i_source,2,i,j)*source_time_function(i_source,it)
- enddo
- enddo
- else ! backward wavefield
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + &
- sourcearray(i_source,1,i,j)*source_time_function(i_source,NSTEP-it+1)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) + &
- sourcearray(i_source,2,i,j)*source_time_function(i_source,NSTEP-it+1)
- enddo
- enddo
- endif !endif SIMULATION_TYPE == 1
-
- endif !if(source_type(i_source) == 2)
-
- endif ! if this processor carries the source and the source element is elastic
- enddo ! do i_source=1,NSOURCES
-
- if(SIMULATION_TYPE == 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
-
- irec_local = irec_local + 1
- if(elastic(ispec_selected_rec(irec))) then
- ! add source array
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_rec(irec))
- if(p_sv)then !P-SH waves
- accel_elastic(1,iglob) = accel_elastic(1,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
- accel_elastic(3,iglob) = accel_elastic(3,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
- else !SH (membrane) waves
- accel_elastic(2,iglob) = accel_elastic(2,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,2,i,j)
- endif
- enddo
- enddo
- endif ! if element is elastic
-
- endif ! if this processor carries the adjoint source and the source element is elastic
- enddo ! irec = 1,nrec
-
- endif ! if SIMULATION_TYPE == 2 adjoint wavefield
-
- endif ! if not using an initial field
-
- ! implement attenuation
- if(TURN_ATTENUATION_ON) then
-
- ! compute Grad(displ_elastic) at time step n+1 for attenuation
- call compute_gradient_attenuation(displ_elastic,dux_dxl_np1,duz_dxl_np1, &
- dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
-
- ! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
- ! loop over spectral elements
- do ispec = 1,nspec
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
- theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
- theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
-
- ! 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,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,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,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) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e11(i,j,ispec,i_sls) = Unp1
-
- ! evolution e13
- Un = e13(i,j,ispec,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,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) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e13(i,j,ispec,i_sls) = Unp1
-
- enddo
-
- enddo
- enddo
- enddo
-
- endif ! end of test on attenuation
-
-end subroutine compute_forces_viscoelastic
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_gradient_attenuation.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_gradient_attenuation.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_gradient_attenuation.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,126 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_gradient_attenuation(displ_elastic,dux_dxl,duz_dxl,dux_dzl,duz_dzl, &
- xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
-
-! compute Grad(displ_elastic) for attenuation
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,npoin
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- logical, dimension(nspec) :: elastic
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
- real(kind=CUSTOM_REAL), dimension(3,npoin) :: displ_elastic
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
-! local variables
- integer :: i,j,k,ispec
-
-! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
-
-! jacobian
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
-
-! loop over spectral elements
- do ispec = 1,nspec
-
-!---
-!--- elastic spectral element
-!---
- if(elastic(ispec)) then
-
-! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
-! derivative along x and along z
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,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(3,ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
-! derivatives of displacement
- dux_dxl(i,j,ispec) = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl(i,j,ispec) = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl(i,j,ispec) = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl(i,j,ispec) = duz_dxi*xizl + duz_dgamma*gammazl
-
- enddo
- enddo
-
- endif
-
- enddo
-
- end subroutine compute_gradient_attenuation
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_normal_vector.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_normal_vector.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_normal_vector.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,122 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine compute_normal_vector( 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)
-
- ! a sum is needed here because in the case of a source force vector
- ! users can give an angle with respect to the normal to the topography surface,
- ! in which case we must compute the normal to the topography
- ! and add it the existing rotation angle
- angle = angle + (theta1 + theta2 + theta3) / 3.d0 + PI/2.d0
-
- end subroutine compute_normal_vector
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine tri_quad(n, n1, nnodes)
-
- implicit none
-
- integer :: n1, nnodes
- integer, dimension(4) :: n
-
-
- n(2) = n1
-
- if ( n1 == 1 ) then
- n(1) = nnodes
- else
- n(1) = n1-1
- endif
-
- if ( n1 == nnodes ) then
- n(3) = 1
- else
- n(3) = n1+1
- endif
-
- if ( n(3) == nnodes ) then
- n(4) = 1
- else
- n(4) = n(3)+1
- endif
-
-
- end subroutine tri_quad
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_pressure.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_pressure.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_pressure.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,493 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- 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,npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,e1,e11, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
-
-! compute pressure in acoustic elements and in elastic elements
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,npoin,numat
-
-
- integer, dimension(nspec) :: kmato
- integer, dimension(NGLLX,NGLLX,nspec) :: ibool
-
- double precision, dimension(2,numat) :: density
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(6,numat) :: anisotropy
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
- double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
- logical, dimension(nspec) :: elastic,poroelastic,anisotropic
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_dot_dot_acoustic
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
-
- double precision, dimension(3,npoin) :: vector_field_display
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
- logical :: assign_external_model,TURN_ATTENUATION_ON
-
- integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
-
-! local variables
- integer :: i,j,ispec,iglob
-
-! pressure in this element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
-
-! loop over spectral elements
- do ispec = 1,nspec
-
-! compute pressure in this element
- 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_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
-
-! use vector_field_display as temporary storage, store pressure in its second component
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- vector_field_display(3,iglob) = pressure_element(i,j)
- enddo
- enddo
-
- enddo
-
- end subroutine compute_pressure_whole_medium
-
-!
-!=====================================================================
-!
-
- 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_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
-
-! compute pressure in acoustic elements and in elastic elements
-
- implicit none
-
- include "constants.h"
-
- integer nspec,numat,ispec
-
- integer, dimension(nspec) :: kmato
- integer, dimension(NGLLX,NGLLX,nspec) :: ibool
-
- double precision, dimension(2,numat) :: density
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(6,numat) :: anisotropy
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
- double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
-! pressure in this element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
-
- logical, dimension(nspec) :: elastic,poroelastic,anisotropic
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_dot_dot_acoustic
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
- logical :: assign_external_model,TURN_ATTENUATION_ON
-
- 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, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
- integer :: i_sls
-
-! local variables
- integer :: i,j,k,iglob
-
-! jacobian
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
-
-! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
- real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: sigma_xx,sigma_zz,sigmap
- real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
- real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dzl
-
-! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,denst
- real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed,cpl,csl
-
- real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
- real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
- real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
- real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
- real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
-
-! for anisotropy
- double precision :: c11,c15,c13,c33,c35,c55
-
-! if elastic element
-!
-! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction,
-! J. Engrg. Mech., vol. 132(11), p. 1205-1214 (2006), below equation (5):
-! for a 3D isotropic solid, pressure is defined in terms of the trace of the stress tensor as
-! p = -1/3 (t11 + t22 + t33) where t is the Cauchy stress tensor.
-
-! to compute pressure in 3D in an elastic solid, one uses pressure = - trace(sigma) / 3
-! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
-! = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_ij
-! sigma_xx = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_xx
-! sigma_yy = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_yy
-! sigma_zz = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_zz
-! pressure = - trace(sigma) / 3 = - (lambda + 2/3 mu) trace(epsilon) = - kappa * trace(epsilon)
-!
-! to compute pressure in 2D in an elastic solid, one uses pressure = - trace(sigma) / 2
-! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
-! = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_ij
-! sigma_xx = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_xx
-! sigma_yy = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_yy
-! pressure = - trace(sigma) / 2 = - (lambda + mu) trace(epsilon)
-!
-
-
- 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))
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- !--- if external medium, get elastic parameters of current grid point
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- csl = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- mul_relaxed = denst*csl*csl
- lambdal_relaxed = denst*cpl*cpl - TWO*mul_relaxed
- endif
-
- ! derivative along x and along z
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,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(3,ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- ! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
-! compute diagonal components of the stress tensor (include attenuation or anisotropy if needed)
-
- if(TURN_ATTENUATION_ON) then
-
-! attenuation is implemented following the memory variable formulation of
-! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
-! vol. 58(1), p. 110-120 (1993). More details can be found in
-! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
-! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
-
- ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(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)
- sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
- sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
-
- ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
- ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
- e1_sum = 0._CUSTOM_REAL
- e11_sum = 0._CUSTOM_REAL
-
- do i_sls = 1,N_SLS
- e1_sum = e1_sum + e1(i,j,ispec,i_sls)
- e11_sum = e11_sum + e11(i,j,ispec,i_sls)
- enddo
-
- sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum &
- + TWO * mul_relaxed * e11_sum
- sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum &
- - TWO * mul_relaxed * e11_sum
-
- else
-
- ! no attenuation
- sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
- sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
-
- endif
-
- ! full anisotropy
- if(anisotropic(ispec)) then
- if(assign_external_model) then
- c11 = c11ext(i,j,ispec)
- c15 = c15ext(i,j,ispec)
- c13 = c13ext(i,j,ispec)
- c33 = c33ext(i,j,ispec)
- c35 = c35ext(i,j,ispec)
- c55 = c55ext(i,j,ispec)
- else
- c11 = anisotropy(1,kmato(ispec))
- c13 = anisotropy(2,kmato(ispec))
- c15 = anisotropy(3,kmato(ispec))
- c33 = anisotropy(4,kmato(ispec))
- c35 = anisotropy(5,kmato(ispec))
- c55 = anisotropy(6,kmato(ispec))
- endif
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- ! implement anisotropy in 2D
- sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
- sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
-
- endif
-
- ! store pressure
- pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
-
- enddo
- enddo
-
- elseif(poroelastic(ispec)) then
-
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
-
- ! get poroelastic parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- !solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
- rhol_s = density(1,kmato(ispec))
- !fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
- !frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
- rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
- !Biot coefficients for the input phi
- D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
- + kappal_fr + FOUR_THIRDS*mul_fr
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
- !where T = G:grad u_s + C div w I
- !and T_f = C div u_s I + M div w I
- !we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
- mul_G = mul_fr
- lambdal_G = H_biot - TWO*mul_fr
- lambdalplus2mul_G = lambdal_G + TWO*mul_G
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- ! derivative along x and along z
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- ! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
-! compute diagonal components of the stress tensor (include attenuation if needed)
-
- if(TURN_ATTENUATION_ON) then
-!-------------------- ATTENTION TO BE DEFINED ------------------------------!
-
-! attenuation is implemented following the memory variable formulation of
-! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
-! vol. 58(1), p. 110-120 (1993). More details can be found in
-! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
-! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
-
- ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(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)
- sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
- sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
-
- ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
- ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
- e1_sum = 0._CUSTOM_REAL
- e11_sum = 0._CUSTOM_REAL
-
- do i_sls = 1,N_SLS
- e1_sum = e1_sum + e1(i,j,ispec,i_sls)
- e11_sum = e11_sum + e11(i,j,ispec,i_sls)
- enddo
-
- sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum &
- + TWO * mul_relaxed * e11_sum
- sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum &
- - TWO * mul_relaxed * e11_sum
-
- else
-
- ! no attenuation
- sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
-
- endif
-
- ! store pressure
- pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
-! pressure_element2(i,j) = - sigmap
- enddo
- enddo
-
-! pressure = - Chi_dot_dot if acoustic element
- else
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- ! store pressure
- pressure_element(i,j) = - potential_dot_dot_acoustic(iglob)
-
- enddo
- enddo
-
- endif ! end of test if acoustic or elastic element
-
- end subroutine compute_pressure_one_element
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/compute_vector_field.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_vector_field.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_vector_field.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,235 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
-! compute Grad(potential) in acoustic elements
-! and combine with existing velocity vector field in elastic elements
-
- implicit none
-
- include "constants.h"
-
- 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
-
- logical, dimension(nspec) :: elastic,poroelastic
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: veloc_elastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: velocs_poroelastic
-
- double precision, dimension(3,npoin) :: vector_field_display
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
-! local variables
- integer i,j,ispec,iglob
-
-! vector field in this element
- real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
-
-! loop over spectral elements
- 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_acoustic,npoin_elastic,npoin_poroelastic, &
- ispec,numat,kmato,density,rhoext,assign_external_model)
-
-! store the result
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- vector_field_display(:,iglob) = vector_field_element(:,i,j)
- enddo
- enddo
-
- enddo
-
- end subroutine compute_vector_whole_medium
-
-!
-!=====================================================================
-!
-
- 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_acoustic,npoin_elastic,npoin_poroelastic, &
- ispec,numat,kmato,density,rhoext,assign_external_model)
-
-! compute Grad(potential) if acoustic element or copy existing vector if elastic element
-
- implicit none
-
- include "constants.h"
-
- integer nspec,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
-
-! vector field in this element
- real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
-
- logical, dimension(nspec) :: elastic,poroelastic
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: veloc_elastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: velocs_poroelastic
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
-! local variables
- integer i,j,k,iglob
-
-! space derivatives
- real(kind=CUSTOM_REAL) tempx1l,tempx2l
- real(kind=CUSTOM_REAL) hp1,hp2
-
-! 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
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- vector_field_element(1,i,j) = veloc_elastic(1,iglob)
- vector_field_element(2,i,j) = veloc_elastic(2,iglob)
- vector_field_element(3,i,j) = veloc_elastic(3,iglob)
- enddo
- enddo
-
- elseif(poroelastic(ispec)) then
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- vector_field_element(1,i,j) = velocs_poroelastic(1,iglob)
- vector_field_element(2,i,j) = 0._CUSTOM_REAL
- vector_field_element(3,i,j) = velocs_poroelastic(2,iglob)
- enddo
- enddo
-
-! compute gradient of potential to calculate vector if acoustic element
-! we then need to divide by density because the potential is a potential of (density * displacement)
- else
-
- rhol = density(1,kmato(ispec))
-
-! double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
-! derivative along x
- tempx1l = 0._CUSTOM_REAL
- do k = 1,NGLLX
- hp1 = hprime_xx(i,k)
- iglob = ibool(k,j,ispec)
- tempx1l = tempx1l + potential_acoustic(iglob)*hp1
- enddo
-
-! derivative along z
- tempx2l = 0._CUSTOM_REAL
- do k = 1,NGLLZ
- hp2 = hprime_zz(j,k)
- iglob = ibool(i,k,ispec)
- tempx2l = tempx2l + potential_acoustic(iglob)*hp2
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- if(assign_external_model) rhol = rhoext(i,j,ispec)
-
-! derivatives of potential
- vector_field_element(1,i,j) = (tempx1l*xixl + tempx2l*gammaxl) / rhol
- vector_field_element(2,i,j) = 0._CUSTOM_REAL
- vector_field_element(3,i,j) = (tempx1l*xizl + tempx2l*gammazl) / rhol
-
- enddo
- enddo
-
- endif ! end of test if acoustic or elastic element
-
- end subroutine compute_vector_one_element
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/construct_acoustic_surface.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/construct_acoustic_surface.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/construct_acoustic_surface.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,194 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! From array 'surface' (element, type : node/edge, node(s) ) that describes the
-! acoustic free surface, determines the points (ixmin, ixmax, izmin and izmax) on the surface
-! for each element.
-! We chose to have ixmin <= ixmax and izmin <= izmax, so as to be able to have DO loops on it with
-! an increment of +1.
-!
-subroutine construct_acoustic_surface ( nspec, ngnod, knods, nsurface, surface, tab_surface )
-
- implicit none
-
- integer, intent(in) :: nspec
- integer, intent(in) :: ngnod
- integer, dimension(ngnod,nspec), intent(in) :: knods
- integer, intent(in) :: nsurface
- integer, dimension(4,nsurface), intent(in) :: surface
- integer, dimension(5,nsurface), intent(out) :: tab_surface
-
- integer :: i, k
- integer :: ixmin, ixmax
- integer :: izmin, izmax
- integer, dimension(ngnod) :: n
- integer :: e1, e2
- integer :: type
-
- do i = 1, nsurface
- tab_surface(1,i) = surface(1,i)
- type = surface(2,i)
- e1 = surface(3,i)
- e2 = surface(4,i)
- do k = 1, ngnod
- n(k) = knods(k,tab_surface(1,i))
- enddo
-
- call get_acoustic_edge ( ngnod, n, type, e1, e2, ixmin, ixmax, izmin, izmax )
-
- tab_surface(2,i) = ixmin
- tab_surface(3,i) = ixmax
- tab_surface(4,i) = izmin
- tab_surface(5,i) = izmax
-
- enddo
-
-end subroutine construct_acoustic_surface
-
-
-!-----------------------------------------------
-! Get the points (ixmin, ixmax, izmin and izmax) on an node/edge for one element.
-!-----------------------------------------------
-subroutine get_acoustic_edge ( ngnod, n, type, e1, e2, ixmin, ixmax, izmin, izmax )
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: ngnod
- integer, dimension(ngnod), intent(in) :: n
- integer, intent(in) :: type, e1, e2
- integer, intent(out) :: ixmin, ixmax, izmin, izmax
-
-
- if ( type == 1 ) then
- if ( e1 == n(1) ) then
- ixmin = 1
- ixmax = 1
- izmin = 1
- izmax = 1
- endif
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- izmin = 1
- izmax = 1
- endif
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- izmin = NGLLZ
- izmax = NGLLZ
- endif
- if ( e1 == n(4) ) then
- ixmin = 1
- ixmax = 1
- izmin = NGLLZ
- izmax = NGLLZ
- endif
-
- else
- if ( e1 == n(1) ) then
- ixmin = 1
- izmin = 1
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- izmax = 1
-
- endif
- if ( e2 == n(4) ) then
- ixmax = 1
- izmax = NGLLZ
-
- endif
- endif
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- izmin = 1
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- izmax = NGLLZ
-
- endif
- if ( e2 == n(1) ) then
- ixmax = ixmin
- ixmin = 1
- izmax = 1
-
- endif
- endif
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- izmin = NGLLZ
- if ( e2 == n(4) ) then
- ixmax = ixmin
- ixmin = 1
- izmax = NGLLZ
-
- endif
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- izmax = izmin
- izmin = 1
-
- endif
- endif
- if ( e1 == n(4) ) then
- ixmin = 1
- izmin = NGLLZ
- if ( e2 == n(1) ) then
- ixmax = 1
- izmax = izmin
- izmin = 1
-
- endif
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- izmax = NGLLZ
-
- endif
- endif
- endif
-
-end subroutine get_acoustic_edge
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/convert_time.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/convert_time.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/convert_time.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,235 +0,0 @@
-
-! open-source subroutines taken from the World Ocean Circulation Experiment (WOCE)
-! web site at http://www.coaps.fsu.edu/woce/html/wcdtools.htm
-
-! converted to Fortran90 by Dimitri Komatitsch,
-! University of Pau, France, January 2008.
-! Also converted "convtime" from a function to a subroutine.
-! Also used a more complete test to detect leap years (the original version was incomplete).
-
- subroutine convtime(timestamp,yr,mon,day,hr,min)
-
-! Originally written by Shawn Smith (ssmith AT coaps.fsu.edu)
-! Updated Spring 1999 for Y2K compliance by Anthony Arguez (anthony AT coaps.fsu.edu).
-
-! This subroutine will convert a given year, month, day, hour, and
-! minutes to a minutes from 01 Jan 1980 00:00 time stamp.
-
- implicit none
-
- integer, intent(out) :: timestamp
-
- integer, intent(in) :: yr,mon,day,hr,min
-
- integer :: year(1980:2020),month(12),leap_mon(12)
-
- integer :: min_day,min_hr
-
-! function to determine if year is a leap year
- logical, external :: is_leap_year
-
- data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
- 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
- 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
- 9993600, 10519200, 11046240, 11571840, 12097440, &
- 12623040, 13150080, 13675680, 14201280, 14726880, &
- 15253920, 15779520, 16305120, 16830720, 17357760, &
- 17883360, 18408960, 18934560, 19461600, 19987200, &
- 20512800, 21038400/
-
- data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
- 305280, 349920, 393120, 437760, 480960/
-
- data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
- 306720, 351360, 394560, 439200, 482400/
-
- data min_day, min_hr /1440, 60/
-
-! Test values to see if they fit valid ranges
- if (yr < 1980 .or. yr > 2020) stop 'Error in convtime: year out of range (1980-2020)'
-
- if (mon < 1 .or. mon > 12) stop 'Error in convtime: month out of range (1-12)'
-
- if (mon == 2) then
- if (is_leap_year(yr) .and. (day < 1 .or. day > 29)) then
- stop 'Error in convtime: February day out of range (1-29)'
- elseif (.not. is_leap_year(yr) .and. (day < 1 .or. day > 28)) then
- stop 'Error in convtime: February day out of range (1-28)'
- endif
- elseif (mon == 4 .or. mon == 6 .or. mon == 9 .or. mon == 11) then
- if (day < 1 .or. day > 30) stop 'Error in convtime: day out of range (1-30)'
- else
- if (day < 1 .or. day > 31) stop 'Error in convtime: day out of range (1-31)'
- endif
-
- if (hr < 0 .or. hr > 23) stop 'Error in convtime: hour out of range (0-23)'
-
- if (min < 0 .or. min > 60) stop 'Error in convtime: minute out of range (0-60)'
-
-! convert time (test if leap year)
- if (is_leap_year(yr)) then
- timestamp = year(yr)+leap_mon(mon)+((day-1)*min_day)+(hr*min_hr)+min
- else
- timestamp = year(yr)+month(mon)+((day-1)*min_day)+(hr*min_hr)+min
- endif
-
- end subroutine convtime
-
-!
-!----
-!
-
- subroutine invtime(timestamp,yr,mon,day,hr,min)
-
-! This subroutine will convert a minutes timestamp to a year/month
-! date. Based on the function convtime by Shawn Smith (COAPS).
-!
-! Written the spring of 1995, several iterations.
-! James N. Stricherz (stricherz AT coaps.fsu.edu)
-!
-! Updated for Y2K compliance in July 1999.
-! Shyam Lakshmin (lakshmin AT coaps.fsu.edu)
-!
-! This code returns correct results for the range of 01 Jan 1980 00:00
-! thru 31 Dec 2020 23:59. I know it does, because I tried each minute of that range.
-
- implicit none
-
- integer, intent(in) :: timestamp
-
- integer, intent(out) :: yr,mon,day,hr,min
-
- integer :: year(1980:2021),month(13),leap_mon(13)
-
- integer :: min_day,min_hr,itime,tmon,ttime,thour,iyr,imon,iday,ihour
-
-! function to determine if year is a leap year
- logical, external :: is_leap_year
-
- data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
- 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
- 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
- 9993600, 10519200, 11046240, 11571840, 12097440, &
- 12623040, 13150080, 13675680, 14201280, 14726880, &
- 15253920, 15779520, 16305120, 16830720, 17357760, &
- 17883360, 18408960, 18934560, 19461600, 19987200, &
- 20512800, 21038400, 21565440/
-
- data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
- 305280, 349920, 393120, 437760, 480960,525600/
-
- data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
- 306720, 351360, 394560, 439200, 482400,527040/
-
- data min_day, min_hr /1440, 60/
-
-! ok, let us invert the effects of the years: subtract off the
-! number of minutes per year until it goes negative
-! iyr then gives the year that the time (in minutes) occurs
- if (timestamp >= year(2021)) stop 'year too high in invtime'
-
- iyr=1979
- itime=timestamp
-
- 10 iyr=iyr+1
- ttime=itime-year(iyr)
- if (ttime <= 0) then
- if (iyr == 1980) iyr=iyr+1
- iyr=iyr-1
- itime=itime-year(iyr)
- else
- goto 10
- endif
-
-! assign the return variable
- yr=iyr
-
-! ok, the remaining time is less than one full year, so convert
-! by the same method as above into months
- imon=0
-
-! if not leap year
- if (.not. is_leap_year(iyr)) then
-
-! increment the month, and subtract off the minutes from the
-! remaining time for a non-leap year
- 20 imon=imon+1
- tmon=itime-month(imon)
- if (tmon > 0) then
- goto 20
- else if (tmon < 0) then
- imon=imon-1
- itime=itime-month(imon)
- else
- if (imon > 12) then
- imon=imon-12
- yr=yr+1
- endif
- mon=imon
- day=1
- hr=0
- min=0
- return
- endif
-
-! if leap year
- else
-
-! same thing, same code, but for a leap year
- 30 imon=imon+1
- tmon=itime-leap_mon(imon)
- if (tmon > 0) then
- goto 30
- elseif (tmon < 0) then
- imon=imon-1
- itime=itime-month(imon)
- else
- if (imon > 12) then
- imon=imon-12
- yr=yr+1
- endif
- mon=imon
- day=1
- hr=0
- min=0
- return
- endif
- endif
-
-! assign the return variable
- mon=imon
-
-! any remaining minutes will belong to day/hour/minutes
-! ok, let us get the days
- iday=0
- 40 iday=iday+1
- ttime=itime-min_day
- if (ttime >= 0) then
- itime=ttime
- goto 40
- endif
-
-! assign the return variable
- if (is_leap_year(iyr) .and. mon > 2) then
- day=iday-1
- else
- day=iday
- endif
-
-! pick off the hours of the days...remember, hours can be 0, so we start at -1
- ihour=-1
- 50 ihour=ihour+1
- thour=itime-min_hr
- if (thour >= 0) then
- itime=thour
- goto 50
- endif
-
-! assign the return variables
- hr=ihour
-
-! the remainder at this point is the minutes, so return them directly
- min=itime
-
- end subroutine invtime
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/convolve_source_timefunction.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/convolve_source_timefunction.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/convolve_source_timefunction.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,152 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- program convolve_source_time_function
-
-!
-! convolve seismograms computed for a Heaviside with given source time function
-!
-
-! we mimic a triangle of half duration equal to half_duration_triangle
-! using a Gaussian having a very close shape, as explained in Figure 4.2
-! of the manual
-
- implicit none
-
- include "constants.h"
-
- integer :: i,j,N_j,number_remove,nlines
-
- double precision :: alpha,dt,tau_j,source,exponent,t1,t2,displ1,displ2,gamma,height,half_duration_triangle
-
- logical :: triangle
-
- double precision, dimension(:), allocatable :: time,sem,sem_fil
-
-! read file with number of lines in input
- open(unit=33,file='input_convolve_code.txt',status='old',action='read')
- read(33,*) nlines
- read(33,*) half_duration_triangle
- read(33,*) triangle
- close(33)
-
-! allocate arrays
- allocate(time(nlines),sem(nlines),sem_fil(nlines))
-
-! read the input seismogram
- do i = 1,nlines
- read(5,*) time(i),sem(i)
- enddo
-
-! define a Gaussian with the right exponent to mimic a triangle of equivalent half duration
- alpha = SOURCE_DECAY_MIMIC_TRIANGLE/half_duration_triangle
-
-! compute the time step
- dt = time(2) - time(1)
-
-! number of integers for which the source wavelet is different from zero
- if(triangle) then
- N_j = ceiling(half_duration_triangle/dt)
- else
- N_j = ceiling(1.5d0*half_duration_triangle/dt)
- endif
-
- do i = 1,nlines
-
- sem_fil(i) = 0.d0
-
- do j = -N_j,N_j
-
- if(i > j .and. i-j <= nlines) then
-
- tau_j = dble(j)*dt
-
-! convolve with a triangle
- if(triangle) then
- height = 1.d0 / half_duration_triangle
- if(abs(tau_j) > half_duration_triangle) then
- source = 0.d0
- else if (tau_j < 0.d0) then
- t1 = - N_j * dt
- displ1 = 0.d0
- t2 = 0.d0
- displ2 = height
- gamma = (tau_j - t1) / (t2 - t1)
- source= (1.d0 - gamma) * displ1 + gamma * displ2
- else
- t1 = 0.d0
- displ1 = height
- t2 = + N_j * dt
- displ2 = 0.d0
- gamma = (tau_j - t1) / (t2 - t1)
- source= (1.d0 - gamma) * displ1 + gamma * displ2
- endif
-
- else
-
-! convolve with a Gaussian
- exponent = alpha**2 * tau_j**2
- if(exponent < 50.d0) then
- source = alpha*exp(-exponent)/sqrt(PI)
- else
- source = 0.d0
- endif
-
- endif
-
- sem_fil(i) = sem_fil(i) + sem(i-j)*source*dt
-
- endif
-
- enddo
- enddo
-
-! compute number of samples to remove from end of seismograms
- number_remove = N_j + 1
- do i=1,nlines - number_remove
- write(*,*) sngl(time(i)),' ',sngl(sem_fil(i))
- enddo
-
- end program convolve_source_time_function
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/create_color_image.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/create_color_image.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/create_color_image.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,267 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine create_color_image(color_image_2D_data,iglob_image_color_2D, &
- NX,NY,it,cutsnaps,image_color_vp_display)
-
-! display a given field as a red and blue color image
-
-! to display the snapshots : display image*.gif
-
-! when compiling with Intel ifort, use " -assume byterecl " option to create binary PNM images
-
- implicit none
-
- include "constants.h"
-
- integer :: NX,NY,it
-
- double precision :: cutsnaps
-
- integer, dimension(NX,NY) :: iglob_image_color_2D
-
- double precision, dimension(NX,NY) :: color_image_2D_data
- double precision, dimension(NX,NY) :: image_color_vp_display
-
- integer :: ix,iy,R,G,B,tenthousands,thousands,hundreds,tens,units,remainder,current_rec
-
- double precision :: amplitude_max,normalized_value,vpmin,vpmax,x1
-
- character(len=100) :: file_name,system_command
-
-! create temporary image files in binary PNM P6 format (smaller) or ASCII PNM P3 format (easier to edit)
- logical, parameter :: BINARY_FILE = .true.
-
-! ASCII code of character '0' and of carriage return character
- integer, parameter :: ascii_code_of_zero = 48, ascii_code_of_carriage_return = 10
-
-! open the image file
- write(file_name,"('OUTPUT_FILES/image',i7.7,'.pnm')") it
-
- if(BINARY_FILE) then
-
- open(unit=27,file=file_name,status='unknown',access='direct',recl=1)
- write(27,rec=1) 'P'
- write(27,rec=2) '6' ! write P6 = binary PNM image format
- write(27,rec=3) char(ascii_code_of_carriage_return)
-
-! compute and write horizontal size
- remainder = NX
-
- tenthousands = remainder / 10000
- remainder = remainder - 10000 * tenthousands
-
- thousands = remainder / 1000
- remainder = remainder - 1000 * thousands
-
- hundreds = remainder / 100
- remainder = remainder - 100 * hundreds
-
- tens = remainder / 10
- remainder = remainder - 10 * tens
-
- units = remainder
-
- write(27,rec=4) char(tenthousands + ascii_code_of_zero)
- write(27,rec=5) char(thousands + ascii_code_of_zero)
- write(27,rec=6) char(hundreds + ascii_code_of_zero)
- write(27,rec=7) char(tens + ascii_code_of_zero)
- write(27,rec=8) char(units + ascii_code_of_zero)
- write(27,rec=9) ' '
-
-! compute and write vertical size
- remainder = NY
-
- tenthousands = remainder / 10000
- remainder = remainder - 10000 * tenthousands
-
- thousands = remainder / 1000
- remainder = remainder - 1000 * thousands
-
- hundreds = remainder / 100
- remainder = remainder - 100 * hundreds
-
- tens = remainder / 10
- remainder = remainder - 10 * tens
-
- units = remainder
-
- write(27,rec=10) char(tenthousands + ascii_code_of_zero)
- write(27,rec=11) char(thousands + ascii_code_of_zero)
- write(27,rec=12) char(hundreds + ascii_code_of_zero)
- write(27,rec=13) char(tens + ascii_code_of_zero)
- write(27,rec=14) char(units + ascii_code_of_zero)
- write(27,rec=15) char(ascii_code_of_carriage_return)
-
-! number of shades
- write(27,rec=16) '2'
- write(27,rec=17) '5'
- write(27,rec=18) '5'
- write(27,rec=19) char(ascii_code_of_carriage_return)
-
-! block of image data starts at sixteenth character
- current_rec = 20
-
- else
-
- open(unit=27,file=file_name,status='unknown')
- write(27,"('P3')") ! write P3 = ASCII PNM image format
- write(27,*) NX,NY ! write image size
- write(27,*) '255' ! number of shades
-
- endif
-
-! compute maximum amplitude
- amplitude_max = maxval(abs(color_image_2D_data))
- vpmin = HUGEVAL
- vpmax = TINYVAL
- do iy=1,NY
- do ix=1,NX
- if ( iglob_image_color_2D(ix,iy) > -1 ) then
- vpmin = min(vpmin,image_color_vp_display(ix,iy))
- vpmax = max(vpmax,image_color_vp_display(ix,iy))
- endif
-
- enddo
- enddo
-
-! in the PNM format, the image starts in the upper-left corner
- do iy=NY,1,-1
- do ix=1,NX
-
-! check if pixel is defined or not (can be above topography for instance)
- if(iglob_image_color_2D(ix,iy) == -1) then
-
-! use light blue to display undefined region above topography
- R = 204
- G = 255
- B = 255
-
-! suppress small amplitudes considered as noise
- else if (abs(color_image_2D_data(ix,iy)) < amplitude_max * cutsnaps) then
-
-! use P velocity model as background where amplitude is negligible
- if((vpmax-vpmin)/vpmin > 0.02d0) then
- x1 = (image_color_vp_display(ix,iy)-vpmin)/(vpmax-vpmin)
- else
- x1 = 0.5d0
- endif
-
-! rescale to avoid very dark gray levels
- x1 = x1*0.7 + 0.2
- if(x1 > 1.d0) x1=1.d0
-
-! invert scale: white = vpmin, dark gray = vpmax
- x1 = 1.d0 - x1
-
-! map to [0,255]
- x1 = x1 * 255.d0
-
- R = nint(x1)
- if(R < 0) R = 0
- if(R > 255) R = 255
- G = R
- B = R
-
- else
-
-! define normalized image data in [-1:1] and convert to nearest integer
-! keeping in mind that data values can be negative
- normalized_value = color_image_2D_data(ix,iy) / amplitude_max
-
-! suppress values outside of [-1:+1]
- if(normalized_value < -1.d0) normalized_value = -1.d0
- if(normalized_value > 1.d0) normalized_value = 1.d0
-
-! use red if positive value, blue if negative, no green
- if(normalized_value >= 0.d0) then
- R = nint(255.d0*normalized_value**POWER_DISPLAY_COLOR)
- G = 0
- B = 0
- else
- R = 0
- G = 0
- B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY_COLOR)
- endif
-
- endif
-
-! write color image
- if(BINARY_FILE) then
-
-! first write red
- write(27,rec=current_rec) char(R)
- current_rec = current_rec + 1
-
-! then write green
- write(27,rec=current_rec) char(G)
- current_rec = current_rec + 1
-
-! then write blue
- write(27,rec=current_rec) char(B)
- current_rec = current_rec + 1
-
- else
-
- write(27,"(i3,' ',i3,' ',i3)") R,G,B
-
- endif
-
- enddo
- enddo
-
-! close the file
- close(27)
-
-! open image file and create system command to convert image to more convenient format
-! use the "convert" command from ImageMagick http://www.imagemagick.org
- write(system_command,"('cd OUTPUT_FILES ; convert image',i7.7,'.pnm image',i7.7,'.gif ; rm -f image',i7.7,'.pnm')") it,it,it
-
-! call the system to convert image to GIF
-! this line can be safely commented out if your compiler does not implement "system()" for system calls;
-! in such a case you will simply get images in PNM format in directory OUTPUT_FILES instead of GIF format
- call system(system_command)
-
- end subroutine create_color_image
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/createnum_fast.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/createnum_fast.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/createnum_fast.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,343 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
-
-! same as subroutine "createnum_slow" but with a faster algorithm
-
- implicit none
-
- include "constants.h"
-
- 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)
-
- integer i,j
-
-! additional arrays needed for this fast version
- integer, dimension(:), allocatable :: loc,ind,ninseg,iglob,iwork
- logical, dimension(:), allocatable :: ifseg
- double precision, dimension(:), allocatable :: xp,yp,work
-
- integer ie,nseg,ioff,iseg,ig
- integer nxyz,ntot,ispec,ieoff,ilocnum,iy,ix,in,nnum
-
- double precision xmaxval,xminval,ymaxval,yminval,xtol,xtypdist
- double precision xcor,ycor
-
-
-!---- create global mesh numbering
- 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
-
- allocate(loc(ntot))
- allocate(ind(ntot))
- allocate(ninseg(ntot))
- allocate(iglob(ntot))
- allocate(ifseg(ntot))
- allocate(xp(ntot))
- allocate(yp(ntot))
- allocate(work(ntot))
- allocate(iwork(ntot))
-
-! compute coordinates of the grid points
- do ispec=1,nspec
- ieoff = nxyz*(ispec - 1)
- ilocnum = 0
-
- do iy = 1,NGLLX
- do ix = 1,NGLLX
-
- ilocnum = ilocnum + 1
-
- xcor = zero
- ycor = zero
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xcor = xcor + shape(in,ix,iy)*coorg(1,nnum)
- ycor = ycor + shape(in,ix,iy)*coorg(2,nnum)
- enddo
-
- xp(ilocnum + ieoff) = xcor
- yp(ilocnum + ieoff) = ycor
-
- enddo
- enddo
-
- enddo
-
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-! Establish initial pointers
- do ie=1,nspec
- ieoff = nxyz*(ie -1)
- do ix=1,nxyz
- loc (ix+ieoff) = ix+ieoff
- enddo
- enddo
-
-! set up local geometric tolerances
-
- xtypdist=+HUGEVAL
-
- do ie=1,nspec
-
- xminval=+HUGEVAL
- yminval=+HUGEVAL
- xmaxval=-HUGEVAL
- ymaxval=-HUGEVAL
- ieoff=nxyz*(ie-1)
- do ilocnum=1,nxyz
- xmaxval=max(xp(ieoff+ilocnum),xmaxval)
- xminval=min(xp(ieoff+ilocnum),xminval)
- ymaxval=max(yp(ieoff+ilocnum),ymaxval)
- yminval=min(yp(ieoff+ilocnum),yminval)
- enddo
-
-! compute the minimum typical "size" of an element in the mesh
- xtypdist = min(xtypdist,xmaxval-xminval)
- xtypdist = min(xtypdist,ymaxval-yminval)
-
- enddo
-
-! define a tolerance, small with respect to the minimum size
- xtol = SMALLVALTOL * xtypdist
-
- ifseg(:) = .false.
- nseg = 1
- ifseg(1) = .true.
- ninseg(1) = ntot
-
- do j=1,NDIM
-! Sort within each segment
- ioff=1
- do iseg=1,nseg
- if(j == 1) then
- call rank (xp(ioff),ind,ninseg(iseg))
- else
- call rank (yp(ioff),ind,ninseg(iseg))
- endif
- call swap(xp(ioff),work,ind,ninseg(iseg))
- call swap(yp(ioff),work,ind,ninseg(iseg))
- call iswap(loc(ioff),iwork,ind,ninseg(iseg))
- ioff=ioff+ninseg(iseg)
- enddo
-! Check for jumps in current coordinate
- if (j == 1) then
- do i=2,ntot
- if (abs(xp(i)-xp(i-1)) > xtol) ifseg(i)=.true.
- enddo
- else
- do i=2,ntot
- if (abs(yp(i)-yp(i-1)) > xtol) ifseg(i)=.true.
- enddo
- endif
-! Count up number of different segments
- nseg = 0
- do i=1,ntot
- if (ifseg(i)) then
- nseg = nseg+1
- ninseg(nseg) = 1
- else
- ninseg(nseg) = ninseg(nseg) + 1
- endif
- enddo
- enddo
-!
-! Assign global node numbers (now sorted lexicographically!)
-!
- ig = 0
- do i=1,ntot
- if (ifseg(i)) ig=ig+1
- iglob(loc(i)) = ig
- enddo
-
- npoin = ig
-
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-! get result in my format
- do ispec=1,nspec
- ieoff = nxyz*(ispec - 1)
- ilocnum = 0
- do iy = 1,NGLLX
- do ix = 1,NGLLX
- ilocnum = ilocnum + 1
- ibool(ix,iy,ispec) = iglob(ilocnum + ieoff)
- enddo
- enddo
- enddo
-
- deallocate(loc)
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iglob)
- deallocate(ifseg)
- deallocate(xp)
- deallocate(yp)
- deallocate(work)
- deallocate(iwork)
-
-! 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
-
- end subroutine createnum_fast
-
-
-!-----------------------------------------------------------------------
-
- subroutine rank(A,IND,N)
-!
-! Use Heap Sort (p 233 Numerical Recipes)
-!
- implicit none
-
- integer N
- double precision A(N)
- integer IND(N)
-
- integer i,j,l,ir,indx
- double precision q
-
- do J=1,N
- IND(j)=j
- enddo
-
- if(n == 1) return
- L=n/2+1
- ir=n
- 100 continue
- IF(l > 1) THEN
- l=l-1
- indx=ind(l)
- q=a(indx)
- ELSE
- indx=ind(ir)
- q=a(indx)
- ind(ir)=ind(1)
- ir=ir-1
- if(ir == 1) then
- ind(1)=indx
- return
- endif
- ENDIF
- i=l
- j=l+l
- 200 continue
- IF(J <= IR) THEN
- IF(J < IR) THEN
- IF(A(IND(j)) < A(IND(j+1))) j=j+1
- ENDIF
- IF(q < A(IND(j))) THEN
- IND(I)=IND(J)
- I=J
- J=J+J
- ELSE
- J=IR+1
- ENDIF
- GOTO 200
- ENDIF
- IND(I)=INDX
- GOTO 100
-
- end subroutine rank
-
-!-----------------------------------------------------------------------
-
- subroutine swap(a,w,ind,n)
-!
-! Use IND to sort array A (p 233 Numerical Recipes)
-!
- implicit none
-
- integer n
- double precision A(N),W(N)
- integer IND(N)
-
- integer j
-
- W(:) = A(:)
-
- do J=1,N
- A(j) = W(ind(j))
- enddo
-
- end subroutine swap
-
-!-----------------------------------------------------------------------
-
- subroutine iswap(a,w,ind,n)
-!
-! Use IND to sort array A
-!
- implicit none
-
- integer n
- integer A(N),W(N),IND(N)
-
- integer j
-
- W(:) = A(:)
-
- do J=1,N
- A(j) = W(ind(j))
- enddo
-
- end subroutine iswap
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/createnum_slow.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/createnum_slow.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/createnum_slow.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,324 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
-
-! generate the global numbering
-
- implicit none
-
- include "constants.h"
-
- integer npoin,nspec,ngnod,myrank,ipass
-
- integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
-
- integer i,j,num2,i2,j2,ipos,ipos2,iloc,jloc,kloc
- integer ngnodloc,ngnodother,nedgeloc,nedgeother,npedge,numelem,npcorn
-
- logical alreadyexist
-
- integer, dimension(NEDGES) :: ngnod_begin,ngnod_end
-
-
-!---- create global mesh numbering
- if(myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Generating global mesh numbering (slow version)...'
- write(IOUT,*)
- endif
-
- npoin = 0
- npedge = 0
- npcorn = 0
-
-! define edges from the four control points
-
-! --- edge 1 linking point 1 to point 2
- ngnod_begin(1)= 1
- ngnod_end(1)= 2
-
-! --- edge 2 linking point 2 to point 3
- ngnod_begin(2)= 2
- ngnod_end(2)= 3
-
-! --- edge 3 linking point 3 to point 4
- ngnod_begin(3)= 3
- ngnod_end(3)= 4
-
-! --- edge 4 linking point 4 to point 1
- ngnod_begin(4)= 4
- ngnod_end(4)= 1
-
-! initialisation du tableau de numerotation globale
- ibool(:,:,:) = 0
-
- do numelem = 1,nspec
- do i=1,NGLLX
- do j=1,NGLLZ
-
-! verifier que le point n'a pas deja ete genere
-
- if(ibool(i,j,numelem) == 0) then
-
-!
-!---- point interieur a un element, donc forcement unique
-!
- if(i /= 1 .and. i /= NGLLX .and. j /= 1 .and. j /= NGLLZ) then
-
- npoin = npoin + 1
- ibool(i,j,numelem) = npoin
-
-!
-!---- point au coin d'un element, rechercher les coins des autres elements
-!
- else if((i == 1 .and. j == 1) .or. (i == 1 .and. j == NGLLZ) .or. &
- (i == NGLLX .and. j == 1) .or. (i == NGLLX .and. j == NGLLZ)) then
-
-! trouver numero local du coin
- if(i == 1 .and. j == 1) then
- ngnodloc = 1
- else if(i == NGLLX .and. j == 1) then
- ngnodloc = 2
- else if(i == NGLLX .and. j == NGLLZ) then
- ngnodloc = 3
- else if(i == 1 .and. j == NGLLZ) then
- ngnodloc = 4
- endif
-
-! rechercher si existe deja, forcement dans un element precedent
-
- alreadyexist = .false.
-
- if(numelem > 1) then
-
- do num2=1,numelem-1
-
-! ne rechercher que sur les 4 premiers points de controle et non sur ngnod
- do ngnodother=1,4
-
-! voir si ce coin a deja ete genere
- if(knods(ngnodother,num2) == knods(ngnodloc,numelem)) then
- alreadyexist = .true.
-
-! obtenir la numerotation dans l'autre element
- if(ngnodother == 1) then
- i2 = 1
- j2 = 1
- else if(ngnodother == 2) then
- i2 = NGLLX
- j2 = 1
- else if(ngnodother == 3) then
- i2 = NGLLX
- j2 = NGLLZ
- else if(ngnodother == 4) then
- i2 = 1
- j2 = NGLLZ
- else
- call exit_MPI('bad corner')
- endif
-
-! affecter le meme numero
- ibool(i,j,numelem) = ibool(i2,j2,num2)
-
-! sortir de la recherche
- goto 134
-
- endif
- enddo
- enddo
-
- 134 continue
-
- endif
-
-! si un ancien point n'a pas ete trouve, en generer un nouveau
- if(.not. alreadyexist) then
- npcorn = npcorn + 1
- npoin = npoin + 1
- ibool(i,j,numelem) = npoin
- endif
-
-!
-!---- point a l'interieur d'une arete, rechercher si autre arete correspondante
-!
- else
-
-! trouver numero local de l'arete
- if(j == 1) then
- nedgeloc = 1
- else if(i == NGLLX) then
- nedgeloc = 2
- else if(j == NGLLZ) then
- nedgeloc = 3
- else if(i == 1) then
- nedgeloc = 4
- endif
-
-! rechercher si existe deja, forcement dans un element precedent
-
- alreadyexist = .false.
-
- if(numelem > 1) then
-
- do num2=1,numelem-1
-
-! rechercher sur les 4 aretes
- do nedgeother=1,4
-
-!--- detecter un eventuel defaut dans la structure topologique du maillage
-
- if((knods(ngnod_begin(nedgeother),num2) == knods(ngnod_begin(nedgeloc),numelem)) &
- .and. &
- (knods(ngnod_end(nedgeother),num2) == knods(ngnod_end(nedgeloc),numelem))) then
- call exit_MPI('Improper topology of the input mesh detected')
-
-!--- sinon voir si cette arete a deja ete generee
-
- else if((knods(ngnod_begin(nedgeother),num2) == knods(ngnod_end(nedgeloc),numelem)) &
- .and. &
- (knods(ngnod_end(nedgeother),num2) == knods(ngnod_begin(nedgeloc),numelem))) then
-
- alreadyexist = .true.
-
-! obtenir la numerotation dans l'autre element
-! maillage conforme donc on doit supposer que NGLLX == NGLLZ
-
-! generer toute l'arete pour eviter des recherches superflues
- do kloc = 2,NGLLX-1
-
-! calculer l'abscisse le long de l'arete de depart
- if(nedgeloc == 1) then
- iloc = kloc
- jloc = 1
- ipos = iloc
- else if(nedgeloc == 2) then
- iloc = NGLLX
- jloc = kloc
- ipos = jloc
- else if(nedgeloc == 3) then
- iloc = kloc
- jloc = NGLLZ
- ipos = NGLLX - iloc + 1
- else if(nedgeloc == 4) then
- iloc = 1
- jloc = kloc
- ipos = NGLLZ - jloc + 1
- else
- call exit_MPI('bad nedgeloc')
- endif
-
-! calculer l'abscisse le long de l'arete d'arrivee
-! topologie du maillage coherente, donc sens de parcours des aretes opposes
-
- ipos2 = NGLLX - ipos + 1
-
-! calculer les coordonnees reelles dans l'element d'arrivee
- if(nedgeother == 1) then
- i2 = ipos2
- j2 = 1
- else if(nedgeother == 2) then
- i2 = NGLLX
- j2 = ipos2
- else if(nedgeother == 3) then
- i2 = NGLLX - ipos2 + 1
- j2 = NGLLZ
- else if(nedgeother == 4) then
- i2 = 1
- j2 = NGLLZ - ipos2 + 1
- else
- call exit_MPI('bad nedgeother')
- endif
-
-! verifier que le point de depart n'existe pas deja
- 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) call exit_MPI('unknown point in the mesh')
-
-! affecter le meme numero
- ibool(iloc,jloc,numelem) = ibool(i2,j2,num2)
-
- enddo
-
-! sortir de la recherche
- goto 135
-
- endif
- enddo
- enddo
-
- 135 continue
-
- endif
-
-! si un ancien point n'a pas ete trouve, en generer un nouveau
- if(.not. alreadyexist) then
- npedge = npedge + 1
- npoin = npoin + 1
- ibool(i,j,numelem) = npoin
- endif
-
- endif
-
- endif
-
- enddo
- enddo
- enddo
-
-! verification de la coherence de la numerotation generee
- 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
-
- end subroutine createnum_slow
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/datim.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/datim.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/datim.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,72 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine datim(string_input)
-
-! get date and time
-
- implicit none
-
- include "constants.h"
-
- character(len=50) string_input
- character(len=8) datein
- character(len=10) timein
- character(len=16) dateprint
- character(len=8) timeprint
-
- datein = ' '
- timein = ' '
-
- call date_and_time(datein,timein)
-
- dateprint = datein(7:8)//' - '//datein(5:6)//' - '//datein(1:4)
- timeprint = timein(1:2)//':'//timein(3:4)//':'//timein(5:6)
-
- write(iout,"(//1x,79('-')/1x,79('-')/1x,'Program SPECFEM2D: ')")
- write(iout,"(1x,79('-')/1x,79('-')/1x,a50)") string_input
- write(iout,"(1x,79('-')/,1x,79('-')/' D a t e : ',a16,30x,' T i m e : ',a8/1x,79('-'),/1x,79('-'))") dateprint,timeprint
-
- end subroutine datim
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/define_derivation_matrices.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/define_derivation_matrices.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/define_derivation_matrices.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,94 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
-
- implicit none
-
- include "constants.h"
-
-! Gauss-Lobatto-Legendre points of integration
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLZ) :: zigll
-
-! weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-! array with 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
-
-! function for calculating derivatives of Lagrange polynomials
- double precision, external :: lagrange_deriv_GLL
-
- integer i1,i2,k1,k2
-
-! set up coordinates of the Gauss-Lobatto-Legendre points
- call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
- call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
-
-! if number of points is odd, the middle abscissa is exactly zero
- if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
- if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
-
-! calculate derivatives of the Lagrange polynomials
-! and precalculate some products in double precision
-! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
- do i1=1,NGLLX
- do i2=1,NGLLX
- hprime_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)
- hprimewgll_xx(i2,i1) = wxgll(i2) * hprime_xx(i2,i1)
- enddo
- enddo
-
- do k1=1,NGLLZ
- do k2=1,NGLLZ
- hprime_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)
- hprimewgll_zz(k2,k1) = wzgll(k2) * hprime_zz(k2,k1)
- enddo
- enddo
-
- end subroutine define_derivation_matrices
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/define_external_model.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/define_external_model.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/define_external_model.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,91 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine define_external_model(x,y,iflag_element,myrank,rho,vp,vs,Qp_attenuation,&
- Qs_attenuation,c11,c13,c15,c33,c35,c55 )
-
- implicit none
-
- include "constants.h"
-
-! user can modify this routine to assign any different external Earth model (rho, vp, vs)
-! based on the x and y coordinates of that grid point and the flag of the region it belongs to
-
- integer, intent(in) :: iflag_element,myrank
-
- double precision, intent(in) :: x,y
-
- double precision, intent(out) :: rho,vp,vs
- double precision, intent(out) :: Qp_attenuation,Qs_attenuation
- double precision, intent(out) :: c11,c15,c13,c33,c35,c55
-
-! dummy routine here, just to demonstrate how the model can be assigned
- if(myrank == 0 .and. iflag_element == 1 .or. x < 1700.d0 .or. y >= 2300.d0) then
- rho = 2000.d0
- vp = 3000.d0
- vs = vp / sqrt(3.d0)
- Qp_attenuation = 0
- Qs_attenuation = 0
- c11 = 169.d9
- c13 = 122.d9
- c15 = 0.d0
- c33 = c11
- c35 = 0.d0
- c55 = 75.3d9
- else
- rho = 2500.d0
- vp = 3600.d0
- vs = vp / 2.d0
- Qp_attenuation = 60
- Qs_attenuation = 60
- c11 = 0.d0
- c13 = 0.d0
- c15 = 0.d0
- c33 = 0.d0
- c35 = 0.d0
- c55 = 0.d0
- endif
-
- end subroutine define_external_model
Deleted: seismo/2D/SPECFEM2D/trunk/src/define_shape_functions.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/define_shape_functions.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/define_shape_functions.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,170 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)
-
-!=======================================================================
-!
-! Set up the shape functions for the subparametric transformation.
-! The routine can handle 4 or 9 control nodes defined as follows:
-!
-! 4 . . . . 7 . . . . 3
-! . .
-! . t .
-! . .
-! 8 9 s 6
-! . .
-! . .
-! . .
-! 1 . . . . 5 . . . . 2
-!
-! Local coordinate system : s,t
-!
-!=======================================================================
-
- implicit none
-
- include "constants.h"
-
- integer ngnod
-
- double precision shape2D(ngnod)
- double precision dershape2D(NDIM,ngnod)
- double precision xi,gamma
-
- double precision s,t,sp,sm,tp,tm,s2,t2,ss,tt,st
-
-!
-!---- set up the shape functions and their local derivatives
-!
- s = xi
- t = gamma
-
-!---- 4-node element
- if(ngnod == 4) then
- sp = s + ONE
- sm = s - ONE
- tp = t + ONE
- tm = t - ONE
-
-!---- corner nodes
- shape2D(1) = QUART * sm * tm
- shape2D(2) = - QUART * sp * tm
- shape2D(3) = QUART * sp * tp
- shape2D(4) = - QUART * sm * tp
-
- dershape2D(1,1) = QUART * tm
- dershape2D(1,2) = - QUART * tm
- dershape2D(1,3) = QUART * tp
- dershape2D(1,4) = - QUART * tp
-
- dershape2D(2,1) = QUART * sm
- dershape2D(2,2) = - QUART * sp
- dershape2D(2,3) = QUART * sp
- dershape2D(2,4) = - QUART * sm
-
-!---- 9-node element
- else if(ngnod == 9) then
-
- sp = s + ONE
- sm = s - ONE
- tp = t + ONE
- tm = t - ONE
- s2 = s * TWO
- t2 = t * TWO
- ss = s * s
- tt = t * t
- st = s * t
-
-!---- corner nodes
- shape2D(1) = QUART * sm * st * tm
- shape2D(2) = QUART * sp * st * tm
- shape2D(3) = QUART * sp * st * tp
- shape2D(4) = QUART * sm * st * tp
-
- dershape2D(1,1) = QUART * tm * t * (s2 - ONE)
- dershape2D(1,2) = QUART * tm * t * (s2 + ONE)
- dershape2D(1,3) = QUART * tp * t * (s2 + ONE)
- dershape2D(1,4) = QUART * tp * t * (s2 - ONE)
-
- dershape2D(2,1) = QUART * sm * s * (t2 - ONE)
- dershape2D(2,2) = QUART * sp * s * (t2 - ONE)
- dershape2D(2,3) = QUART * sp * s * (t2 + ONE)
- dershape2D(2,4) = QUART * sm * s * (t2 + ONE)
-
-!---- midside nodes
- shape2D(5) = HALF * tm * t * (ONE - ss)
- shape2D(6) = HALF * sp * s * (ONE - tt)
- shape2D(7) = HALF * tp * t * (ONE - ss)
- shape2D(8) = HALF * sm * s * (ONE - tt)
-
- dershape2D(1,5) = -ONE * st * tm
- dershape2D(1,6) = HALF * (ONE - tt) * (s2 + ONE)
- dershape2D(1,7) = -ONE * st * tp
- dershape2D(1,8) = HALF * (ONE - tt) * (s2 - ONE)
-
- dershape2D(2,5) = HALF * (ONE - ss) * (t2 - ONE)
- dershape2D(2,6) = -ONE * st * sp
- dershape2D(2,7) = HALF * (ONE - ss) * (t2 + ONE)
- dershape2D(2,8) = -ONE * st * sm
-
-!---- center node
- shape2D(9) = (ONE - ss) * (ONE - tt)
-
- dershape2D(1,9) = -ONE * s2 * (ONE - tt)
- dershape2D(2,9) = -ONE * t2 * (ONE - ss)
-
- else
- call exit_MPI('Error: wrong number of control nodes')
- endif
-
-!--- check the shape functions and their derivatives
-! sum of shape functions should be one
-! sum of derivaticves of shape functions should be zero
- if(abs(sum(shape2D)-ONE) > TINYVAL) call exit_MPI('error shape functions')
- if(abs(sum(dershape2D(1,:))) > TINYVAL) call exit_MPI('error deriv xi shape functions')
- if(abs(sum(dershape2D(2,:))) > TINYVAL) call exit_MPI('error deriv gamma shape functions')
-
- end subroutine define_shape_functions
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/enforce_acoustic_free_surface.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/enforce_acoustic_free_surface.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/enforce_acoustic_free_surface.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,88 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
-
-! free surface for an acoustic medium
-! if acoustic, the free surface condition is a Dirichlet condition for the potential,
-! not Neumann, in order to impose zero pressure at the surface
-
- implicit none
-
- include "constants.h"
-
- integer :: nelem_acoustic_surface,npoin,nspec
-
- integer, dimension(5,nelem_acoustic_surface) :: acoustic_surface
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- real(kind=CUSTOM_REAL), dimension(npoin) :: &
- potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
-
-!---
-!--- local variables
-!---
-
- integer :: ispec_acoustic_surface,ispec,i,j,iglob
-
- do ispec_acoustic_surface = 1, nelem_acoustic_surface
-
- ispec = acoustic_surface(1,ispec_acoustic_surface)
-
- do j = acoustic_surface(4,ispec_acoustic_surface), acoustic_surface(5,ispec_acoustic_surface)
- do i = acoustic_surface(2,ispec_acoustic_surface), acoustic_surface(3,ispec_acoustic_surface)
- iglob = ibool(i,j,ispec)
- potential_acoustic(iglob) = ZERO
- potential_dot_acoustic(iglob) = ZERO
- potential_dot_dot_acoustic(iglob) = ZERO
- enddo
- enddo
-
- enddo
-
- end subroutine enforce_acoustic_free_surface
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/exit_mpi.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/exit_mpi.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/exit_mpi.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,75 +0,0 @@
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!-----------------------------------------------
-! subroutine to stop the code whether sequential or parallel.
-!-----------------------------------------------
-subroutine exit_MPI(error_msg)
-
- implicit none
-#ifdef USE_MPI
- ! standard include of the MPI library
- include "mpif.h"
-#endif
-
- ! identifier for error message file
- integer, parameter :: IERROR = 30
-
- character(len=*) error_msg
-
- integer ier
-
- ier = 0
-
- ! write error message to screen
- write(*,*) error_msg(1:len(error_msg))
- write(*,*) 'Error detected, aborting MPI... proc '
-
- ! stop all the MPI processes, and exit
-#ifdef USE_MPI
- call MPI_ABORT(MPI_COMM_WORLD,30,ier)
-#endif
-
- stop 'error, program ended in exit_MPI'
-
-end subroutine exit_MPI
Deleted: seismo/2D/SPECFEM2D/trunk/src/get_MPI.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/get_MPI.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/get_MPI.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,326 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-#ifdef USE_MPI
-
- subroutine get_MPI(nspec,ibool,knods,ngnod,npoin,elastic,poroelastic, &
- ninterface, max_interface_size, &
- my_nelmnts_neighbours,my_interfaces,my_neighbours, &
- 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, &
- myrank,ipass,coord)
-
-! sets up the MPI interface for communication between partitions
-
- implicit none
-
- include "constants.h"
- include 'mpif.h'
-
- integer, intent(in) :: nspec, npoin, ngnod
- logical, dimension(nspec), intent(in) :: elastic, poroelastic
- integer, dimension(ngnod,nspec), intent(in) :: knods
- integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
-
- integer :: ninterface
- integer :: max_interface_size
- integer, dimension(ninterface) :: my_nelmnts_neighbours,my_neighbours
- integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
-
- integer, dimension(NGLLX*max_interface_size,ninterface) :: &
- ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
- integer, dimension(ninterface) :: &
- nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
- integer, dimension(ninterface), intent(out) :: &
- inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
- integer, intent(out) :: ninterface_acoustic, ninterface_elastic, ninterface_poroelastic
-
- logical, dimension(nspec), intent(inout) :: mask_ispec_inner_outer
-
- integer :: myrank,ipass
- double precision, dimension(NDIM,npoin) :: coord
-
- !local parameters
- double precision, dimension(:), allocatable :: xp,zp
- double precision, dimension(:), allocatable :: work
- integer, dimension(:), allocatable :: locval
- integer, dimension(:), allocatable :: nibool_interfaces_true
- ! for MPI buffers
- integer, dimension(:), allocatable :: reorder_interface,ind,ninseg,iwork
- integer, dimension(:), allocatable :: ibool_dummy
-! integer, dimension(:,:), allocatable :: ibool_interfaces_dummy
- logical, dimension(:), allocatable :: ifseg
- integer :: iinterface,ilocnum
- integer :: num_points1, num_points2
- ! assembly test
- integer :: i,j,ispec,iglob,count,inum,ier,idomain
- integer :: max_nibool_interfaces,num_nibool,num_interface
- real(kind=CUSTOM_REAL), dimension(:),allocatable :: test_flag_cr
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_ac
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_ac
- integer, dimension(:), allocatable :: tab_requests_send_recv_acoustic
-
- ! gets global indices for points on MPI interfaces
- ! (defined by my_interfaces) between different partitions
- ! and stores them in ibool_interfaces*** & nibool_interfaces*** (number of total points)
- 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 )
-
-
- ! sorts ibool comm buffers lexicographically for all MPI interfaces
- num_points1 = 0
- num_points2 = 0
- allocate(nibool_interfaces_true(ninterface))
-
- do idomain = 1,3
-
- ! checks number of interface in this domain
- num_interface = 0
- if( idomain == 1 ) then
- num_interface = ninterface_acoustic
- elseif( idomain == 2 ) then
- num_interface = ninterface_elastic
- elseif( idomain == 3 ) then
- num_interface = ninterface_poroelastic
- endif
- if( num_interface == 0 ) cycle
-
- ! loops over interfaces
- do iinterface = 1, ninterface
-
- ! number of global points in this interface
- num_nibool = 0
- if( idomain == 1 ) then
- num_nibool = nibool_interfaces_acoustic(iinterface)
- elseif( idomain == 2 ) then
- num_nibool = nibool_interfaces_elastic(iinterface)
- elseif( idomain == 3 ) then
- num_nibool = nibool_interfaces_poroelastic(iinterface)
- endif
- ! checks if anything to sort
- if( num_nibool == 0 ) cycle
-
- allocate(xp(num_nibool))
- allocate(zp(num_nibool))
- allocate(locval(num_nibool))
- allocate(ifseg(num_nibool))
- allocate(reorder_interface(num_nibool))
- allocate(ibool_dummy(num_nibool))
- allocate(ind(num_nibool))
- allocate(ninseg(num_nibool))
- allocate(iwork(num_nibool))
- allocate(work(num_nibool))
-
- ! works with a copy of ibool array
- if( idomain == 1 ) then
- ibool_dummy(:) = ibool_interfaces_acoustic(1:num_nibool,iinterface)
- elseif( idomain == 2 ) then
- ibool_dummy(:) = ibool_interfaces_elastic(1:num_nibool,iinterface)
- elseif( idomain == 3 ) then
- ibool_dummy(:) = ibool_interfaces_poroelastic(1:num_nibool,iinterface)
- endif
-
- ! gets x,y,z coordinates of global points on MPI interface
- do ilocnum = 1, num_nibool
- iglob = ibool_dummy(ilocnum)
- xp(ilocnum) = coord(1,iglob)
- zp(ilocnum) = coord(2,iglob)
- enddo
-
- ! sorts (lexicographically?) ibool_interfaces and updates value
- ! of total number of points nibool_interfaces_true(iinterface)
- call sort_array_coordinates(num_nibool,xp,zp, &
- ibool_dummy, &
- reorder_interface,locval,ifseg, &
- nibool_interfaces_true(iinterface), &
- ind,ninseg,iwork,work)
-
- ! checks that number of MPI points are still the same
- num_points1 = num_points1 + num_nibool
- num_points2 = num_points2 + nibool_interfaces_true(iinterface)
- if( num_points1 /= num_points2 ) then
- write(IOUT,*) 'error sorting MPI interface points:',myrank
- write(IOUT,*) ' domain:',idomain
- write(IOUT,*) ' interface:',iinterface,num_points1,num_points2
- call exit_MPI('error sorting MPI interface')
- endif
-
- ! stores new order of ibool array
- if( idomain == 1 ) then
- ibool_interfaces_acoustic(1:num_nibool,iinterface) = ibool_dummy(:)
- elseif( idomain == 2 ) then
- ibool_interfaces_elastic(1:num_nibool,iinterface) = ibool_dummy(:)
- elseif( idomain == 3 ) then
- ibool_interfaces_poroelastic(1:num_nibool,iinterface) = ibool_dummy(:)
- endif
-
- ! cleanup temporary arrays
- deallocate(xp)
- deallocate(zp)
- deallocate(locval)
- deallocate(ifseg)
- deallocate(reorder_interface)
- deallocate(ibool_dummy)
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iwork)
- deallocate(work)
- enddo
- enddo
-
- ! cleanup
- deallocate(nibool_interfaces_true)
-
- ! outputs total number of MPI interface points
- call MPI_REDUCE(num_points2, num_points1, 1, MPI_INTEGER, &
- MPI_SUM, 0, MPI_COMM_WORLD, ier)
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) 'total MPI interface points: ',num_points1
- endif
-
- ! checks interfaces in acoustic domains
- inum = 0
- count = 0
- if ( ninterface_acoustic > 0) then
-
- ! checks with assembly of test fields
- allocate(test_flag_cr(npoin))
- test_flag_cr(:) = 0._CUSTOM_REAL
- count = 0
- do ispec = 1, nspec
- ! sets flags on global points
- do j = 1, NGLLZ
- do i = 1, NGLLX
- ! global index
- iglob = ibool(i,j,ispec)
-
- ! counts number of unique global points to set
- if( nint(test_flag_cr(iglob)) == 0 ) count = count+1
-
- ! sets identifier
- test_flag_cr(iglob) = myrank + 1.0
- enddo
- enddo
- enddo
-
- max_nibool_interfaces = maxval(nibool_interfaces_acoustic(:))
-
- allocate(tab_requests_send_recv_acoustic(ninterface_acoustic*2))
- allocate(buffer_send_faces_vector_ac(max_nibool_interfaces,ninterface_acoustic))
- allocate(buffer_recv_faces_vector_ac(max_nibool_interfaces,ninterface_acoustic))
- inum = 0
- do iinterface = 1, ninterface
- inum = inum + nibool_interfaces_acoustic(iinterface)
- enddo
- endif
-
- ! note: this mpi reduction awaits information from all processes.
- ! thus, avoid an mpi deadlock in case some of the paritions have no acoustic interface
- call MPI_REDUCE(inum, num_points1, 1, MPI_INTEGER, &
- MPI_SUM, 0, MPI_COMM_WORLD, ier)
-
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) ' acoustic interface points: ',num_points1
- endif
-
- ! checks if assembly works
- inum = 0
- if( ninterface_acoustic > 0 ) then
- ! adds contributions from different partitions to flag arrays
- ! custom_real arrays
- call assemble_MPI_vector_ac(test_flag_cr,npoin, &
- ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
- max_interface_size, max_nibool_interfaces,&
- ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
- tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
- buffer_recv_faces_vector_ac, my_neighbours)
-
- ! checks number of interface points
- inum = 0
- do iglob=1,npoin
- ! only counts flags with MPI contributions
- if( nint(test_flag_cr(iglob)) > myrank+1 ) inum = inum + 1
- enddo
-
- deallocate(tab_requests_send_recv_acoustic)
- deallocate(buffer_send_faces_vector_ac)
- deallocate(buffer_recv_faces_vector_ac)
- deallocate(test_flag_cr)
- endif
-
- ! note: this mpi reduction awaits information from all processes.
- call MPI_REDUCE(inum, num_points2, 1, MPI_INTEGER, &
- MPI_SUM, 0, MPI_COMM_WORLD, ier)
-
- if( myrank == 0 ) then
- if( ipass == 1 ) then
- write(IOUT,*) ' assembly acoustic MPI interface points:',num_points2
- endif
-
- ! they don't need to fit, somehow..
- !if( num_points2 /= num_points1 ) then
- ! print*,'error acoustic assembly:' !,myrank
- ! print*,' total = ',num_points1,' not equal to assembled ',num_points2
- ! call exit_MPI('error acoustic MPI assembly')
- !endif
- endif
-
- end subroutine get_MPI
-
-#endif
Deleted: seismo/2D/SPECFEM2D/trunk/src/get_node_number.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/get_node_number.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/get_node_number.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,94 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
-! *******************
-! meshing subroutines
-! *******************
-
-!--- global node number
-
-integer function num(i,j,nx)
-
- implicit none
-
- integer i,j,nx
-
- num = j*(nx+1) + i + 1
-
-end function num
-
-
-!--- global node number (when ngnod==4).
-integer function num_4(i,j,nx)
-
- implicit none
-
- integer i,j,nx
-
- num_4 = j*(nx+1) + i + 1
-
-end function num_4
-
-
-!--- global node number (when ngnod==9).
-integer function num_9(i,j,nx,nz)
-
- implicit none
-
- integer i,j,nx,nz
-
-
- if ( (mod(i,2) == 0) .and. (mod(j,2) == 0) ) then
- num_9 = j/2 * (nx+1) + i/2 + 1
- else
- if ( mod(j,2) == 0 ) then
- num_9 = (nx+1)*(nz+1) + j/2 * nx + ceiling(real(i)/real(2))
- else
- num_9 = (nx+1)*(nz+1) + nx*(nz+1) + floor(real(j)/real(2))*(nx*2+1) + i + 1
-
- endif
- endif
-
-end function num_9
Deleted: seismo/2D/SPECFEM2D/trunk/src/get_perm_cuthill_mckee.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/get_perm_cuthill_mckee.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/get_perm_cuthill_mckee.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,806 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! implement reverse Cuthill-McKee (1969) ordering, introduced in
-! E. Cuthill and J. McKee. Reducing the bandwidth of sparse symmetric matrices.
-! In Proceedings of the 1969 24th national conference, pages 157-172,
-! New-York, New-York, USA, 1969. ACM Press.
-! see for instance http://en.wikipedia.org/wiki/Cuthill%E2%80%93McKee_algorithm
-
- subroutine get_perm(ibool,perm,limit,nspec,nglob)
-
- implicit none
-
- include "constants.h"
-
-! local variables
- integer nspec,nglob_GLL_full
- integer nglob_four_corners_only,nglob
-
-! maximum number of neighbors of a spectral element (in principle, it could be any value)
- integer, parameter :: MAX_NUMBER_OF_NEIGHBORS = 50
-
-! input
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
-! output
- integer, dimension(nspec) :: perm
-
-! global corner numbers that need to be created
- integer, dimension(nglob) :: global_corner_number
-
- integer mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
- integer, dimension(:), allocatable :: ne,np,adj
- integer xadj(nspec+1)
-
-! arrays to store the permutation and inverse permutation of the Cuthill-McKee algorithm
- integer, dimension(nspec) :: invperm
-
- logical maskel(nspec)
-
- integer i,istart,istop,number_of_neighbors
-
-! only count the total size of the array that will be created, or actually create it
- logical count_only
- integer total_size_ne,total_size_adj,limit
-
-!
-!-----------------------------------------------------------------------
-!
- if(PERFORM_CUTHILL_MCKEE) then
-
- ! total number of points in the mesh
- nglob_GLL_full = nglob
-
- !---- call Charbel Farhat's routines
- call form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,nglob_GLL_full,ibool,nglob_four_corners_only)
- do i=1,nspec
- istart = mp(i)
- istop = mp(i+1) - 1
- enddo
-
- allocate(np(nglob_four_corners_only+1))
- count_only = .true.
- total_size_ne = 1
- allocate(ne(total_size_ne))
- call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only,nspec,count_only,total_size_ne)
- deallocate(ne)
- allocate(ne(total_size_ne))
- count_only = .false.
- call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only,nspec,count_only,total_size_ne)
- do i=1,nglob_four_corners_only
- istart = np(i)
- istop = np(i+1) - 1
- enddo
-
- count_only = .true.
- total_size_adj = 1
- allocate(adj(total_size_adj))
- call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_four_corners_only,&
- count_only,total_size_ne,total_size_adj)
- deallocate(adj)
- allocate(adj(total_size_adj))
- count_only = .false.
- call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_four_corners_only,&
- count_only,total_size_ne,total_size_adj)
- do i=1,nspec
- istart = xadj(i)
- istop = xadj(i+1) - 1
- number_of_neighbors = istop-istart+1
- if(number_of_neighbors < 1) stop 'error: your mesh seems to have at least one element not connected to any other'
- if(number_of_neighbors > MAX_NUMBER_OF_NEIGHBORS) stop 'error: your mesh seems to have an unlikely high valence'
- enddo
- deallocate(ne,np)
-
-! call the Cuthill-McKee sorting algorithm
- call cuthill_mckee(adj,xadj,perm,invperm,nspec,total_size_adj,limit)
- deallocate(adj)
- else
-! create identity permutation in order to do nothing
- do i=1,nspec
- perm(i) = i
- enddo
- endif
-
- end subroutine get_perm
-
-!=======================================================================
-!
-! Charbel Farhat's FEM topology routines
-!
-! Dimitri Komatitsch, February 1996 - Code based on Farhat's original version
-! described in his technical report from 1987
-!
-! modified and adapted by Dimitri Komatitsch, May 2006
-!
-!=======================================================================
-
- subroutine form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number, &
- nglob_GLL_full,ibool,nglob_four_corners_only)
-
-!-----------------------------------------------------------------------
-!
-! Forms the MN and MP arrays
-!
-! Input :
-! -------
-! ibool Array needed to build the element connectivity table
-! nspec Number of elements in the domain
-! NGNOD_QUADRANGLE number of nodes per hexahedron (brick with 8 corners)
-!
-! Output :
-! --------
-! MN, MP This is the element connectivity array pair.
-! Array MN contains the list of the element
-! connectivity, that is, the nodes contained in each
-! element. They are stored in a stacked fashion.
-!
-! Pointer array MP stores the location of each
-! element list. Its length is equal to the number
-! of elements plus one.
-!
-!-----------------------------------------------------------------------
-
- implicit none
-
- include "constants.h"
-
- integer nspec,nglob_GLL_full
-
-! arrays with mesh parameters per slice
- integer, intent(in), dimension(NGLLX,NGLLZ,nspec) :: ibool
-
-! global corner numbers that need to be created
- integer, intent(out), dimension(nglob_GLL_full) :: global_corner_number
- integer, intent(out) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
- integer, intent(out) :: nglob_four_corners_only
-
- integer ninter,nsum,ispec,node,k,inumcorner,ix,iy
-
- ninter = 1
- nsum = 1
- mp(1) = 1
-
-!---- define topology of the elements in the mesh
-!---- we need to define adjacent numbers from the sub-mesh consisting of the corners only
- nglob_four_corners_only = 0
- global_corner_number(:) = -1
-
- do ispec=1,nspec
-
- inumcorner = 0
- do iy = 1,NGLLZ,NGLLZ-1
- do ix = 1,NGLLX,NGLLX-1
-
- inumcorner = inumcorner + 1
- if(inumcorner > NGNOD_QUADRANGLE) stop 'corner number too large'
-
-! check if this point was already assigned a number previously, otherwise create one and store it
- if(global_corner_number(ibool(ix,iy,ispec)) == -1) then
- nglob_four_corners_only = nglob_four_corners_only + 1
- global_corner_number(ibool(ix,iy,ispec)) = nglob_four_corners_only
- endif
-
- node = global_corner_number(ibool(ix,iy,ispec))
- do k=nsum,ninter-1
- if(node == mn(k)) goto 200
- enddo
-
- mn(ninter) = node
- ninter = ninter + 1
- 200 continue
-
- enddo
- enddo
-
- nsum = ninter
- mp(ispec + 1) = nsum
-
- enddo
-
- end subroutine form_elt_connectivity_foelco
-
-!
-!----------------------------------------------------
-!
-
- subroutine form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only, &
- nspec,count_only,total_size_ne)
-
-!-----------------------------------------------------------------------
-!
-! Forms the NE and NP arrays
-!
-! Input :
-! -------
-! MN, MP, nspec
-! nglob_four_corners_only Number of nodes in the domain
-!
-! Output :
-! --------
-! NE, NP This is the node-connected element array pair.
-! Integer array NE contains a list of the
-! elements connected to each node, stored in stacked fashion.
-!
-! Array NP is the pointer array for the
-! location of a node's element list in the NE array.
-! Its length is equal to the number of points plus one.
-!
-!-----------------------------------------------------------------------
-
- implicit none
-
- include "constants.h"
-
-! only count the total size of the array that will be created, or actually create it
- logical count_only
- integer total_size_ne
-
- integer nglob_four_corners_only,nspec
-
- integer, intent(in) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
-
- integer, intent(out) :: ne(total_size_ne),np(nglob_four_corners_only+1)
-
- integer nsum,inode,ispec,j
-
- nsum = 1
- np(1) = 1
-
- do inode=1,nglob_four_corners_only
- do 200 ispec=1,nspec
-
- do j=mp(ispec),mp(ispec + 1) - 1
- if (mn(j) == inode) then
- if(count_only) then
- total_size_ne = nsum
- else
- ne(nsum) = ispec
- endif
- nsum = nsum + 1
- goto 200
- endif
- enddo
- 200 continue
-
- np(inode + 1) = nsum
-
- enddo
-
- end subroutine form_node_connectivity_fonoco
-
-!
-!----------------------------------------------------
-!
-
- subroutine create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec, &
- nglob_four_corners_only,count_only,total_size_ne,total_size_adj)
-
-!-----------------------------------------------------------------------
-!
-! Establishes the element adjacency information of the mesh
-! Two elements are considered adjacent if they share a face.
-!
-! Input :
-! -------
-! MN, MP, NE, NP, nspec
-! MASKEL logical mask (length = nspec)
-!
-! Output :
-! --------
-! ADJ, XADJ This is the element adjacency array pair. Array
-! ADJ contains the list of the elements adjacent to
-! element i. They are stored in a stacked fashion.
-! Pointer array XADJ stores the location of each element list.
-!
-!-----------------------------------------------------------------------
-
- implicit none
-
- include "constants.h"
-
-! only count the total size of the array that will be created, or actually create it
- logical count_only
- integer total_size_ne,total_size_adj
-
- integer nglob_four_corners_only
-
- integer nspec,iad,ispec,istart,istop,ino,node,jstart,jstop,nelem,jel
-
- integer, intent(in) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1),ne(total_size_ne),np(nglob_four_corners_only+1)
-
- integer, intent(out) :: adj(total_size_adj),xadj(nspec+1)
-
- logical maskel(nspec)
- integer countel(nspec)
-
- xadj(1) = 1
- iad = 1
-
- do ispec=1,nspec
-
-! reset mask
- maskel(:) = .false.
-
-! mask current element
- maskel(ispec) = .true.
- if (FACE) countel(:) = 0
-
- istart = mp(ispec)
- istop = mp(ispec+1) - 1
- do ino=istart,istop
- node = mn(ino)
- jstart = np(node)
- jstop = np(node + 1) - 1
- do 120 jel=jstart,jstop
- nelem = ne(jel)
- if(maskel(nelem)) goto 120
- if (FACE) then
-!! DK DK this below implemented by David Michea in 3D, but not true anymore in 2D: should be
-!! DK DK two corners instead of three. But does not matter because FACE is always .false.
-!! DK DK and therefore this part of the routine is currently never used.
-!! DK DK Let me add a stop statement just in case.
- stop 'FACE = .true. not implemented, check the above comment in the source code'
-!! DK DK End of the stop statement added.
- ! if 2 elements share at least 3 corners, therefore they share a face
- countel(nelem) = countel(nelem) + 1
- if (countel(nelem)>=3) then
- if(count_only) then
- total_size_adj = iad
- else
- adj(iad) = nelem
- endif
- maskel(nelem) = .true.
- iad = iad + 1
- endif
- else
- if(count_only) then
- total_size_adj = iad
- else
- adj(iad) = nelem
- endif
- maskel(nelem) = .true.
- iad = iad + 1
- endif
- 120 continue
- enddo
-
- xadj(ispec+1) = iad
-
- enddo
-
- end subroutine create_adjacency_table_adjncy
-
-!
-!----------------------------------------------------
-!
-
- subroutine cuthill_mckee(adj,xadj,mask,invperm_all,nspec,total_size_adj,limit)
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: nspec,total_size_adj, limit
- integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
-
- integer, intent(out), dimension(nspec) :: mask,invperm_all
- integer, dimension(nspec) :: invperm_sub
- integer ispec,gsize,counter,nspec_sub,root,total_ordered_elts, next_root
-
-! fill the mask with ones
- mask(:) = 1
- invperm_all(:) = 0
- counter = 0
- nspec_sub = limit
- root = 1
- total_ordered_elts = 0
-
- do while(total_ordered_elts < nspec)
- ! creation of a sublist of sorted elements which fit in the cache (the criterion of size is limit)
- ! limit = nb of elements that can fit in the L2 cache
- call Cut_McK( root, nspec, total_size_adj, xadj, adj, mask, gsize, invperm_sub, limit, nspec_sub, next_root)
- ! add the sublist in the main permutation list
- invperm_all(total_ordered_elts+1:total_ordered_elts+nspec_sub) = invperm_sub(1:nspec_sub)
- total_ordered_elts = total_ordered_elts + nspec_sub
- ! seek for a new root to build the new sublist
- if (next_root > 0) then
- root = next_root
- else
- if (total_ordered_elts /= nspec) &
- call find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
- root = next_root
- endif
- enddo
-
- if (INVERSE) then
- do ispec=1,nspec
- mask(invperm_all(ispec)) = ispec
- enddo
- else
- mask(:) = invperm_all(:)
- endif
-
- end subroutine cuthill_mckee
-
-
-!*******************************************************************************
-! Objective: Cuthill-McKee ordering
-! The algorithm is:
-!
-! X(1) = ROOT.
-! for ( I = 1 to N-1)
-! Find all unlabeled neighbors of X(I),
-! assign them the next available labels, in order of increasing degree.
-!
-! Parameters:
-! root the starting point for the cm ordering.
-! nbnodes the number of nodes.
-! nnz the number of adjacency entries.
-!
-! xadj/adj the graph
-! mask only those nodes with nonzero mask are considered
-!
-! gsize the number of the connected component
-! invp Inverse permutation (from new order to old order)
-!*******************************************************************************
-
-subroutine find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
-
- implicit none
-
- include "constants.h"
-
-! input
- integer, intent(in) :: total_size_adj,total_ordered_elts,nspec
- integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
- integer, intent(in), dimension(nspec) :: mask,invperm_all
-! output
- integer, intent(out) :: next_root
-! variables
- integer :: cur_node,neighbor_node,i,j
-
- do i=total_ordered_elts, 1, -1
- cur_node = invperm_all(i)
- do j= xadj(cur_node), xadj(cur_node+1)-1
- neighbor_node = adj(j)
- if (mask(neighbor_node)/=0) then
- next_root=neighbor_node
- return
- endif
- enddo
- enddo
-
-end subroutine find_next_root
-
-!*******************************************************************************
-! Objective: Cuthill-McKee ordering
-! The algorithm is:
-!
-! X(1) = ROOT.
-! for ( I = 1 to N-1)
-! Find all unlabeled neighbors of X(I),
-! assign them the next available labels, in order of increasing degree.
-!
-! Parameters:
-! root the starting point for the cm ordering.
-! nbnodes the number of nodes.
-! nnz the number of adjacency entries.
-!
-! xadj/adj the graph
-! mask only those nodes with nonzero mask are considered
-!
-! gsize the number of the connected component
-! invp Inverse permutation (from new order to old order)
-!*******************************************************************************
-
-subroutine Cut_McK( root, nbnodes, nnz, xadj, adj, mask, gsize, invp, limit, nspec_sub, next_root)
-
- implicit none
-
- include "constants.h"
-
-!--------------------------------------------------------------- Input Variables
- integer root, nnz, nbnodes, limit, nspec_sub, next_root
-
- integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
-
-!-------------------------------------------------------------- Output Variables
- integer gsize
- integer invp(nbnodes)
-
-!--------------------------------------------------------------- Local Variables
- integer i, j, k, l, lbegin, lnbr, linvp, lvlend, nbr, node, fnbr
- integer deg(nbnodes)
-
-! Find the degrees of the nodes in the subgraph specified by mask and root
-! Here invp is used to store a levelization of the subgraph
- invp(:)=0
- deg(:)=0
- call degree ( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, invp)
-
- mask(root) = 0
-
- IF (gsize > 1) THEN
- !If there is at least 2 nodes in the subgraph
- lvlend = 0
- lnbr = 1
-
- DO while (lvlend < lnbr)
- !lbegin/lvlend point to the begin/end of the present level
- lbegin = lvlend + 1
- lvlend = lnbr
-
- do i= lbegin, lvlend
- node = invp(i)
-
- !Find the unnumbered neighbours of node.
- !fnbr/lnbr point to the first/last neighbors of node
- fnbr = lnbr + 1
- do j= xadj(node), xadj(node+1)-1
- nbr = adj(j)
-
- if (mask(nbr) /= 0) then
- lnbr = lnbr + 1
- mask(nbr) = 0
- invp(lnbr) = nbr
- endif
- enddo
-
- !If no neighbors, go to next node in this level.
- IF (lnbr > fnbr) THEN
- !Sort the neighbors of NODE in increasing order by degree.
- !Linear insertion is used.
- k = fnbr
- do while (k < lnbr)
- l = k
- k = k + 1
- nbr = invp(k)
-
- DO WHILE (fnbr < l)
- linvp = invp(l)
-
- if (deg(linvp) <= deg(nbr)) then
- exit
- endif
-
- invp(l+1) = linvp
- l = l-1
- ENDDO
-
- invp(l+1) = nbr
- enddo
- ENDIF
- enddo
- ENDDO
-
- ENDIF
-
- if (gsize > limit) then
- do i = limit + 1 , nbnodes
- node=invp(i)
- if (node /=0) mask(node) = 1
- enddo
- next_root = invp(limit +1)
- nspec_sub = limit
- else
- next_root = -1
- nspec_sub = gsize
- endif
-
-END subroutine Cut_McK
-
-
-!*******************************************************************************
-! Objective: computes the degrees of the nodes in the connected graph
-!
-! Parameters:
-! root the root node
-! nbnodes the number of nodes in the graph
-! nnz the graph size
-! xadj/adj the whole graph
-! mask Only nodes with mask == 0 are considered
-!
-! gsize the number of nodes in the connected graph
-! deg degree for all the nodes in the connected graph
-! level levelization of the connected graph
-!
-!*******************************************************************************
-
-subroutine degree( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, level )
-
- implicit none
-
-!--------------------------------------------------------------- Input Variables
- integer root, nbnodes, nnz
- integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
-
-!-------------------------------------------------------------- Output Variables
- integer gsize
- integer deg(nbnodes), level(nbnodes)
-
-!--------------------------------------------------------------- Local Variables
- integer i, j, ideg, lbegin, lvlend, lvsize, nxt, nbr, node
-
-! added a test to detect disconnected subsets in the mesh
-! (in which case Cuthill-McKee fails and should be turned off)
- if(root > nbnodes+1) stop 'error: root > nbnodes+1 in Cuthill-McKee'
- if(root < 1) then
- print *,'error: root < 1 in Cuthill-McKee; you probably have a mesh composed of'
- print *,'two disconnected subsets of elements, in which case Cuthill-McKee fails and should be turned off.'
- print *,'please set PERFORM_CUTHILL_MCKEE = .false. in constants.h and recompile.'
- print *,'please also doublecheck that you indeed want to run two separate meshes simultaneously,'
- print *,'which is extremely unusual (but formally not incorrect).'
- stop 'fatal error in Cuthill-McKee'
- endif
-
-! The sign of xadj(I) is used to indicate if node i has been considered
- xadj(root) = -xadj(root)
- level(1) = root
- nxt = 1
- lvlend = 0
- lvsize = 1
-
- DO WHILE (lvsize > 0)
- ! lbegin/lvlend points the begin/end of the present level
- lbegin = lvlend + 1
- lvlend = nxt
-
- ! Find the degrees of nodes in the present level and generate the next level
- DO i= lbegin, lvlend
- node = level(i)
- ideg = 0
- do j= ABS( xadj(node) ), ABS( xadj(node+1) )-1
- nbr = adj(j)
-
- if (mask(nbr) /= 0) then
- ideg = ideg + 1
-
- if (xadj(nbr) >= 0) then
- xadj(nbr) = -xadj(nbr)
- nxt = nxt + 1
- level(nxt) = nbr
- endif
- endif
- enddo
-
- deg(node) = ideg
- ENDDO
-
- !Compute the level size of the next level
- lvsize = nxt - lvlend
- ENDDO
-
- !Reset xadj to its correct sign
- do i = 1, nxt
- node = level(i)
- xadj(node) = -xadj(node)
- enddo
-
- gsize = nxt
-
-END subroutine degree
-
-!
-!-----------------------------------------------------------------------
-!
-
- subroutine permute_elements_real(array_to_permute,temp_array,perm,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: nspec
- integer, intent(in), dimension(nspec) :: perm
-
- real(kind=CUSTOM_REAL), intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
-
- integer old_ispec,new_ispec
-
-! copy the original array
- temp_array(:,:,:) = array_to_permute(:,:,:)
-
- do old_ispec = 1,nspec
- new_ispec = perm(old_ispec)
- array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
- enddo
-
- end subroutine permute_elements_real
-
-!
-!-----------------------------------------------------------------------
-!
-
-! implement permutation of elements for arrays of integer type
- subroutine permute_elements_integer(array_to_permute,temp_array,perm,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: nspec
- integer, intent(in), dimension(nspec) :: perm
-
- integer, intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
-
- integer old_ispec,new_ispec
-
-! copy the original array
- temp_array(:,:,:) = array_to_permute(:,:,:)
-
- do old_ispec = 1,nspec
- new_ispec = perm(old_ispec)
- array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
- enddo
-
- end subroutine permute_elements_integer
-
-!
-!-----------------------------------------------------------------------
-!
-
-! implement permutation of elements for arrays of double precision type
- subroutine permute_elements_dble(array_to_permute,temp_array,perm,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: nspec
- integer, intent(in), dimension(nspec) :: perm
-
- double precision, intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
-
- integer old_ispec,new_ispec
-
-! copy the original array
- temp_array(:,:,:) = array_to_permute(:,:,:)
-
- do old_ispec = 1,nspec
- new_ispec = perm(old_ispec)
- array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
- enddo
-
- end subroutine permute_elements_dble
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/get_poroelastic_velocities.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/get_poroelastic_velocities.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/get_poroelastic_velocities.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,155 +0,0 @@
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!----
-!---- subroutine to compute poroelastic velocities cpI, cpII, & cs as a function of the dominant frequency
-!----
-
- subroutine get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
- tortl,rhol_s,rhol_f,etal_f,perm,fi,f0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- implicit none
-
- include "constants.h"
-
- double precision :: f0,w0il
- double precision :: H_biot,C_biot,M_biot
- double precision :: cpIsquare,cpIIsquare
- double precision :: cssquare,att_I,att_II
- double precision :: etal_f,rhol_f,rhol_s,rhol_bar,perm
- double precision :: mul_fr,phil,tortl
-
- double precision :: a_r,a_i,b_r,b_i,cc,alpha,aa1,aa2
- double precision :: xx,yy, gXI, gYI,gXII,gYII,w_c,f_c
- double precision :: wi,fi,taus,taue,Q0,bbr,bbi
-
- double precision :: gA,gB,sa,sb,xxs,yys
- logical :: TURN_VISCATTENUATION_ON
-
- rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
-
- w_c = etal_f*phil/(tortl*rhol_f*perm)
- f_c = w_c/(2*pi)
-
- wi=2.d0*pi*fi
-
- alpha=10.d0**dlog10(wi)
- w0il = 2.d0*pi*f0
- taue = (sqrt(Q0*Q0+1) +1)/(w0il*Q0)
- taus = (sqrt(Q0*Q0+1) -1)/(w0il*Q0)
-
- if(TURN_VISCATTENUATION_ON) then
-! high frequency, with memory variables
- bbr = etal_f/perm*(1.d0+alpha*alpha*taus*taue)/(1.d0 + alpha*alpha*taus*taus)
- bbi = etal_f/perm*alpha*(taue-taus)/(1.d0 + alpha*alpha*taus*taus)
- else
-! low frequency
- bbr = etal_f/perm
- bbi = 0.d0
- endif
-
-! cs
- gA = (rhol_f*tortl*rhol_bar-phil*rhol_f**2)**2/(phil*rhol_bar)**2 - (bbr**2-bbi**2)/alpha**2*&
- (phil*rhol_f/(rhol_bar*tortl) -1.d0) - bbi/alpha*phil*rhol_f/(rhol_bar*tortl)*&
- (rhol_f*tortl*rhol_bar-phil*rhol_f**2)/(phil*rhol_bar)
- gB = -2.d0*bbr*bbi/alpha**2*(phil*rhol_f/(rhol_bar*tortl) -1.d0) + bbr/alpha*phil*rhol_f/&
- (rhol_bar*tortl)*(rhol_f*tortl*rhol_bar-phil*rhol_f**2)/(phil*rhol_bar)
-!
- sa = (rhol_f*tortl*rhol_bar-phil*rhol_f**2)**2/(phil*rhol_bar)**2 + (bbr**2-bbi**2)/alpha**2
- sb = 2.d0*bbr*bbi/alpha**2
-!
- xxs = sa*gA + sb*gB
- yys = gA*sb - sa*gB
-
- cssquare = mul_fr/(rhol_bar-phil*rhol_f/tortl) * 2.d0*(gA**2+gB**2)/(sqrt(xxs**2+yys**2)+xxs)
-
-
-! cpI & cpII
- a_r = rhol_bar - phil*rhol_f/tortl - phil*rhol_bar/(tortl*rhol_f)*bbi/alpha
- a_i = phil*rhol_bar/(tortl*rhol_f)*bbr
- b_r = H_biot + M_biot*phil*rhol_bar/(tortl*rhol_f) - 2.d0*phil*C_biot/tortl - &
- phil*H_biot/(tortl*rhol_f)*bbi/alpha
- b_i = phil*H_biot/(tortl*rhol_f)*bbr
- cc = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
-!
- xx = b_r*b_r - b_i*b_i/(alpha*alpha) - 4.d0*a_r*cc
- yy = 2.d0*b_r*b_i/alpha - 4.d0*a_i/alpha*cc
-!
- gXI = a_r*(b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) + &
- a_i/alpha*(b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
-
- gYI = a_i/alpha*(b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) - &
- a_r*(b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
- gYI = -gYI
-
- gXII = a_r*(b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) + &
- a_i/alpha*(b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
-
- gYII = a_i/alpha*(b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) - &
- a_r*(b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
- gYII = -gYII
-!
-!
-!
- cpIsquare = ((b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2 + &
- (b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)/&
- (sqrt(gXI**2+gYI**2) + gXI)
-
- cpIIsquare = ((b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2 + &
- (b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)/&
- (sqrt(gXII**2+gYII**2) + gXII)
-
-! attenuation factors
- att_I = -alpha*sign(1.d0,yy)*sqrt(sqrt(gXI**2+gYI**2)-gXI) / &
- sqrt((b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2+&
- (b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)
- att_II = -alpha*sign(1.d0,yy)*sqrt(sqrt(gXII**2+gYII**2)-gXII) / &
- sqrt((b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2+&
- (b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)
-
-! inverse quality factors
- aa1 = -gYI/gXI
- aa2 = -gYII/gXII
-
- end subroutine get_poroelastic_velocities
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/gll_library.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/gll_library.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/gll_library.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,534 +0,0 @@
-
-!=======================================================================
-!
-! Library to compute the Gauss-Lobatto-Legendre points and weights
-! Based on Gauss-Lobatto routines from M.I.T.
-! Department of Mechanical Engineering
-!
-!=======================================================================
-
- double precision function endw1(n,alpha,beta)
-
- implicit none
-
- integer n
- double precision alpha,beta
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
- double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
- double precision, external :: gammaf
- integer i
-
- f3 = zero
- apb = alpha+beta
- if(n == 0) then
- endw1 = zero
- return
- endif
- f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
- f1 = f1*(apb+two)*two**(apb+two)/two
- if(n == 1) then
- endw1 = f1
- return
- endif
- fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
- fint1 = fint1*two**(apb+two)
- fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
- fint2 = fint2*two**(apb+three)
- f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
- if(n == 2) then
- endw1 = f2
- return
- endif
- do i=3,n
- di = dble(i-1)
- abn = alpha+beta+di
- abnn = abn+di
- a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
- a2 = (two*(alpha-beta))/(abnn*(abnn+two))
- a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
- f3 = -(a2*f2+a1*f1)/a3
- f1 = f2
- f2 = f3
- enddo
- endw1 = f3
-
- end function endw1
-
-!
-!=======================================================================
-!
-
- double precision function endw2(n,alpha,beta)
-
- implicit none
-
- integer n
- double precision alpha,beta
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
- double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
- double precision, external :: gammaf
- integer i
-
- apb = alpha+beta
- f3 = zero
- if (n == 0) then
- endw2 = zero
- return
- endif
- f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
- f1 = f1*(apb+two)*two**(apb+two)/two
- if (n == 1) then
- endw2 = f1
- return
- endif
- fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
- fint1 = fint1*two**(apb+two)
- fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
- fint2 = fint2*two**(apb+three)
- f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
- if (n == 2) then
- endw2 = f2
- return
- endif
- do i=3,n
- di = dble(i-1)
- abn = alpha+beta+di
- abnn = abn+di
- a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
- a2 = (two*(alpha-beta))/(abnn*(abnn+two))
- a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
- f3 = -(a2*f2+a1*f1)/a3
- f1 = f2
- f2 = f3
- enddo
- endw2 = f3
-
- end function endw2
-
-!
-!=======================================================================
-!
-
- double precision function gammaf (x)
-
- implicit none
-
- double precision, parameter :: pi = 3.141592653589793d0
-
- double precision x
-
- double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
-
- gammaf = one
-
- if (x == -half) gammaf = -two*sqrt(pi)
- if (x == half) gammaf = sqrt(pi)
- if (x == one ) gammaf = one
- if (x == two ) gammaf = one
- if (x == 1.5d0) gammaf = sqrt(pi)/2.d0
- if (x == 2.5d0) gammaf = 1.5d0*sqrt(pi)/2.d0
- if (x == 3.5d0) gammaf = 2.5d0*1.5d0*sqrt(pi)/2.d0
- if (x == 3.d0 ) gammaf = 2.d0
- if (x == 4.d0 ) gammaf = 6.d0
- if (x == 5.d0 ) gammaf = 24.d0
- if (x == 6.d0 ) gammaf = 120.d0
-
- end function gammaf
-
-!
-!=====================================================================
-!
-
- subroutine jacg (xjac,np,alpha,beta)
-
-!=======================================================================
-!
-! computes np Gauss points, which are the zeros of the
-! Jacobi polynomial with parameters alpha and beta
-!
-! .alpha = beta = 0.0 -> Legendre points
-! .alpha = beta = -0.5 -> Chebyshev points
-!
-!=======================================================================
-
- implicit none
-
- integer np
- double precision alpha,beta
- double precision xjac(np)
-
- integer k,j,i,jmin,jm,n
- double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
- double precision p,pd,pm1,pdm1,pm2,pdm2
-
- integer, parameter :: K_MAX_ITER = 10
- double precision, parameter :: zero = 0.d0, eps = 1.0d-12
-
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- xlast = 0.d0
- n = np-1
- dth = 4.d0*atan(1.d0)/(2.d0*dble(n)+2.d0)
- p = 0.d0
- pd = 0.d0
- jmin = 0
- do j=1,np
- if(j == 1) then
- x = cos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
- else
- x1 = cos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
- x2 = xlast
- x = (x1+x2)/2.d0
- endif
- do k=1,K_MAX_ITER
- call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
- recsum = 0.d0
- jm = j-1
- do i=1,jm
- recsum = recsum+1.d0/(x-xjac(np-i+1))
- enddo
- delx = -p/(pd-recsum*p)
- x = x+delx
- if(abs(delx) < eps) goto 31
- enddo
- 31 continue
- xjac(np-j+1) = x
- xlast = x
- enddo
- do i=1,np
- xmin = 2.d0
- do j=i,np
- if(xjac(j) < xmin) then
- xmin = xjac(j)
- jmin = j
- endif
- enddo
- if(jmin /= i) then
- swap = xjac(i)
- xjac(i) = xjac(jmin)
- xjac(jmin) = swap
- endif
- enddo
-
- end subroutine jacg
-
-!
-!=====================================================================
-!
-
- subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
-
-!=======================================================================
-!
-! Computes the Jacobi polynomial of degree n and its derivative at x
-!
-!=======================================================================
-
- implicit none
-
- double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
- integer n
-
- double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
- integer k
-
- apb = alp+bet
- poly = 1.d0
- pder = 0.d0
- psave = 0.d0
- pdsave = 0.d0
-
- if (n == 0) return
-
- polyl = poly
- pderl = pder
- poly = (alp-bet+(apb+2.d0)*x)/2.d0
- pder = (apb+2.d0)/2.d0
- if (n == 1) return
-
- do k=2,n
- dk = dble(k)
- a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
- a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
- b3 = (2.d0*dk+apb-2.d0)
- a3 = b3*(b3+1.d0)*(b3+2.d0)
- a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
- polyn = ((a2+a3*x)*poly-a4*polyl)/a1
- pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
- psave = polyl
- pdsave = pderl
- polyl = poly
- poly = polyn
- pderl = pder
- pder = pdern
- enddo
-
- polym1 = polyl
- pderm1 = pderl
- polym2 = psave
- pderm2 = pdsave
-
- end subroutine jacobf
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision FUNCTION PNDLEG (Z,N)
-
-!------------------------------------------------------------------------
-!
-! Compute the derivative of the Nth order Legendre polynomial at Z.
-! Based on the recursion formula for the Legendre polynomials.
-!
-!------------------------------------------------------------------------
- implicit none
-
- double precision z
- integer n
-
- double precision P1,P2,P1D,P2D,P3D,FK,P3
- integer k
-
- P1 = 1.d0
- P2 = Z
- P1D = 0.d0
- P2D = 1.d0
- P3D = 1.d0
-
- do K = 1, N-1
- FK = dble(K)
- P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
- P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
- P1 = P2
- P2 = P3
- P1D = P2D
- P2D = P3D
- enddo
-
- PNDLEG = P3D
-
- end function pndleg
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision FUNCTION PNLEG (Z,N)
-
-!------------------------------------------------------------------------
-!
-! Compute the value of the Nth order Legendre polynomial at Z.
-! Based on the recursion formula for the Legendre polynomials.
-!
-!------------------------------------------------------------------------
- implicit none
-
- double precision z
- integer n
-
- double precision P1,P2,P3,FK
- integer k
-
- P1 = 1.d0
- P2 = Z
- P3 = P2
-
- do K = 1, N-1
- FK = dble(K)
- P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
- P1 = P2
- P2 = P3
- enddo
-
- PNLEG = P3
-
- end function pnleg
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision function pnormj (n,alpha,beta)
-
- implicit none
-
- double precision alpha,beta
- integer n
-
- double precision one,two,dn,const,prod,dindx,frac
- double precision, external :: gammaf
- integer i
-
- one = 1.d0
- two = 2.d0
- dn = dble(n)
- const = alpha+beta+one
-
- if (n <= 1) then
- prod = gammaf(dn+alpha)*gammaf(dn+beta)
- prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
- pnormj = prod * two**const/(two*dn+const)
- return
- endif
-
- prod = gammaf(alpha+one)*gammaf(beta+one)
- prod = prod/(two*(one+const)*gammaf(const+one))
- prod = prod*(one+alpha)*(two+alpha)
- prod = prod*(one+beta)*(two+beta)
-
- do i=3,n
- dindx = dble(i)
- frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
- prod = prod*frac
- enddo
-
- pnormj = prod * two**const/(two*dn+const)
-
- end function pnormj
-
-!
-!------------------------------------------------------------------------
-!
-
- subroutine zwgjd(z,w,np,alpha,beta)
-
-!=======================================================================
-!
-! Z w g j d : Generate np Gauss-Jacobi points and weights
-! associated with Jacobi polynomial of degree n = np-1
-!
-! Note : Coefficients alpha and beta must be greater than -1.
-! ----
-!=======================================================================
-
- implicit none
- include 'constants.h'
-
- !double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
-
- integer np
- double precision z(np)
- real(kind=CUSTOM_REAL) :: w(np)
- double precision alpha,beta
-
- integer n,np1,np2,i
- double precision p,pd,pm1,pdm1,pm2,pdm2
- double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
- double precision, external :: gammaf,pnormj
-
- pd = zero
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- n = np-1
- apb = alpha+beta
- p = zero
- pdm1 = zero
-
- if (np <= 0) call exit_MPI('minimum number of Gauss points is 1')
-
- if ((alpha <= -one) .or. (beta <= -one)) call exit_MPI('alpha and beta must be greater than -1')
-
- if (np == 1) then
- z(1) = (beta-alpha)/(apb+two)
- w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
- return
- endif
-
- call jacg(z,np,alpha,beta)
-
- np1 = n+1
- np2 = n+2
- dnp1 = dble(np1)
- dnp2 = dble(np2)
- fac1 = dnp1+alpha+beta+one
- fac2 = fac1+dnp1
- fac3 = fac2+one
- fnorm = pnormj(np1,alpha,beta)
- rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
- do i=1,np
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
- w(i) = -rcoef/(p*pdm1)
- enddo
-
- end subroutine zwgjd
-
-!
-!------------------------------------------------------------------------
-!
-
- subroutine zwgljd(z,w,np,alpha,beta)
-
-!=======================================================================
-!
-! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
-! ----------- weights associated with Jacobi polynomials of degree
-! n = np-1.
-!
-! Note : alpha and beta coefficients must be greater than -1.
-! Legendre polynomials are special case of Jacobi polynomials
-! just by setting alpha and beta to 0.
-!
-!=======================================================================
-
- implicit none
- include 'constants.h'
-
-
- !double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
-
- integer np
- double precision alpha,beta
- double precision z(np)
- real(kind=CUSTOM_REAL) :: w(np)
-
- integer n,nm1,i
- double precision p,pd,pm1,pdm1,pm2,pdm2
- double precision alpg,betg
- double precision, external :: endw1,endw2
-
- p = zero
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- n = np-1
- nm1 = n-1
- pd = zero
-
- if (np <= 1) call exit_MPI('minimum number of Gauss-Lobatto points is 2')
-
-! with spectral elements, use at least 3 points
- if (np <= 2) call exit_MPI('minimum number of Gauss-Lobatto points for the SEM is 3')
-
- if ((alpha <= -one) .or. (beta <= -one)) call exit_MPI('alpha and beta must be greater than -1')
-
- if (nm1 > 0) then
- alpg = alpha+one
- betg = beta+one
- call zwgjd(z(2),w(2),nm1,alpg,betg)
- endif
-
- z(1) = - one
- z(np) = one
-
- do i=2,np-1
- w(i) = w(i)/(one-z(i)**2)
- enddo
-
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
- w(1) = endw1(n,alpha,beta)/(two*pd)
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
- w(np) = endw2(n,alpha,beta)/(two*pd)
-
- end subroutine zwgljd
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/gmat01.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/gmat01.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/gmat01.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,396 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine gmat01(density_array,porosity_array,tortuosity_array, &
- aniso_array,permeability,poroelastcoef, &
- numat,myrank,ipass,Qp_array,Qs_array, &
- freq0,Q0,f0,TURN_VISCATTENUATION_ON)
-
-! reads properties of a 2D isotropic or anisotropic linear elastic element
-
- implicit none
- include "constants.h"
-
- integer :: numat,myrank,ipass
- double precision :: density_array(2,numat),poroelastcoef(4,3,numat),porosity_array(numat)
- double precision :: aniso_array(6,numat),tortuosity_array(numat),permeability(3,numat)
- double precision :: Qp_array(numat),Qs_array(numat)
- double precision :: f0,Q0,freq0
- logical :: TURN_VISCATTENUATION_ON
-
- ! local parameters
- double precision :: lambdaplus2mu,kappa
- 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
- double precision :: cpIsquare,cpIIsquare,cssquare,mu_s,mu_fr,eta_f,lambda_s,lambda_fr
- double precision :: val1,val2,val3,val4,val5,val6
- double precision :: val7,val8,val9,val10,val11,val12,val0
- double precision :: c11,c13,c15,c33,c35,c55
- double precision :: D_biot,H_biot,C_biot,M_biot
- double precision :: w_c
- integer in,n,indic
- character(len=80) datlin
-
-
- !
- !---- loop over the different material sets
- !
- density_array(:,:) = zero
- porosity_array(:) = zero
- tortuosity_array(:) = zero
- aniso_array(:,:) = zero
- permeability(:,:) = zero
- poroelastcoef(:,:,:) = zero
- Qp_array(:) = zero
- Qs_array(:) = zero
-
- if(myrank == 0 .and. ipass == 1) write(IOUT,100) numat
-
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- do in = 1,numat
-
- 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, 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
-
- ! P and S velocity
- cp = 20
- cs = 10
-
- ! Anisotropy parameters
- c11 = val1
- c13 = val2
- c15 = val3
- c33 = val4
- c35 = val5
- c55 = val6
-
- ! Qp and Qs values
- !Qp = val9
- !Qs = val10
-
- ! 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)
-
- !---- isotropic material, moduli are given, allows for declaration of poroelastic material
- !---- poroelastic (0<phi<1)
- else if (indic == 3) then
- ! Qs values
- Qs = val12
-
- density(1) =val0
- density(2) =val1
-
- ! Solid properties
- kappa_s = val7
- mu_s = val11
- ! Fluid properties
- kappa_f = val8
- eta_f = val10
- ! Frame properties
- 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
- lambdaplus2mu_fr = kappa_fr + FOUR_THIRDS*mu_fr
- lambda_fr = lambdaplus2mu_fr - 2.d0*mu_fr
- phi = val2
- tortuosity = val3
-
- ! 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)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare, &
- H_biot,C_biot,M_biot,mu_fr,phi, &
- tortuosity,density(1),density(2),eta_f, &
- val4,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- 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)
-
- ! Poisson's ratio for the solid phase
- poisson_s = HALF*(3.d0*kappa_s- 2.d0*mu_s)/(3.d0*kappa_s+mu_s)
-
- ! Poisson's ratio 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'
-
- else
- call exit_MPI('wrong model flag read')
-
- endif
-
- !
- !---- set elastic coefficients and density
- !
- ! 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)
-! dummy poroelastcoef values, trick to avoid floating invalid
- poroelastcoef(1,1,n) = lambda
- poroelastcoef(2,1,n) = mu
- poroelastcoef(3,1,n) = lambdaplus2mu
- poroelastcoef(4,1,n) = zero
- aniso_array(1,n) = c11
- aniso_array(2,n) = c13
- aniso_array(3,n) = c15
- aniso_array(4,n) = c33
- aniso_array(5,n) = c35
- aniso_array(6,n) = c55
-! dummy Q values, trick to avoid a bug in attenuation_model
- Qp_array(n) = 15
- Qs_array(n) = 15
- porosity_array(n) = 0.d0
- elseif (indic == 3) then
- density_array(1,n) = density(1)
- density_array(2,n) = density(2)
- poroelastcoef(1,1,n) = lambda_s
- poroelastcoef(2,1,n) = mu_s ! = mu_fr
- poroelastcoef(3,1,n) = lambdaplus2mu_s
- poroelastcoef(4,1,n) = zero
-
- poroelastcoef(1,2,n) = kappa_f
- poroelastcoef(2,2,n) = eta_f
- poroelastcoef(3,2,n) = zero
- poroelastcoef(4,2,n) = zero
-
- poroelastcoef(1,3,n) = lambda_fr
- poroelastcoef(2,3,n) = mu_fr
- poroelastcoef(3,3,n) = lambdaplus2mu_fr
- poroelastcoef(4,3,n) = zero
- Qp_array(n) = 10.d0 ! dummy for attenuation_model
- Qs_array(n) = Qs
- endif
-
- !
- !---- check what has been read
- !
- if(myrank == 0 .and. ipass == 1) then
- if(indic == 1) then
- ! 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,density(1),c11,c13,c15,c33,c35,c55
- elseif(indic == 3) then
- ! 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,w_c
- endif
- endif
-
- enddo
-
- !
- !---- formats
- !
-100 format(//,' M a t e r i a l s e t s : ', &
- ' 2 D (p o r o) e l a s t i c i t y', &
- /1x,54('='),//5x,'Number of material sets . . . . . . (numat) =',i6)
-
-200 format(//5x,'----------------------------------------',/5x, &
- '-- Elastic (solid) isotropic material --',/5x, &
- '----------------------------------------',/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, &
- 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
- 'c11 coefficient (Pascal). . . . . . (c11) =',1pe15.8,/5x, &
- 'c13 coefficient (Pascal). . . . . . (c13) =',1pe15.8,/5x, &
- 'c15 coefficient (Pascal). . . . . . (c15) =',1pe15.8,/5x, &
- 'c33 coefficient (Pascal). . . . . . (c33) =',1pe15.8,/5x, &
- 'c35 coefficient (Pascal). . . . . . (c35) =',1pe15.8,/5x, &
- 'c55 coefficient (Pascal). . . . . . (c55) =',1pe15.8,/5x)
-
-500 format(//5x,'----------------------------------------',/5x, &
- '-- Poroelastic isotropic material --',/5x, &
- '----------------------------------------',/5x, &
- 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
- 'First P-wave velocity. . . . . . . . . . . (cpI) =',1pe15.8,/5x, &
- 'Second P-wave velocity. . . . . . . . . . . (cpII) =',1pe15.8,/5x, &
- 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8)
-
-600 format(//5x,'-------------------------------',/5x, &
- '-- Solid phase properties --',/5x, &
- 'Mass density. . . . . . . . . . (density_s) =',1pe15.8,/5x, &
- 'Poisson''s ratio. . . . . . . . .(poisson_s) =',1pe15.8,/5x, &
- 'First Lame parameter Lambda. . . (lambda_s) =',1pe15.8,/5x, &
- 'Second Lame parameter Mu. . . . . . .(mu_s) =',1pe15.8,/5x, &
- 'Solid bulk modulus Kappa . . . . . . . .(kappa_s) =',1pe15.8,/5x, &
- 'Young''s modulus E. . . . . . . . .(young_s) =',1pe15.8)
-
-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)
-
-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. . . . . . . . . . . . . . . . .(c) =',1pe15.8,/5x,&
- 'Permeability xx component. . . . . . . . . . =',1pe15.8,/5x,&
- 'Permeability zx component. . . . . . . . . . =',1pe15.8,/5x,&
- 'Permeability zz component. . . . . . . . . . =',1pe15.8,/5x,&
- 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
-
-900 format(//5x,'-------------------------------',/5x, &
- '-- Biot coefficients --',/5x, &
- '-------------------------------',/5x, &
- 'D. . . . . . . . =',1pe15.8,/5x, &
- 'H. . . . . . . . =',1pe15.8,/5x, &
- 'C. . . . . . . . =',1pe15.8,/5x, &
- 'M. . . . . . . . =',1pe15.8,/5x, &
- 'characteristic freq =',1pe15.8)
-
- end subroutine gmat01
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/include_for_periodic_conditions.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/include_for_periodic_conditions.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/include_for_periodic_conditions.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,105 +0,0 @@
-
-!----------------------------------------------------------------------
- do ispecperio2 = 1,NSPEC_PERIO
-
- ispec2 = numperio_right(ispecperio2)
-
- if(codeabs_perio_right(ILEFT,ispecperio2)) then
- i2 = 1
- do j2 = 1,NGLLZ
- iglob2 = ibool(i2,j2,ispec2)
- if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
- (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
- print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
-! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
-! print *,ispec,i,j,ispec2,i2,j2
-! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
-!--------------------------------------------------------------------------------
- iglob_target_to_replace = ibool(i2,j2,ispec2)
- do ispec3 = 1,nspec
- do j3 = 1,NGLLZ
- do i3 = 1,NGLLX
- if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
- enddo
- enddo
- enddo
-!--------------------------------------------------------------------------------
- endif
- enddo
- endif
-
- if(codeabs_perio_right(IRIGHT,ispecperio2)) then
- i2 = NGLLX
- do j2 = 1,NGLLZ
- iglob2 = ibool(i2,j2,ispec2)
- if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
- (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
- print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
-! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
-! print *,ispec,i,j,ispec2,i2,j2
-! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
-!--------------------------------------------------------------------------------
- iglob_target_to_replace = ibool(i2,j2,ispec2)
- do ispec3 = 1,nspec
- do j3 = 1,NGLLZ
- do i3 = 1,NGLLX
- if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
- enddo
- enddo
- enddo
-!--------------------------------------------------------------------------------
- endif
- enddo
- endif
-
- if(codeabs_perio_right(IBOTTOM,ispecperio2)) then
- j2 = 1
- do i2 = 1,NGLLX
- iglob2 = ibool(i2,j2,ispec2)
- if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
- (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
- print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
-! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
-! print *,ispec,i,j,ispec2,i2,j2
-! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
-!--------------------------------------------------------------------------------
- iglob_target_to_replace = ibool(i2,j2,ispec2)
- do ispec3 = 1,nspec
- do j3 = 1,NGLLZ
- do i3 = 1,NGLLX
- if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
- enddo
- enddo
- enddo
-!--------------------------------------------------------------------------------
- endif
- enddo
- endif
-
- if(codeabs_perio_right(ITOP,ispecperio2)) then
- j2 = NGLLZ
- do i2 = 1,NGLLX
- iglob2 = ibool(i2,j2,ispec2)
- if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
- (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
- print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
-! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
-! print *,ispec,i,j,ispec2,i2,j2
-! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
-!--------------------------------------------------------------------------------
- iglob_target_to_replace = ibool(i2,j2,ispec2)
- do ispec3 = 1,nspec
- do j3 = 1,NGLLZ
- do i3 = 1,NGLLX
- if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
- enddo
- enddo
- enddo
-!--------------------------------------------------------------------------------
- endif
- enddo
- endif
-
- enddo
-!----------------------------------------------------------------------
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/initialize_simulation.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/initialize_simulation.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/initialize_simulation.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,120 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine initialize_simulation(nproc,myrank,NUMBER_OF_PASSES, &
- ninterface_acoustic,ninterface_elastic,ninterface_poroelastic)
-
- implicit none
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: nproc,myrank,NUMBER_OF_PASSES
- integer :: ninterface_acoustic, ninterface_elastic,ninterface_poroelastic
-
- ! local parameters
- integer :: ier
- character(len=256) :: prname
-
-!***********************************************************************
-!
-! i n i t i a l i z a t i o n p h a s e
-!
-!***********************************************************************
-
-#ifdef USE_MPI
- call MPI_INIT(ier)
- call MPI_COMM_SIZE(MPI_COMM_WORLD,nproc,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
- if( ier /= 0 ) call exit_MPI('error MPI initialization')
-
- ! 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
- !ier = 0
- !ninterface_acoustic = 0
- !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
-
- ninterface_acoustic = 0
- ninterface_elastic = 0
- ninterface_poroelastic = 0
-
- ! 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',iostat=ier)
- if( ier /= 0 ) call exit_MPI('error opening file simulation_results***.txt')
-
- endif
-
- end subroutine initialize_simulation
Deleted: seismo/2D/SPECFEM2D/trunk/src/invert_mass_matrix.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/invert_mass_matrix.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/invert_mass_matrix.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,206 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine invert_mass_matrix_init(any_elastic,any_acoustic,any_poroelastic, &
- rmass_inverse_elastic,npoin_elastic, &
- rmass_inverse_acoustic,npoin_acoustic, &
- rmass_s_inverse_poroelastic, &
- rmass_w_inverse_poroelastic,npoin_poroelastic, &
- nspec,ibool,kmato,wxgll,wzgll,jacobian, &
- elastic,poroelastic, &
- assign_external_model,numat, &
- density,poroelastcoef,porosity,tortuosity, &
- vpext,rhoext)
-
-! builds the global mass matrix
-
- implicit none
- include 'constants.h'
-
- logical any_elastic,any_acoustic,any_poroelastic
-
- ! inverse mass matrices
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(npoin_elastic) :: rmass_inverse_elastic
-
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: rmass_inverse_acoustic
-
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(npoin_poroelastic) :: &
- rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
-
- integer :: nspec
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: kmato
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wzgll
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: jacobian
-
- logical,dimension(nspec) :: elastic,poroelastic
-
- logical :: assign_external_model
- integer :: numat
- double precision, dimension(2,numat) :: density
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,rhoext
-
- ! local parameters
- integer :: ispec,i,j,iglob
- double precision :: rhol,kappal,mul_relaxed,lambdal_relaxed
- double precision :: rhol_s,rhol_f,rhol_bar,phil,tortl
-
- ! initializes mass matrix
- if(any_elastic) rmass_inverse_elastic(:) = 0._CUSTOM_REAL
- if(any_poroelastic) rmass_s_inverse_poroelastic(:) = 0._CUSTOM_REAL
- if(any_poroelastic) rmass_w_inverse_poroelastic(:) = 0._CUSTOM_REAL
- if(any_acoustic) rmass_inverse_acoustic(:) = 0._CUSTOM_REAL
-
- 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/3.d0*mul_relaxed
- endif
-
- if( poroelastic(ispec) ) then
-
- ! material is poroelastic
-
- rhol_s = density(1,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- rhol_bar = (1.d0-phil)*rhol_s + phil*rhol_f
-
- ! for the solid mass matrix
- rmass_s_inverse_poroelastic(iglob) = rmass_s_inverse_poroelastic(iglob) &
- + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar - phil*rhol_f/tortl)
- ! for the fluid mass matrix
- rmass_w_inverse_poroelastic(iglob) = rmass_w_inverse_poroelastic(iglob) &
- + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar*rhol_f*tortl &
- - phil*rhol_f*rhol_f)/(rhol_bar*phil)
-
- elseif( elastic(ispec) ) then
-
- ! for elastic medium
-
- rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) &
- + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
-
- else
-
- ! for acoustic medium
-
- rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) &
- + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / kappal
-
- endif
-
- enddo
- enddo
- enddo ! do ispec = 1,nspec
-
- end subroutine invert_mass_matrix_init
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine invert_mass_matrix(any_elastic,any_acoustic,any_poroelastic, &
- rmass_inverse_elastic,npoin_elastic, &
- rmass_inverse_acoustic,npoin_acoustic, &
- rmass_s_inverse_poroelastic, &
- rmass_w_inverse_poroelastic,npoin_poroelastic)
-
-! inverts the global mass matrix
-
- implicit none
- include 'constants.h'
-
- logical any_elastic,any_acoustic,any_poroelastic
-
-! inverse mass matrices
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(npoin_elastic) :: rmass_inverse_elastic
-
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: rmass_inverse_acoustic
-
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(npoin_poroelastic) :: &
- rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
-
-
-! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
- if(any_elastic) &
- where(rmass_inverse_elastic <= 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
- if(any_poroelastic) &
- where(rmass_s_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_s_inverse_poroelastic = 1._CUSTOM_REAL
- if(any_poroelastic) &
- where(rmass_w_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_w_inverse_poroelastic = 1._CUSTOM_REAL
- if(any_acoustic) &
- where(rmass_inverse_acoustic <= 0._CUSTOM_REAL) rmass_inverse_acoustic = 1._CUSTOM_REAL
-
-! compute the inverse of the mass matrix
- if(any_elastic) &
- rmass_inverse_elastic(:) = 1._CUSTOM_REAL / rmass_inverse_elastic(:)
- if(any_poroelastic) &
- rmass_s_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_s_inverse_poroelastic(:)
- if(any_poroelastic) &
- rmass_w_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_w_inverse_poroelastic(:)
- if(any_acoustic) &
- rmass_inverse_acoustic(:) = 1._CUSTOM_REAL / rmass_inverse_acoustic(:)
-
- end subroutine invert_mass_matrix
Deleted: seismo/2D/SPECFEM2D/trunk/src/is_in_convex_quadrilateral.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/is_in_convex_quadrilateral.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/is_in_convex_quadrilateral.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,77 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine is_in_convex_quadrilateral(elmnt_coords, x_coord, z_coord, is_in)
-
- implicit none
-
- double precision, dimension(2,4) :: elmnt_coords
- double precision, intent(in) :: x_coord, z_coord
- logical, intent(out) :: is_in
-
- real :: x1, x2, x3, x4, z1, z2, z3, z4
- real :: normal1, normal2, normal3, normal4
-
- x1 = elmnt_coords(1,1)
- x2 = elmnt_coords(1,2)
- x3 = elmnt_coords(1,3)
- x4 = elmnt_coords(1,4)
- z1 = elmnt_coords(2,1)
- z2 = elmnt_coords(2,2)
- z3 = elmnt_coords(2,3)
- z4 = elmnt_coords(2,4)
-
- normal1 = (z_coord-z1) * (x2-x1) - (x_coord-x1) * (z2-z1)
- normal2 = (z_coord-z2) * (x3-x2) - (x_coord-x2) * (z3-z2)
- normal3 = (z_coord-z3) * (x4-x3) - (x_coord-x3) * (z4-z3)
- normal4 = (z_coord-z4) * (x1-x4) - (x_coord-x4) * (z1-z4)
-
- if ((normal1 < 0) .or. (normal2 < 0) .or. (normal3 < 0) .or. (normal4 < 0)) then
- is_in = .false.
- else
- is_in = .true.
- endif
-
- end subroutine is_in_convex_quadrilateral
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/lagrange_poly.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/lagrange_poly.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/lagrange_poly.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,162 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- double precision function hgll(I,Z,ZGLL,NZ)
-
-!-------------------------------------------------------------
-!
-! Compute the value of the Lagrangian interpolant L through
-! the NZ Gauss-Lobatto Legendre points ZGLL at point Z
-!
-!-------------------------------------------------------------
-
- implicit none
-
- integer i,nz
- double precision z
- double precision ZGLL(0:nz-1)
-
- integer n
- double precision EPS,DZ,ALFAN
- double precision, external :: PNLEG,PNDLEG
-
- EPS = 1.d-5
- DZ = Z - ZGLL(I)
- if(abs(DZ) < EPS) then
- HGLL = 1.d0
- return
- endif
- N = NZ - 1
- ALFAN = dble(N)*(dble(N)+1.d0)
- HGLL = - (1.d0-Z*Z)*PNDLEG(Z,N)/ (ALFAN*PNLEG(ZGLL(I),N)*(Z-ZGLL(I)))
-
- end function hgll
-
-!
-!=====================================================================
-!
-
- subroutine lagrange_any(xi,NGLL,xigll,h,hprime)
-
-! subroutine to compute the Lagrange interpolants based upon the GLL points
-! and their first derivatives at any point xi in [-1,1]
-
- implicit none
-
- integer NGLL
- double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)
-
- integer dgr,i,j
- double precision prod1,prod2
-
- do dgr=1,NGLL
-
- prod1 = 1.0d0
- prod2 = 1.0d0
- do i=1,NGLL
- if(i /= dgr) then
- prod1 = prod1*(xi-xigll(i))
- prod2 = prod2*(xigll(dgr)-xigll(i))
- endif
- enddo
- h(dgr)=prod1/prod2
-
- hprime(dgr)=0.0d0
- do i=1,NGLL
- if(i /= dgr) then
- prod1=1.0d0
- do j=1,NGLL
- if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
- enddo
- hprime(dgr) = hprime(dgr)+prod1
- endif
- enddo
- hprime(dgr) = hprime(dgr)/prod2
-
- enddo
-
- end subroutine lagrange_any
-
-!
-!=====================================================================
-!
-
-! subroutine to compute the derivative of the Lagrange interpolants
-! at the GLL points at any given GLL point
-
- double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)
-
-!------------------------------------------------------------------------
-!
-! Compute the value of the derivative of the I-th
-! Lagrange interpolant through the
-! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
-!
-!------------------------------------------------------------------------
-
- implicit none
-
- integer i,j,nz
- double precision zgll(0:nz-1)
-
- integer degpoly
-
- double precision, external :: pnleg,pndleg
-
- degpoly = nz - 1
- if (i == 0 .and. j == 0) then
- lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
- else if (i == degpoly .and. j == degpoly) then
- lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
- else if (i == j) then
- lagrange_deriv_GLL = 0.d0
- else
- lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
- (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
- + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
- (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
- endif
-
- end function lagrange_deriv_GLL
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/locate_receivers.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/locate_receivers.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/locate_receivers.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,317 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!----
-!---- locate_receivers finds the correct position of the receivers
-!----
-
- 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,ipass, &
- x_final_receiver, z_final_receiver)
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer nrec,nspec,npoin,ngnod,npgeo,ipass
- integer, intent(in) :: nproc, myrank
-
- integer knods(ngnod,nspec)
- double precision coorg(NDIM,npgeo)
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
-! array containing coordinates of the points
- double precision coord(NDIM,npoin)
-
- integer irec,i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
-
- double precision x_source,z_source,dist,stele,stbur
- double precision, dimension(nrec) :: distance_receiver
- double precision xi,gamma,dx,dz,dxi,dgamma
-
-! Gauss-Lobatto-Legendre points of integration
- double precision xigll(NGLLX)
- double precision zigll(NGLLZ)
-
- double precision x,z,xix,xiz,gammax,gammaz,jacobian
-
-! use dynamic allocation
- double precision distmin
- double precision, dimension(:), allocatable :: final_distance
-
-! receiver information
- integer :: nrecloc
- integer, dimension(nrec) :: ispec_selected_rec, recloc
- double precision, dimension(nrec) :: xi_receiver,gamma_receiver
-
-! station information for writing the seismograms
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- 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
- integer, dimension(nrec,nproc) :: gather_ispec_selected_rec
- integer, dimension(nrec), intent(inout) :: which_proc_receiver
- integer :: ierror
-
-
- ierror = 0
-#ifdef USE_MPI
- call MPI_BARRIER(MPI_COMM_WORLD,ierror)
-#endif
-
-! **************
-
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) '********************'
- write(IOUT,*) ' locating receivers'
- write(IOUT,*) '********************'
- write(IOUT,*)
- write(IOUT,*) 'reading receiver information from the DATA/STATIONS file'
- write(IOUT,*)
- endif
-
- open(unit=1,file='DATA/STATIONS_target',status='old',action='read')
-
-! allocate memory for arrays using number of stations
- allocate(final_distance(nrec))
-
-! loop on all the stations
- do irec=1,nrec
-
- ! set distance to huge initial value
- distmin=HUGEVAL
-
- read(1,*) station_name(irec),network_name(irec),st_xval(irec),st_zval(irec),stele,stbur
-
- ! check that station is not buried, burial is not implemented in current code
- if(abs(stbur) > TINYVAL) call exit_MPI('stations with non-zero burial not implemented yet')
-
- ! compute distance between source and receiver
- distance_receiver(irec) = sqrt((st_zval(irec)-z_source)**2 + (st_xval(irec)-x_source)**2)
-
- 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
-
- iglob = ibool(i,j,ispec)
- dist = sqrt((st_xval(irec)-dble(coord(1,iglob)))**2 + (st_zval(irec)-dble(coord(2,iglob)))**2)
-
- ! keep this point if it is closer to the receiver
- if(dist < distmin) then
- distmin = dist
- ispec_selected_rec(irec) = ispec
- ix_initial_guess = i
- iz_initial_guess = j
- endif
-
- enddo
- enddo
-
- ! end of loop on all the spectral elements
- enddo
-
-
-! ****************************************
-! find the best (xi,gamma) for each receiver
-! ****************************************
-
- ! use initial guess in xi and gamma
- xi = xigll(ix_initial_guess)
- gamma = zigll(iz_initial_guess)
-
- ! iterate to solve the non linear system
- do iter_loop = 1,NUM_ITER
-
- ! recompute jacobian for the new point
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_rec(irec),ngnod,nspec,npgeo, &
- .true.)
-
- ! compute distance to target location
- dx = - (x - st_xval(irec))
- dz = - (z - st_zval(irec))
-
- ! compute increments
- dxi = xix*dx + xiz*dz
- dgamma = gammax*dx + gammaz*dz
-
- ! update values
- xi = xi + dxi
- gamma = gamma + dgamma
-
- ! impose that we stay in that element
- ! (useful if user gives a receiver outside the mesh for instance)
- ! we can go slightly outside the [1,1] segment since with finite elements
- ! the polynomial solution is defined everywhere
- ! this can be useful for convergence of itertive scheme with distorted elements
- if (xi > 1.10d0) xi = 1.10d0
- if (xi < -1.10d0) xi = -1.10d0
- if (gamma > 1.10d0) gamma = 1.10d0
- if (gamma < -1.10d0) gamma = -1.10d0
-
- ! end of non linear iterations
- enddo
-
- ! compute final coordinates of point found
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_rec(irec),ngnod,nspec,npgeo, &
- .true.)
-
- ! store xi,gamma of point found
- xi_receiver(irec) = xi
- gamma_receiver(irec) = gamma
-
- ! 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
- close(1)
-
-! elect one process for each receiver.
-#ifdef USE_MPI
- call MPI_GATHER(final_distance(1),nrec,MPI_DOUBLE_PRECISION,&
- gather_final_distance(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
- call MPI_GATHER(xi_receiver(1),nrec,MPI_DOUBLE_PRECISION,&
- gather_xi_receiver(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
- call MPI_GATHER(gamma_receiver(1),nrec,MPI_DOUBLE_PRECISION,&
- gather_gamma_receiver(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
- call MPI_GATHER(ispec_selected_rec(1),nrec,MPI_INTEGER,&
- gather_ispec_selected_rec(1,1),nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
-
- if ( myrank == 0 ) then
- do irec = 1, nrec
- which_proc_receiver(irec:irec) = minloc(gather_final_distance(irec,:)) - 1
- enddo
- endif
-
- call MPI_BCAST(which_proc_receiver(1),nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
-
-#else
-
- gather_final_distance(:,1) = final_distance(:)
-
- gather_xi_receiver(:,1) = xi_receiver(:)
- gather_gamma_receiver(:,1) = gamma_receiver(:)
- gather_ispec_selected_rec(:,1) = ispec_selected_rec(:)
-
- which_proc_receiver(:) = 0
-
-#endif
-
- nrecloc = 0
- do irec = 1, nrec
- if ( which_proc_receiver(irec) == myrank ) then
- nrecloc = nrecloc + 1
- recloc(nrecloc) = irec
- endif
- enddo
-
- if (myrank == 0 .and. ipass == 1) then
-
- do irec = 1, nrec
- write(IOUT,*)
- write(IOUT,*) 'Station # ',irec,' ',station_name(irec),network_name(irec)
-
- if(gather_final_distance(irec,which_proc_receiver(irec)+1) == HUGEVAL) &
- call exit_MPI('error locating receiver')
-
- write(IOUT,*) ' original x: ',sngl(st_xval(irec))
- write(IOUT,*) ' original z: ',sngl(st_zval(irec))
- write(IOUT,*) ' distance from source: ',sngl(distance_receiver(irec))
- write(IOUT,*) 'closest estimate found: ',sngl(gather_final_distance(irec,which_proc_receiver(irec)+1)), &
- ' m away'
- write(IOUT,*) ' in element ',gather_ispec_selected_rec(irec,which_proc_receiver(irec)+1)
- write(IOUT,*) ' at process ', which_proc_receiver(irec)
- write(IOUT,*) ' at xi,gamma coordinates = ',gather_xi_receiver(irec,which_proc_receiver(irec)+1),&
- gather_gamma_receiver(irec,which_proc_receiver(irec)+1)
- write(IOUT,*)
- enddo
-
- write(IOUT,*)
- write(IOUT,*) 'end of receiver detection'
- write(IOUT,*)
-
- ! write out actual station locations (compare with STATIONS_target from meshfem2D)
- ! NOTE: this will be written out even if generate_STATIONS = .false.
- open(unit=15,file='DATA/STATIONS',status='unknown')
- do irec = 1,nrec
- write(15,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") &
- irec,x_final_receiver(irec),z_final_receiver(irec)
- enddo
- close(15)
-
- endif
-
- ! deallocate arrays
- deallocate(final_distance)
-
-#ifdef USE_MPI
- call MPI_BARRIER(MPI_COMM_WORLD,ierror)
-#endif
-
- end subroutine locate_receivers
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/locate_source_force.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/locate_source_force.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/locate_source_force.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,257 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!----
-!---- locate_source_force finds the correct position of the point force source
-!----
-
- subroutine locate_source_force(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,ipass,iglob_source)
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer nspec,npoin,ngnod,npgeo,ipass
-
- integer knods(ngnod,nspec)
- double precision coorg(NDIM,npgeo)
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
-! array containing coordinates of the points
- double precision coord(NDIM,npoin)
-
- integer i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
-
- double precision x_source,z_source,dist
- double precision xi,gamma,dx,dz,dxi,dgamma
-
-! Gauss-Lobatto-Legendre points of integration
- double precision xigll(NGLLX)
- double precision zigll(NGLLZ)
-
- double precision x,z,xix,xiz,gammax,gammaz,jacobian
- double precision distmin,final_distance,dist_glob
-
-! source information
- integer ispec_selected_source,is_proc_source,nb_proc_source,iglob_source
- integer, intent(in) :: nproc, myrank
- double precision xi_source,gamma_source
-
-#ifdef USE_MPI
- integer, dimension(1:nproc) :: allgather_is_proc_source
- integer, dimension(1) :: locate_is_proc_source
- integer :: ierror
-#endif
-
-
-
-! **************
- if ((myrank == 0 .or. nproc == 1) .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) '*******************************'
- write(IOUT,*) ' locating force source'
- write(IOUT,*) '*******************************'
- write(IOUT,*)
- endif
-
-! set distance to huge initial value
- distmin = HUGEVAL
-
- is_proc_source = 0
-
- 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
-
- iglob = ibool(i,j,ispec)
- dist = sqrt((x_source-dble(coord(1,iglob)))**2 &
- + (z_source-dble(coord(2,iglob)))**2)
-
-! keep this point if it is closer to the source
- if(dist < distmin) then
- iglob_source = iglob
- distmin = dist
- ispec_selected_source = ispec
- ix_initial_guess = i
- iz_initial_guess = j
- endif
-
- enddo
- enddo
-
-! 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)
-
-#else
- dist_glob = distmin
-
-#endif
-
-! check if this process contains the source
- if ( abs(dist_glob - distmin) < TINYVAL ) is_proc_source = 1
-
-#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)
-
-#else
-
- nb_proc_source = is_proc_source
-
-#endif
-
-
-#ifdef USE_MPI
- ! when several processes contain the source, we elect one of them (minimum rank).
- if ( nb_proc_source > 1 ) then
-
- call MPI_ALLGATHER(is_proc_source, 1, MPI_INTEGER, allgather_is_proc_source(1), &
- 1, MPI_INTEGER, MPI_COMM_WORLD, ierror)
- locate_is_proc_source = maxloc(allgather_is_proc_source) - 1
-
- if ( myrank /= locate_is_proc_source(1) ) then
- is_proc_source = 0
- endif
- nb_proc_source = 1
-
- endif
-
-#endif
-
-! ****************************************
-! find the best (xi,gamma) for each source
-! ****************************************
-
-! use initial guess in xi and gamma
- xi = xigll(ix_initial_guess)
- gamma = zigll(iz_initial_guess)
-
-! iterate to solve the non linear system
- do iter_loop = 1,NUM_ITER
-
-! recompute jacobian for the new point
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
- .true.)
-
-! compute distance to target location
- dx = - (x - x_source)
- dz = - (z - z_source)
-
-! compute increments
- dxi = xix*dx + xiz*dz
- dgamma = gammax*dx + gammaz*dz
-
-! update values
- xi = xi + dxi
- gamma = gamma + dgamma
-
-! impose that we stay in that element
-! (useful if user gives a source outside the mesh for instance)
-! we can go slightly outside the [1,1] segment since with finite elements
-! the polynomial solution is defined everywhere
-! this can be useful for convergence of itertive scheme with distorted elements
- if (xi > 1.10d0) xi = 1.10d0
- if (xi < -1.10d0) xi = -1.10d0
- if (gamma > 1.10d0) gamma = 1.10d0
- if (gamma < -1.10d0) gamma = -1.10d0
-
-! end of non linear iterations
- enddo
-
-! compute final coordinates of point found
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
- .true.)
-
-! store xi,gamma of point found
- xi_source = xi
- gamma_source = gamma
-
-! compute final distance between asked and found
- final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
-
- if (is_proc_source == 1 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Force source:'
-
- if(final_distance == HUGEVAL) call exit_MPI('error locating force source')
-
- write(IOUT,*) ' original x: ',sngl(x_source)
- write(IOUT,*) ' original z: ',sngl(z_source)
- write(IOUT,*) 'closest estimate found: ',sngl(final_distance),' m away'
-#ifdef USE_MPI
- write(IOUT,*) ' in rank ',myrank
-#endif
- write(IOUT,*) ' in element ',ispec_selected_source
- write(IOUT,*) ' at xi,gamma coordinates = ',xi_source,gamma_source
- write(IOUT,*)
-
- write(IOUT,*)
- write(IOUT,*) 'end of force source detection'
- write(IOUT,*)
- endif
-
-#ifdef USE_MPI
- call MPI_BARRIER(MPI_COMM_WORLD,ierror)
-#endif
-
- end subroutine locate_source_force
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/locate_source_moment_tensor.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/locate_source_moment_tensor.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/locate_source_moment_tensor.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,256 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!----
-!---- locate_source_moment_tensor finds the correct position of the moment-tensor source
-!----
-
- 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,ipass)
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer nspec,npoin,ngnod,npgeo,ipass
-
- integer knods(ngnod,nspec)
- double precision coorg(NDIM,npgeo)
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
-! array containing coordinates of the points
- double precision coord(NDIM,npoin)
-
- integer i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
-
- double precision x_source,z_source,dist
- double precision xi,gamma,dx,dz,dxi,dgamma
-
-! Gauss-Lobatto-Legendre points of integration
- double precision xigll(NGLLX)
- double precision zigll(NGLLZ)
-
- double precision x,z,xix,xiz,gammax,gammaz,jacobian
- double precision distmin,final_distance,dist_glob
-
-! source information
- integer ispec_selected_source,is_proc_source,nb_proc_source
- integer, intent(in) :: nproc, myrank
- double precision xi_source,gamma_source
-
-#ifdef USE_MPI
- integer, dimension(1:nproc) :: allgather_is_proc_source
- integer, dimension(1) :: locate_is_proc_source
- integer :: ierror
-#endif
-
-
-
-! **************
- 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
-
- is_proc_source = 0
-
- 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
-
- iglob = ibool(i,j,ispec)
- dist = sqrt((x_source-dble(coord(1,iglob)))**2 &
- + (z_source-dble(coord(2,iglob)))**2)
-
-! keep this point if it is closer to the source
- if(dist < distmin) then
- distmin = dist
- ispec_selected_source = ispec
- ix_initial_guess = i
- iz_initial_guess = j
- endif
-
- enddo
- enddo
-
-! 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)
-
-#else
- dist_glob = distmin
-
-#endif
-
-! check if this process contains the source
- if ( dist_glob == distmin ) is_proc_source = 1
-
-#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)
-
-#else
- nb_proc_source = is_proc_source
-
-#endif
-
-
-#ifdef USE_MPI
- ! when several processes contain the source, we elect one of them (minimum rank).
- if ( nb_proc_source > 1 ) then
-
- call MPI_ALLGATHER(is_proc_source, 1, MPI_INTEGER, allgather_is_proc_source(1), &
- 1, MPI_INTEGER, MPI_COMM_WORLD, ierror)
- locate_is_proc_source = maxloc(allgather_is_proc_source) - 1
-
- if ( myrank /= locate_is_proc_source(1) ) then
- is_proc_source = 0
- endif
- nb_proc_source = 1
-
- endif
-
-#endif
-
-! ****************************************
-! find the best (xi,gamma) for each source
-! ****************************************
-
-! use initial guess in xi and gamma
- xi = xigll(ix_initial_guess)
- gamma = zigll(iz_initial_guess)
-
-! iterate to solve the non linear system
- do iter_loop = 1,NUM_ITER
-
-! recompute jacobian for the new point
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
- .true.)
-
-! compute distance to target location
- dx = - (x - x_source)
- dz = - (z - z_source)
-
-! compute increments
- dxi = xix*dx + xiz*dz
- dgamma = gammax*dx + gammaz*dz
-
-! update values
- xi = xi + dxi
- gamma = gamma + dgamma
-
-! impose that we stay in that element
-! (useful if user gives a source outside the mesh for instance)
-! we can go slightly outside the [1,1] segment since with finite elements
-! the polynomial solution is defined everywhere
-! this can be useful for convergence of itertive scheme with distorted elements
- if (xi > 1.10d0) xi = 1.10d0
- if (xi < -1.10d0) xi = -1.10d0
- if (gamma > 1.10d0) gamma = 1.10d0
- if (gamma < -1.10d0) gamma = -1.10d0
-
-! end of non linear iterations
- enddo
-
-! compute final coordinates of point found
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
- .true.)
-
-! store xi,gamma of point found
- xi_source = xi
- gamma_source = gamma
-
-! compute final distance between asked and found
- final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
-
- if (is_proc_source == 1 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Moment-tensor source:'
-
- if(final_distance == HUGEVAL) call exit_MPI('error locating moment-tensor source')
-
- write(IOUT,*) ' original x: ',sngl(x_source)
- write(IOUT,*) ' original z: ',sngl(z_source)
- write(IOUT,*) 'closest estimate found: ',sngl(final_distance),' m away'
-#ifdef USE_MPI
- write(IOUT,*) ' in rank ',myrank
-#endif
- write(IOUT,*) ' in element ',ispec_selected_source
- write(IOUT,*) ' at xi,gamma coordinates = ',xi_source,gamma_source
- write(IOUT,*)
-
- write(IOUT,*)
- write(IOUT,*) 'end of moment-tensor source detection'
- write(IOUT,*)
- endif
-
-#ifdef USE_MPI
- call MPI_BARRIER(MPI_COMM_WORLD,ierror)
-#endif
-
- end subroutine locate_source_moment_tensor
-
Added: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/Makefile.in
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/Makefile.in (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/Makefile.in 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,218 @@
+
+#========================================================================
+#
+# S P E C F E M 2 D Version 6.1
+# ------------------------------
+#
+# Copyright Universite de Pau, CNRS and INRIA, France,
+# and Princeton University / California Institute of Technology, USA.
+# 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 princeton DOT edu
+#
+# This software is a computer program whose purpose is to solve
+# the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+# using a spectral-element method (SEM).
+#
+# This software is governed by the CeCILL license under French law and
+# abiding by the rules of distribution of free software. You can use,
+# modify and/or redistribute the software under the terms of the CeCILL
+# license as circulated by CEA, CNRS and INRIA at the following URL
+# "http://www.cecill.info".
+#
+# As a counterpart to the access to the source code and rights to copy,
+# modify and redistribute granted by the license, users are provided only
+# with a limited warranty and the software's author, the holder of the
+# economic rights, and the successive licensors have only limited
+# liability.
+#
+# In this respect, the user's attention is drawn to the risks associated
+# with loading, using, modifying and/or developing or reproducing the
+# software by the user in light of its specific status of free software,
+# that may mean that it is complicated to manipulate, and that also
+# therefore means that it is reserved for developers and experienced
+# professionals having in-depth computer knowledge. Users are therefore
+# encouraged to load and test the software's suitability as regards their
+# requirements in conditions enabling the security of their systems and/or
+# data to be ensured and, more generally, to use and operate it in the
+# same conditions as regards security.
+#
+# The full text of the license is available in file "LICENSE".
+#
+#========================================================================
+
+# @configure_input@
+
+FC = @FC@
+FCFLAGS = #@FCFLAGS@
+
+MPIFC = @MPIFC@
+MPILIBS = @MPILIBS@
+
+FLAGS_CHECK = @FLAGS_CHECK@ -I../../setup
+FLAGS_NO_CHECK = @FLAGS_NO_CHECK@ -I../../setup
+
+CC = @CC@
+CPPFLAGS = @CPPFLAGS@ $(COND_MPI_CPPFLAGS)
+CFLAGS = @CFLAGS@ $(CPPFLAGS) -I../../setup
+
+## serial or parallel
+ at COND_MPI_TRUE@F90 = $(MPIFC) $(FCFLAGS) -DUSE_MPI -DUSE_SCOTCH -I"../../@SCOTCH_INCLUDEDIR@" $(MPILIBS)
+ at COND_MPI_FALSE@F90 = $(FC) $(FCFLAGS)
+
+## scotch libraries
+ at COND_MPI_TRUE@LIB = -L"../../@SCOTCH_LIBDIR@" -lscotch -lscotcherr
+ at COND_MPI_FALSE@LIB =
+
+# optional: uncomment this to use more than one processor core, in which case the SCOTCH graph partitioner is needed
+#LIB = ../../scotch_5.1.10b/lib/libscotch.a ../../scotch_5.1.10b/lib/libscotcherr.a
+
+LINK = $(F90)
+
+## compilation directories
+# E : executables directory
+E = ../../bin
+# O : objects directory
+O = ../../obj
+# SHARED : shared directoy
+SHARED = ../shared
+# S : source file directory
+S = .
+## setup file directory
+SETUP = ../../setup
+
+
+##.PHONY: clean default all backup bak generate_databases specfem3D meshfem3D
+
+####
+#### targets
+####
+
+# default targets for the pure Fortran version
+ at COND_PYRE_FALSE@DEFAULT = \
+ at COND_PYRE_FALSE@ meshfem2D \
+ at COND_PYRE_FALSE@ check_quality_external_mesh \
+ at COND_PYRE_FALSE@ $(EMPTY_MACRO)
+
+
+
+OBJS_MESHFEM2D = \
+ $O/get_node_number.o \
+ $O/part_unstruct.o \
+ $O/read_interfaces_file.o \
+ $O/read_materials.o \
+ $O/read_parameter_file.o \
+ $O/read_regions.o \
+ $O/read_source_file.o \
+ $O/read_value_parameters.o \
+ $O/save_databases.o \
+ $O/save_gnuplot_file.o \
+ $O/save_stations_file.o \
+ $O/spline_routines.o \
+ $O/meshfem2D.o
+
+default: scotch $(DEFAULT)
+
+all: clean default
+
+mesh : meshfem2D
+meshfem2D: xmeshfem2D
+check_quality_external_mesh: xcheck_quality_external_mesh
+
+
+scotch:
+ifeq (@USE_BUNDLED_SCOTCH@,1)
+ (echo "Using bundled Scotch")
+ (cd "../../@SCOTCH_DIR@/src"; make)
+else
+ (echo "Not using bundled Scotch")
+endif
+
+
+clean:
+ (rm -rf $O/*.o $E/xmeshfem2D $E/xmeshfem2D.trace \
+ $O/*.il *.mod core \
+ $E/xcheck_quality_external_mesh \
+ *.oo *.ipo)
+
+
+help:
+ @echo "usage: make [executable]"
+ @echo ""
+ @echo "supported executables:"
+ @echo " xmeshfem3D"
+ @echo " xcheck_quality_external_mesh"
+ @echo ""
+
+##
+## mesher
+##
+xmeshfem2D: $(OBJS_MESHFEM2D)
+ $(LINK) $(FLAGS_CHECK) -o ${E}/xmeshfem2D $(OBJS_MESHFEM2D) $(LIB)
+
+##
+## check_quality_external_mesh
+##
+xcheck_quality_external_mesh: $O/check_quality_external_mesh.o $O/read_value_parameters.o
+ ${F90} $(FLAGS_CHECK) -o ${E}/xcheck_quality_external_mesh $O/check_quality_external_mesh.o $O/read_value_parameters.o
+
+##
+## object files
+##
+
+##
+## meshfem2D
+##
+
+$O/get_node_number.o: ${S}/get_node_number.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/get_node_number.o ${S}/get_node_number.f90
+
+$O/meshfem2D.o: ${S}/meshfem2D.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/meshfem2D.o ${S}/meshfem2D.F90
+
+$O/part_unstruct.o: ${S}/part_unstruct.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/part_unstruct.o ${S}/part_unstruct.F90
+
+$O/read_interfaces_file.o: ${S}/read_interfaces_file.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/read_interfaces_file.o ${S}/read_interfaces_file.f90
+
+$O/read_materials.o: ${S}/read_materials.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/read_materials.o ${S}/read_materials.f90
+
+$O/read_parameter_file.o: ${S}/read_parameter_file.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/read_parameter_file.o ${S}/read_parameter_file.F90
+
+$O/read_regions.o: ${S}/read_regions.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/read_regions.o ${S}/read_regions.f90
+
+$O/read_source_file.o: ${S}/read_source_file.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/read_source_file.o ${S}/read_source_file.f90
+
+$O/save_databases.o: ${S}/save_databases.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/save_databases.o ${S}/save_databases.f90
+
+$O/save_gnuplot_file.o: ${S}/save_gnuplot_file.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/save_gnuplot_file.o ${S}/save_gnuplot_file.f90
+
+$O/save_stations_file.o: ${S}/save_stations_file.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/save_stations_file.o ${S}/save_stations_file.f90
+
+$O/spline_routines.o: ${S}/spline_routines.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/spline_routines.o ${S}/spline_routines.f90
+
+##
+## check_quality_external_mesh
+##
+
+$O/check_quality_external_mesh.o: ${SHARED}/check_quality_external_mesh.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/check_quality_external_mesh.o ${SHARED}/check_quality_external_mesh.f90
+
+##
+## shared
+##
+$O/read_value_parameters.o: ${SHARED}/read_value_parameters.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/read_value_parameters.o ${SHARED}/read_value_parameters.f90
+
+
+
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/get_node_number.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/get_node_number.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/get_node_number.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/get_node_number.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,94 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+! *******************
+! meshing subroutines
+! *******************
+
+!--- global node number
+
+integer function num(i,j,nx)
+
+ implicit none
+
+ integer i,j,nx
+
+ num = j*(nx+1) + i + 1
+
+end function num
+
+
+!--- global node number (when ngnod==4).
+integer function num_4(i,j,nx)
+
+ implicit none
+
+ integer i,j,nx
+
+ num_4 = j*(nx+1) + i + 1
+
+end function num_4
+
+
+!--- global node number (when ngnod==9).
+integer function num_9(i,j,nx,nz)
+
+ implicit none
+
+ integer i,j,nx,nz
+
+
+ if ( (mod(i,2) == 0) .and. (mod(j,2) == 0) ) then
+ num_9 = j/2 * (nx+1) + i/2 + 1
+ else
+ if ( mod(j,2) == 0 ) then
+ num_9 = (nx+1)*(nz+1) + j/2 * nx + ceiling(real(i)/real(2))
+ else
+ num_9 = (nx+1)*(nz+1) + nx*(nz+1) + floor(real(j)/real(2))*(nx*2+1) + i + 1
+
+ endif
+ endif
+
+end function num_9
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/meshfem2D.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/meshfem2D.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/meshfem2D.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/meshfem2D.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,942 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!========================================================================
+!
+! Basic mesh generator for SPECFEM2D
+!
+!========================================================================
+
+! If you use this code for your own research, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{VaCaSaKoVi99,
+! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
+! D. Komatitsch and J. P. Vilotte},
+! title = {Elastic wave propagation in an irregularly layered medium},
+! journal = {Soil Dynamics and Earthquake Engineering},
+! year = {1999},
+! volume = {18},
+! pages = {11-18},
+! number = {1},
+! doi = {10.1016/S0267-7261(98)00027-X}}
+!
+! @ARTICLE{LeChKoHuTr09,
+! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
+! Shouh Huang and Jeroen Tromp},
+! title = {Effects of realistic surface topography on seismic ground motion
+! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
+! method and {LiDAR DTM}},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2009},
+! volume = {99},
+! pages = {681-693},
+! number = {2A},
+! doi = {10.1785/0120080264}}
+!
+! @ARTICLE{LeChLiKoHuTr08,
+! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
+! and Bor Shouh Huang and Jeroen Tromp},
+! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
+! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2008},
+! volume = {98},
+! pages = {253-264},
+! number = {1},
+! doi = {10.1785/0120070033}}
+!
+! @ARTICLE{LeKoHuTr09,
+! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
+! title = {Effects of topography on seismic wave propagation: An example from
+! northern {T}aiwan},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2009},
+! volume = {99},
+! pages = {314-325},
+! number = {1},
+! doi = {10.1785/0120080020}}
+!
+! @ARTICLE{KoErGoMi10,
+! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
+! David Mich\'ea},
+! title = {High-order finite-element seismic wave propagation modeling with
+! {MPI} on a large {GPU} cluster},
+! journal = {J. Comput. Phys.},
+! year = {2010},
+! volume = {229},
+! pages = {7692-7714},
+! number = {20},
+! doi = {10.1016/j.jcp.2010.06.024}}
+!
+! @ARTICLE{KoGoErMi10,
+! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
+! David Mich\'ea},
+! title = {Modeling the propagation of elastic waves using spectral elements
+! on a cluster of 192 {GPU}s},
+! journal = {Computer Science Research and Development},
+! year = {2010},
+! volume = {25},
+! pages = {75-82},
+! number = {1-2},
+! doi = {10.1007/s00450-010-0109-1}}
+!
+! @ARTICLE{KoMiEr09,
+! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
+! title = {Porting a high-order finite-element earthquake modeling application
+! to {NVIDIA} graphics cards using {CUDA}},
+! journal = {Journal of Parallel and Distributed Computing},
+! year = {2009},
+! volume = {69},
+! pages = {451-460},
+! number = {5},
+! doi = {10.1016/j.jpdc.2009.01.006}}
+!
+! @ARTICLE{LiPoKoTr04,
+! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
+! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
+! journal={Bull. Seismol. Soc. Am.},
+! year = {2004},
+! volume = {94},
+! pages = {1748-1761},
+! number = {5},
+! doi = {10.1785/012004038}}
+!
+! @INCOLLECTION{ChKoViCaVaFe07,
+! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
+! Yann Capdeville and Bernard Valette and Gaetano Festa},
+! title = {Spectral Element Analysis in Seismology},
+! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
+! publisher = {Elsevier - Academic Press},
+! year = {2007},
+! editor = {Ru-Shan Wu and Val\'erie Maupin},
+! volume = {48},
+! series = {Advances in Geophysics},
+! pages = {365-419}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoLiTrSuStSh04,
+! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
+! and Christiane Stidham and John H. Shaw},
+! year=2004,
+! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
+! based upon the Spectral-Element Method},
+! journal={Bull. Seism. Soc. Am.},
+! volume=94,
+! number=1,
+! pages={187-206}}
+!
+! @ARTICLE{MoTr08,
+! author={C. Morency and J. Tromp},
+! title={Spectral-element simulations of wave propagation in poroelastic media},
+! journal={Geophys. J. Int.},
+! year=2008,
+! volume=175,
+! pages={301-345}}
+!
+! and/or other articles from http://web.univ-pau.fr/~dkomati1/publications.html
+!
+! If you use the kernel capabilities of the code, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! @ARTICLE{MoLuTr09,
+! author={C. Morency and Y. Luo and J. Tromp},
+! title={Finite-frequency kernels for wave propagation in porous media based upon adjoint methods},
+! year=2009,
+! journal={Geophys. J. Int.},
+! doi={10.1111/j.1365-246X.2009.04332}}
+!
+! If you use the METIS / SCOTCH / CUBIT non-structured capabilities, please also cite:
+!
+! @ARTICLE{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},
+! journal = {Lecture Notes in Computer Science},
+! year = {2008},
+! volume = {5336},
+! pages = {350-363}}
+!
+! version 6.1, Christina Morency and Pieyre Le Loher, March 2010:
+! - added SH (membrane) waves calculation for elastic media
+! - added support for external fully anisotropic media
+! - fixed some bugs in acoustic kernels
+!
+! version 6.0, Christina Morency and Yang Luo, August 2009:
+! - support for poroelastic media
+! - adjoint method for acoustic/elastic/poroelastic
+!
+! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, February 2008:
+! - support for CUBIT and GiD meshes
+! - 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)
+! - merged loops in the solver for efficiency
+! - simplified input of external model
+! - added CPU time information
+! - translated many comments from French to English
+!
+! version 5.1, Dimitri Komatitsch, January 2005:
+! - more general mesher with any number of curved layers
+! - Dirac and Gaussian time sources and corresponding convolution routine
+! - option for acoustic medium instead of elastic
+! - receivers at any location, not only grid points
+! - moment-tensor source at any location, not only a grid point
+! - color snapshots
+! - more flexible DATA/Par_file with any number of comment lines
+! - Xsu scripts for seismograms
+! - subtract t0 from seismograms
+! - seismograms and snapshots in pressure in addition to vector field
+!
+! version 5.0, Dimitri Komatitsch, May 2004:
+! - got rid of useless routines, suppressed commons etc.
+! - weak formulation based explicitly on stress tensor
+! - implementation of full anisotropy
+! - implementation of attenuation based on memory variables
+!
+! based on SPECFEM2D version 4.2, June 1998
+! (c) by Dimitri Komatitsch, Harvard University, USA
+! and Jean-Pierre Vilotte, Institut de Physique du Globe de Paris, France
+!
+! itself based on SPECFEM2D version 1.0, 1995
+! (c) by Dimitri Komatitsch and Jean-Pierre Vilotte,
+! Institut de Physique du Globe de Paris, France
+!
+
+! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
+! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
+! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement is then: u = grad(Chi) / rho
+! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+! The source in an acoustic element is a pressure source.
+! First-order acoustic-acoustic discontinuities are also handled automatically
+! because pressure is continuous at such an interface, therefore Chi_dot_dot
+! is continuous, therefore Chi is also continuous, which is consistent with
+! the spectral-element basis functions and with the assembling process.
+! This is the reason why a simple displacement potential u = grad(Chi) would
+! not work because it would be discontinuous at such an interface and would
+! therefore not be consistent with the basis functions.
+
+program meshfem2D
+
+ use part_unstruct
+ use parameter_file
+ use source_file
+ use interfaces_file
+ implicit none
+
+ include "constants.h"
+
+ ! coordinates of the grid points of the mesh
+ double precision, dimension(:,:), allocatable :: x,z
+
+ ! to compute the coordinate transformation
+ integer :: ioffset
+ double precision :: gamma,absx,a00,a01,bot0,top0
+
+ ! to store density and velocity model
+ integer, dimension(:), allocatable :: num_material
+
+ ! interface data
+ integer :: max_npoints_interface,number_of_interfaces,npoints_interface_bottom, &
+ npoints_interface_top
+ integer :: number_of_layers
+ integer :: nz,nxread,nzread
+
+ integer :: ilayer,ipoint_current
+ integer, dimension(:), pointer :: nz_layer
+ double precision, dimension(:), allocatable :: &
+ xinterface_bottom,zinterface_bottom,coefs_interface_bottom, &
+ xinterface_top,zinterface_top,coefs_interface_top
+
+ integer :: nspec
+ integer :: nbregion
+
+ ! external functions
+ integer, external :: num_4, num_9
+ double precision, external :: value_spline
+
+ ! variables used for storing info about the mesh and partitions
+ integer, dimension(:), allocatable :: my_interfaces
+ integer, dimension(:), allocatable :: my_nb_interfaces
+
+ integer :: num_start
+ integer :: num_node
+
+ ! variables used for tangential detection
+ integer :: nnodes_tangential_curve
+ double precision, dimension(:,:), allocatable :: nodes_tangential_curve
+
+#ifdef USE_SCOTCH
+ integer :: edgecut
+#endif
+
+ integer :: iproc
+ integer :: ix,iz,i,j
+ integer :: imaterial_number,inumelem
+ integer :: i_source,ios
+ double precision :: tang1,tangN
+
+ ! ***
+ ! *** read the parameter file
+ ! ***
+
+ print *,'Reading the parameter file ... '
+ print *
+
+ open(unit=IIN,file='DATA/Par_file',status='old',iostat=ios)
+ if( ios /= 0 ) stop 'error opening DATA/Par_file file'
+
+ ! reads in parameters in DATA/Par_file
+ call read_parameter_file()
+
+ ! reads in mesh elements
+ if ( read_external_mesh ) then
+ call read_external_mesh_file(mesh_file, num_start, ngnod)
+
+ else
+ call read_interfaces_file(interfacesfile,max_npoints_interface, &
+ number_of_interfaces,npoints_interface_bottom, &
+ number_of_layers,nz_layer,nx,nz,nxread,nzread,ngnod, &
+ nelmnts,elmnts)
+ endif
+
+ allocate(num_material(nelmnts))
+ num_material(:) = 0
+
+ ! assigns materials to mesh elements
+ if ( read_external_mesh ) then
+ call read_mat(materials_file, num_material)
+ else
+ call read_regions(nbregion,nb_materials,icodemat,cp,cs, &
+ rho_s,Qp,Qs,aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
+ nelmnts,num_material,nxread,nzread)
+ endif
+
+ close(IIN)
+
+ print *
+ print *,'Parameter file successfully read... '
+
+ ! reads in source descriptions
+ call read_source_file(NSOURCES)
+
+ ! reads in 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 = 1 ! dummy values instead of 0
+ allocate(nodes_tangential_curve(2,1))
+ endif
+
+
+ !---
+
+ if(ngnod /= 4 .and. ngnod /= 9) stop 'ngnod different from 4 or 9!'
+
+ print *
+ print *,'The mesh contains ',nelmnts,' elements'
+ print *
+ print *,'Control elements have ',ngnod,' nodes'
+ print *
+
+ !---
+
+ if ( .not. read_external_mesh ) then
+ ! allocate arrays for the grid
+ allocate(x(0:nx,0:nz))
+ allocate(z(0:nx,0:nz))
+
+ x(:,:) = 0.d0
+ z(:,:) = 0.d0
+
+ ! get interface data from external file
+ print *,'Reading interface data from file DATA/',interfacesfile(1:len_trim(interfacesfile))
+ open(unit=IIN_INTERFACES,file='DATA/'//interfacesfile,status='old')
+
+ allocate(xinterface_bottom(max_npoints_interface))
+ allocate(zinterface_bottom(max_npoints_interface))
+ allocate(coefs_interface_bottom(max_npoints_interface))
+
+ allocate(xinterface_top(max_npoints_interface))
+ allocate(zinterface_top(max_npoints_interface))
+ allocate(coefs_interface_top(max_npoints_interface))
+
+ ! read number of interfaces
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,number_of_interfaces)
+
+ ! read bottom interface
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_bottom)
+
+ ! loop on all the points describing this interface
+ do ipoint_current = 1,npoints_interface_bottom
+ call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
+ xinterface_bottom(ipoint_current),zinterface_bottom(ipoint_current))
+ enddo
+
+ ! loop on all the layers
+ do ilayer = 1,number_of_layers
+
+ ! read top interface
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_top)
+
+ ! loop on all the points describing this interface
+ do ipoint_current = 1,npoints_interface_top
+ call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
+ xinterface_top(ipoint_current),zinterface_top(ipoint_current))
+ enddo
+
+ ! compute the spline for the bottom interface, impose the tangent on both edges
+ tang1 = (zinterface_bottom(2)-zinterface_bottom(1)) / (xinterface_bottom(2)-xinterface_bottom(1))
+ tangN = (zinterface_bottom(npoints_interface_bottom)-zinterface_bottom(npoints_interface_bottom-1)) / &
+ (xinterface_bottom(npoints_interface_bottom)-xinterface_bottom(npoints_interface_bottom-1))
+ call spline_construction(xinterface_bottom,zinterface_bottom,npoints_interface_bottom,tang1,tangN,coefs_interface_bottom)
+
+ ! compute the spline for the top interface, impose the tangent on both edges
+ tang1 = (zinterface_top(2)-zinterface_top(1)) / (xinterface_top(2)-xinterface_top(1))
+ tangN = (zinterface_top(npoints_interface_top)-zinterface_top(npoints_interface_top-1)) / &
+ (xinterface_top(npoints_interface_top)-xinterface_top(npoints_interface_top-1))
+ call spline_construction(xinterface_top,zinterface_top,npoints_interface_top,tang1,tangN,coefs_interface_top)
+
+ ! 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
+ do i_source=1,NSOURCES
+ 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
+ ioffset = sum(nz_layer(1:ilayer-1))
+ else
+ ioffset = 0
+ endif
+
+ !--- definition of the mesh
+
+ do ix = 0,nx
+
+ ! evenly spaced points along X
+ absx = xmin + (xmax - xmin) * dble(ix) / dble(nx)
+
+ ! value of the bottom and top splines
+ bot0 = value_spline(absx,xinterface_bottom,zinterface_bottom,coefs_interface_bottom,npoints_interface_bottom)
+ top0 = value_spline(absx,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+
+ do iz = 0,nz_layer(ilayer)
+
+ ! linear interpolation between bottom and top
+ gamma = dble(iz) / dble(nz_layer(ilayer))
+ a00 = 1.d0 - gamma
+ a01 = gamma
+
+ ! coordinates of the grid points
+ x(ix,iz + ioffset) = absx
+ z(ix,iz + ioffset) = a00*bot0 + a01*top0
+
+ enddo
+
+ enddo
+
+ ! the top interface becomes the bottom interface before switching to the next layer
+ npoints_interface_bottom = npoints_interface_top
+ xinterface_bottom(:) = xinterface_top(:)
+ zinterface_bottom(:) = zinterface_top(:)
+
+ enddo
+
+ close(IIN_INTERFACES)
+
+ nnodes = (nz+1)*(nx+1)
+ allocate(nodes_coords(2,nnodes))
+ if ( ngnod == 4 ) then
+ do j = 0, nz
+ do i = 0, nx
+ num_node = num_4(i,j,nxread)
+ nodes_coords(1, num_node) = x(i,j)
+ nodes_coords(2, num_node) = z(i,j)
+
+ enddo
+ enddo
+
+ else
+ do j = 0, nz
+ do i = 0, nx
+ num_node = num_9(i,j,nxread,nzread)
+ nodes_coords(1, num_node) = x(i,j)
+ nodes_coords(2, num_node) = z(i,j)
+ enddo
+ enddo
+
+ endif
+ else
+ call read_nodes_coords(nodes_coords_file)
+ endif
+
+
+ if ( read_external_mesh ) then
+ call read_acoustic_surface(free_surface_file, num_material, &
+ ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
+
+ if ( any_abs ) then
+ call read_abs_surface(absorbing_surface_file, num_start)
+ endif
+
+ else
+
+ ! count the number of acoustic free-surface elements
+ nelem_acoustic_surface = 0
+
+ ! if the surface is absorbing, it cannot be free at the same time
+ if(.not. abstop) then
+ 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
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ endif
+ enddo
+ endif
+ if(.not. absbottom) then
+ j = 1
+ 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
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ endif
+ enddo
+ endif
+ if(.not. absleft) then
+ i = 1
+ do j = 1,nzread
+ imaterial_number = num_material((j-1)*nxread+i)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ endif
+ enddo
+ endif
+ if(.not. absright) then
+ i = nxread
+ do j = 1,nzread
+ imaterial_number = num_material((j-1)*nxread+i)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ endif
+ enddo
+ endif
+
+
+ allocate(acoustic_surface(4,nelem_acoustic_surface))
+
+ nelem_acoustic_surface = 0
+
+ if(.not. abstop) then
+ 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
+ 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
+ enddo
+ endif
+ if(.not. absbottom) then
+ j = 1
+ 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
+ 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(0+ngnod*((j-1)*nxread+i-1))
+ acoustic_surface(4,nelem_acoustic_surface) = elmnts(1+ngnod*((j-1)*nxread+i-1))
+ endif
+ enddo
+ endif
+ if(.not. absleft) then
+ i = 1
+ do j = 1,nzread
+ imaterial_number = num_material((j-1)*nxread+i)
+ 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(0+ngnod*((j-1)*nxread+i-1))
+ acoustic_surface(4,nelem_acoustic_surface) = elmnts(3+ngnod*((j-1)*nxread+i-1))
+ endif
+ enddo
+ endif
+ if(.not. absright) then
+ i = nxread
+ do j = 1,nzread
+ imaterial_number = num_material((j-1)*nxread+i)
+ 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(1+ngnod*((j-1)*nxread+i-1))
+ acoustic_surface(4,nelem_acoustic_surface) = elmnts(2+ngnod*((j-1)*nxread+i-1))
+ endif
+ enddo
+ endif
+
+ !
+ !--- definition of absorbing boundaries
+ !
+ nelemabs = 0
+ if(absbottom) nelemabs = nelemabs + nxread
+ if(abstop) nelemabs = nelemabs + nxread
+ if(absleft) nelemabs = nelemabs + nzread
+ if(absright) nelemabs = nelemabs + nzread
+
+ allocate(abs_surface(4,nelemabs))
+
+ ! generate the list of absorbing elements
+ if(nelemabs > 0) then
+ nelemabs = 0
+ do iz = 1,nzread
+ do ix = 1,nxread
+ inumelem = (iz-1)*nxread + ix
+ if(absbottom .and. iz == 1) then
+ nelemabs = nelemabs + 1
+ abs_surface(1,nelemabs) = inumelem-1
+ abs_surface(2,nelemabs) = 2
+ abs_surface(3,nelemabs) = elmnts(0+ngnod*(inumelem-1))
+ abs_surface(4,nelemabs) = elmnts(1+ngnod*(inumelem-1))
+ endif
+ if(absright .and. ix == nxread) then
+ nelemabs = nelemabs + 1
+ abs_surface(1,nelemabs) = inumelem-1
+ abs_surface(2,nelemabs) = 2
+ abs_surface(3,nelemabs) = elmnts(1+ngnod*(inumelem-1))
+ abs_surface(4,nelemabs) = elmnts(2+ngnod*(inumelem-1))
+ endif
+ if(abstop .and. iz == nzread) then
+ nelemabs = nelemabs + 1
+ abs_surface(1,nelemabs) = inumelem-1
+ abs_surface(2,nelemabs) = 2
+ abs_surface(3,nelemabs) = elmnts(3+ngnod*(inumelem-1))
+ abs_surface(4,nelemabs) = elmnts(2+ngnod*(inumelem-1))
+ endif
+ if(absleft .and. ix == 1) then
+ nelemabs = nelemabs + 1
+ abs_surface(1,nelemabs) = inumelem-1
+ abs_surface(2,nelemabs) = 2
+ abs_surface(3,nelemabs) = elmnts(0+ngnod*(inumelem-1))
+ abs_surface(4,nelemabs) = elmnts(3+ngnod*(inumelem-1))
+ endif
+ enddo
+ enddo
+ endif
+
+ endif
+
+
+ ! compute min and max of X and Z in the grid
+ print *
+ print *,'Min and max value of X in the grid = ',minval(nodes_coords(1,:)),maxval(nodes_coords(1,:))
+ print *,'Min and max value of Z in the grid = ',minval(nodes_coords(2,:)),maxval(nodes_coords(2,:))
+ print *
+
+
+ ! ***
+ ! *** create a Gnuplot file that displays the grid
+ ! ***
+ if ( .not. read_external_mesh ) then
+ call save_gnuplot_file(ngnod,nx,nz,x,z)
+ endif
+
+
+ !*****************************
+ ! partitioning
+ !*****************************
+
+ ! allocates & initializes partioning of elements
+ allocate(part(0:nelmnts-1))
+ part(:) = -1
+
+ if( nproc > 1 ) then
+ allocate(xadj_g(0:nelmnts))
+ allocate(adjncy_g(0:MAX_NEIGHBORS*nelmnts-1))
+ xadj_g(:) = 0
+ adjncy_g(:) = -1
+ endif
+
+ ! construction of the graph
+
+ ! if ngnod == 9, we work on a subarray of elements that represents the elements with four nodes (four corners) only
+ ! because the adjacency of the mesh elements can be entirely determined from the knowledge of the four corners only
+ if ( ngnod == 9 ) then
+ allocate(elmnts_bis(0:NCORNERS*nelmnts-1))
+ do i = 0, nelmnts-1
+ elmnts_bis(i*NCORNERS:i*NCORNERS+NCORNERS-1) = elmnts(i*ngnod:i*ngnod+NCORNERS-1)
+ enddo
+
+ if ( nproc > 1 ) then
+
+!! DK DK fixed problem in the previous implementation by Nicolas Le Goff:
+!! DK DK (nxread+1)*(nzread+1) is OK for a regular internal mesh only, not for non structured external meshes
+!! DK DK call mesh2dual_ncommonnodes(nelmnts, (nxread+1)*(nzread+1), elmnts_bis, xadj, adjncy, nnodes_elmnts, nodes_elmnts,1)
+!! DK DK the subset of element corners is not renumbered therefore we must still use the nnodes computed for 9 nodes here
+ ! determines maximum neighbors based on 1 common node
+ call mesh2dual_ncommonnodes(elmnts_bis,1,xadj_g,adjncy_g)
+ endif
+
+ else
+ if ( nproc > 1 ) then
+ ! determines maximum neighbors based on 1 common node
+ call mesh2dual_ncommonnodes(elmnts,1,xadj_g,adjncy_g)
+ endif
+
+ endif
+
+
+ if ( nproc == 1 ) then
+ part(:) = 0 ! single process has rank 0
+ else
+
+ ! number of common edges
+ nb_edges = xadj_g(nelmnts)
+
+ ! giving weight to edges and vertices. Currently not used.
+ call read_weights()
+
+ ! partitioning
+ 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
+ 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
+! print *, 'This version of SPECFEM was not compiled with support of METIS.'
+! print *, 'Please recompile with -DUSE_METIS in order to enable use of METIS.'
+! stop
+!#endif
+ stop 'support for the METIS graph partitioner has been discontinued, please use SCOTCH (option 3) instead'
+
+ case(3)
+
+#ifdef USE_SCOTCH
+ call Part_scotch(nproc, edgecut)
+#else
+ print *, 'This version of SPECFEM was not compiled with support of SCOTCH.'
+ print *, 'Please recompile with -DUSE_SCOTCH in order to enable use of SCOTCH.'
+ stop
+#endif
+
+ end select
+
+ endif
+
+ ! beware of fluid solid edges : coupled elements are transfered to the same partition
+ if ( ngnod == 9 ) then
+ call acoustic_elastic_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
+ else
+ call acoustic_elastic_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
+ endif
+ ! beware of fluid porous edges : coupled elements are transfered to the same partition
+ if ( ngnod == 9 ) then
+ call acoustic_poro_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
+ else
+ call acoustic_poro_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
+ endif
+ ! beware of porous solid edges : coupled elements are transfered to the same partition
+ if ( ngnod == 9 ) then
+ call poro_elastic_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
+ else
+ call poro_elastic_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
+ endif
+
+ ! local number of each element for each partition
+ call Construct_glob2loc_elmnts(nproc)
+
+ if ( ngnod == 9 ) then
+ if( allocated(nnodes_elmnts) ) deallocate(nnodes_elmnts)
+ if( allocated(nodes_elmnts) ) deallocate(nodes_elmnts)
+ allocate(nnodes_elmnts(0:nnodes-1))
+ allocate(nodes_elmnts(0:nsize*nnodes-1))
+ nnodes_elmnts(:) = 0
+ nodes_elmnts(:) = 0
+ do i = 0, ngnod*nelmnts-1
+ nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
+ nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
+ enddo
+ else
+ if ( nproc < 2 ) then
+ if( .not. allocated(nnodes_elmnts) ) allocate(nnodes_elmnts(0:nnodes-1))
+ if( .not. allocated(nodes_elmnts) ) allocate(nodes_elmnts(0:nsize*nnodes-1))
+ nnodes_elmnts(:) = 0
+ nodes_elmnts(:) = 0
+ do i = 0, ngnod*nelmnts-1
+ nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
+ nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
+ enddo
+ endif
+ endif
+
+ ! local number of each node for each partition
+ call Construct_glob2loc_nodes(nproc)
+
+ ! construct the interfaces between partitions (used for MPI assembly)
+ if ( nproc /= 1 ) then
+ if ( ngnod == 9 ) then
+ call Construct_interfaces(nproc, elmnts_bis, &
+ nb_materials, phi, num_material)
+ else
+ call Construct_interfaces(nproc, elmnts, &
+ nb_materials, phi, num_material)
+ endif
+ allocate(my_interfaces(0:ninterfaces-1))
+ allocate(my_nb_interfaces(0:ninterfaces-1))
+ endif
+
+ ! setting absorbing boundaries by elements instead of edges
+ if ( any_abs ) then
+ call merge_abs_boundaries(nb_materials, phi, num_material, ngnod)
+ endif
+
+ ! *** generate the databases for the solver
+ call save_databases(nspec,num_material, &
+ my_interfaces,my_nb_interfaces, &
+ nnodes_tangential_curve,nodes_tangential_curve)
+
+ ! print position of the source
+ do i_source=1,NSOURCES
+ print *
+ 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 (generate_STATIONS) then
+ call save_stations_file(nreceiverlines,nrec,xdeb,zdeb,xfin,zfin,enreg_surf_same_vertical, &
+ xinterface_top,zinterface_top,coefs_interface_top, &
+ npoints_interface_top,max_npoints_interface)
+ endif
+
+ print *
+ 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
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/part_unstruct.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/part_unstruct.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/part_unstruct.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/part_unstruct.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,1654 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!
+! This module contains subroutines related to unstructured meshes and partitioning of the
+! corresponding graphs.
+!
+
+module part_unstruct
+
+ implicit none
+
+ integer :: nelmnts
+ integer, dimension(:), pointer :: elmnts
+ integer, dimension(:), allocatable :: elmnts_bis
+ integer, dimension(:), allocatable :: vwgt
+ integer, dimension(:), allocatable :: glob2loc_elmnts
+ integer, dimension(:), allocatable :: part
+
+ integer :: nb_edges
+ integer, dimension(:), allocatable :: adjwgt
+
+ integer, dimension(:), allocatable :: xadj_g
+ integer, dimension(:), allocatable :: adjncy_g
+
+ integer :: nnodes
+ double precision, dimension(:,:), allocatable :: nodes_coords
+ integer, dimension(:), allocatable :: nnodes_elmnts
+ integer, dimension(:), allocatable :: nodes_elmnts
+ integer, dimension(:), allocatable :: glob2loc_nodes_nparts
+ integer, dimension(:), allocatable :: glob2loc_nodes_parts
+ integer, dimension(:), allocatable :: glob2loc_nodes
+
+ ! interface data
+ integer :: ninterfaces
+ integer, dimension(:), allocatable :: tab_size_interfaces, tab_interfaces
+
+ integer :: nelem_acoustic_surface
+ integer, dimension(:,:), pointer :: acoustic_surface
+ integer :: nelem_acoustic_surface_loc
+
+ integer :: nelemabs
+ integer, dimension(:,:), allocatable :: abs_surface
+ logical, dimension(:,:), allocatable :: abs_surface_char
+ integer, dimension(:), allocatable :: abs_surface_merge
+ integer :: nelemabs_loc
+
+ integer :: nelemabs_merge
+ integer, dimension(:), allocatable :: ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
+ jbegin_left,jend_left,jbegin_right,jend_right
+
+ ! for acoustic/elastic coupled elements
+ integer :: nedges_coupled
+ integer, dimension(:,:), pointer :: edges_coupled
+
+ ! for acoustic/poroelastic coupled elements
+ integer :: nedges_acporo_coupled
+ integer, dimension(:,:), pointer :: edges_acporo_coupled
+
+ ! for poroelastic/elastic coupled elements
+ integer :: nedges_elporo_coupled
+ integer, dimension(:,:), pointer :: edges_elporo_coupled
+
+contains
+
+ !-----------------------------------------------
+ ! Read the mesh and storing it in array 'elmnts' (which is allocated here).
+ ! 'num_start' is used to have the numbering of the nodes starting at '0'.
+ ! 'nelmnts' is the number of elements, 'nnodes' is the number of nodes in the mesh.
+ !-----------------------------------------------
+ subroutine read_external_mesh_file(filename, num_start, ngnod)
+
+ implicit none
+ !include "constants.h"
+
+ character(len=256), intent(in) :: filename
+ integer, intent(out) :: num_start
+ integer, intent(in) :: ngnod
+
+ integer :: i,ier
+
+ open(unit=990, file=trim(filename), form='formatted' , status='old', action='read',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening file: ',trim(filename)
+ stop 'error read external mesh file'
+ endif
+
+ read(990,*) nelmnts
+
+ allocate(elmnts(0:ngnod*nelmnts-1))
+
+ do i = 0, nelmnts-1
+ if(ngnod == 4) then
+ read(990,*) elmnts(i*ngnod), elmnts(i*ngnod+1), elmnts(i*ngnod+2), elmnts(i*ngnod+3)
+ else if(ngnod == 9) then
+ read(990,*) elmnts(i*ngnod), elmnts(i*ngnod+1), elmnts(i*ngnod+2), elmnts(i*ngnod+3), &
+ elmnts(i*ngnod+4), elmnts(i*ngnod+5), elmnts(i*ngnod+6), elmnts(i*ngnod+7), elmnts(i*ngnod+8)
+ else
+ stop 'error, ngnod should be either 4 or 9 for external meshes'
+ endif
+ enddo
+
+ close(990)
+
+ num_start = minval(elmnts)
+ elmnts(:) = elmnts(:) - num_start
+ nnodes = maxval(elmnts) + 1
+
+ end subroutine read_external_mesh_file
+
+ !-----------------------------------------------
+ ! Read the nodes coordinates and storing it in array 'nodes_coords'
+ !-----------------------------------------------
+ subroutine read_nodes_coords(filename)
+
+ implicit none
+
+ character(len=256), intent(in) :: filename
+
+ integer :: i,ier
+
+ open(unit=991, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening file: ',trim(filename)
+ stop 'error read external nodes coords file'
+ endif
+
+ read(991,*) nnodes
+ allocate(nodes_coords(2,nnodes))
+ do i = 1, nnodes
+ read(991,*) nodes_coords(1,i), nodes_coords(2,i)
+ enddo
+ close(991)
+
+ end subroutine read_nodes_coords
+
+
+ !-----------------------------------------------
+ ! Read the material for each element and storing it in array 'num_materials'
+ !-----------------------------------------------
+ subroutine read_mat(filename, num_material)
+
+ implicit none
+
+ character(len=256), intent(in) :: filename
+ integer, dimension(1:nelmnts), intent(out) :: num_material
+
+ integer :: i,ier
+
+ open(unit=992, file=trim(filename), form='formatted' , status='old', action='read',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening file: ',trim(filename)
+ stop 'error read external mat file'
+ endif
+
+ do i = 1, nelmnts
+ read(992,*) num_material(i)
+ enddo
+ close(992)
+
+ end subroutine read_mat
+
+
+ !-----------------------------------------------
+ ! Read free surface.
+ ! Edges from elastic elements are discarded.
+ ! 'acoustic_surface' contains 1/ element number, 2/ number of nodes that form the free surface,
+ ! 3/ first node on the free surface, 4/ second node on the free surface, if relevant (if 2/ is equal to 2)
+ !-----------------------------------------------
+ subroutine read_acoustic_surface(filename, num_material, &
+ ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
+
+ implicit none
+
+ !include "constants.h"
+
+ character(len=256), intent(in) :: filename
+ integer, dimension(0:nelmnts-1) :: num_material
+ 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
+ integer, intent(in) :: num_start
+
+
+ integer, dimension(:,:), allocatable :: acoustic_surface_tmp
+ integer :: nelmnts_surface
+ integer :: i,ier
+ integer :: imaterial_number
+
+
+ open(unit=993, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening file: ',trim(filename)
+ stop 'error read acoustic surface file'
+ endif
+
+ read(993,*) nelmnts_surface
+
+ allocate(acoustic_surface_tmp(4,nelmnts_surface))
+
+ 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)
+
+ enddo
+
+ close(993)
+ acoustic_surface_tmp(1,:) = acoustic_surface_tmp(1,:) - num_start
+ acoustic_surface_tmp(3,:) = acoustic_surface_tmp(3,:) - num_start
+ acoustic_surface_tmp(4,:) = acoustic_surface_tmp(4,:) - num_start
+
+ nelem_acoustic_surface = 0
+ do i = 1, nelmnts_surface
+ imaterial_number = num_material(acoustic_surface_tmp(1,i))
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+
+ endif
+ enddo
+
+ allocate(acoustic_surface(4,nelem_acoustic_surface))
+
+ nelem_acoustic_surface = 0
+ do i = 1, nelmnts_surface
+ imaterial_number = num_material(acoustic_surface_tmp(1,i))
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ acoustic_surface(:,nelem_acoustic_surface) = acoustic_surface_tmp(:,i)
+ endif
+ enddo
+
+ end subroutine read_acoustic_surface
+
+
+ !-----------------------------------------------
+ ! Read absorbing surface.
+ ! 'abs_surface' contains 1/ element number, 2/ number of nodes that form the absorbing edge
+ ! (which currently must always be equal to two, see comment below),
+ ! 3/ first node on the abs surface, 4/ second node on the abs surface
+ !-----------------------------------------------
+ subroutine read_abs_surface(filename, num_start)
+
+ implicit none
+ !include "constants.h"
+
+ character(len=256), intent(in) :: filename
+ integer, intent(in) :: num_start
+
+ integer :: i,ier
+
+ open(unit=994, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
+ if( ier /= 0 ) then
+ print *,'error opening file: ',trim(filename)
+ stop 'error read absorbing surface file'
+ endif
+
+ read(994,*) nelemabs
+
+ allocate(abs_surface(4,nelemabs))
+
+ do i = 1, nelemabs
+ read(994,*) abs_surface(1,i), abs_surface(2,i), abs_surface(3,i), abs_surface(4,i)
+ if (abs_surface(2,i) /= 2) then
+ print *,'The input format is currently limited: only two nodes per element can be listed.'
+ print *,'If one of your elements has more than one edge along a given absorbing contour'
+ print *,'(e.g., if that contour has a corner) then list it twice,'
+ print *,'putting the first edge on the first line and the second edge on the second line.'
+ print *,'if one of your elements has a single point along the absording contour rather than a full edge, do NOT list it'
+ print *,'(it would have no weight in the contour integral anyway because it would consist of a single point).'
+ print *,'If you are using 9-node elements, list only the first and last points of the edge and not the intermediate point'
+ print *,'located around the middle of the edge; the right 9-node curvature will be restored automatically by the code.'
+ stop 'only two nodes per element should be listed for absorbing edges'
+ endif
+ enddo
+
+ close(994)
+
+ abs_surface(1,:) = abs_surface(1,:) - num_start
+ abs_surface(3,:) = abs_surface(3,:) - num_start
+ abs_surface(4,:) = abs_surface(4,:) - num_start
+
+ end subroutine read_abs_surface
+
+
+ !-----------------------------------------------
+ ! Creating dual graph (adjacency is defined by 'ncommonnodes' between two elements).
+ !-----------------------------------------------
+ subroutine mesh2dual_ncommonnodes(elmnts_l,ncommonnodes,xadj,adjncy)
+
+ implicit none
+ include "constants.h"
+
+ integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
+ integer, intent(in) :: ncommonnodes
+ integer, dimension(0:nelmnts),intent(out) :: xadj
+ integer, dimension(0:MAX_NEIGHBORS*nelmnts-1),intent(out) :: adjncy
+
+ ! local parameters
+ integer :: i, j, k, l, m, num_edges
+ logical :: is_neighbour
+ integer :: num_node, n
+ integer :: elem_base, elem_target
+ integer :: connectivity
+
+ ! allocates memory for arrays
+ if( .not. allocated(nnodes_elmnts) ) allocate(nnodes_elmnts(0:nnodes-1))
+ if( .not. allocated(nodes_elmnts) ) allocate(nodes_elmnts(0:nsize*nnodes-1))
+
+ ! initializes
+ xadj(:) = 0
+ adjncy(:) = 0
+ nnodes_elmnts(:) = 0
+ nodes_elmnts(:) = 0
+ num_edges = 0
+
+ ! list of elements per node
+ do i = 0, NCORNERS*nelmnts-1
+ nodes_elmnts(elmnts_l(i)*nsize + nnodes_elmnts(elmnts_l(i))) = i/NCORNERS
+ nnodes_elmnts(elmnts_l(i)) = nnodes_elmnts(elmnts_l(i)) + 1
+ enddo
+
+ ! checking which elements are neighbours ('ncommonnodes' criteria)
+ do j = 0, nnodes-1
+ do k = 0, nnodes_elmnts(j)-1
+ do l = k+1, nnodes_elmnts(j)-1
+
+ connectivity = 0
+ elem_base = nodes_elmnts(k+j*nsize)
+ elem_target = nodes_elmnts(l+j*nsize)
+ do n = 1, NCORNERS
+ num_node = elmnts_l(NCORNERS*elem_base+n-1)
+ do m = 0, nnodes_elmnts(num_node)-1
+ if ( nodes_elmnts(m+num_node*nsize) == elem_target ) then
+ connectivity = connectivity + 1
+ endif
+ enddo
+ enddo
+
+ ! sets adjacency (adjncy) and number of neighbors (xadj)
+ ! according to ncommonnodes criteria
+ if ( connectivity >= ncommonnodes) then
+
+ is_neighbour = .false.
+
+ do m = 0, xadj(nodes_elmnts(k+j*nsize))
+ if ( .not.is_neighbour ) then
+ if ( adjncy(nodes_elmnts(k+j*nsize)*MAX_NEIGHBORS+m) == nodes_elmnts(l+j*nsize) ) then
+ is_neighbour = .true.
+ endif
+ endif
+ enddo
+ if ( .not.is_neighbour ) then
+ adjncy(nodes_elmnts(k+j*nsize)*MAX_NEIGHBORS &
+ + xadj(nodes_elmnts(k+j*nsize))) = nodes_elmnts(l+j*nsize)
+
+ xadj(nodes_elmnts(k+j*nsize)) = xadj(nodes_elmnts(k+j*nsize)) + 1
+ if (xadj(nodes_elmnts(k+j*nsize)) > MAX_NEIGHBORS) &
+ stop 'ERROR : too much neighbours per element, modify the mesh.'
+
+ adjncy(nodes_elmnts(l+j*nsize)*MAX_NEIGHBORS &
+ + xadj(nodes_elmnts(l+j*nsize))) = nodes_elmnts(k+j*nsize)
+
+ xadj(nodes_elmnts(l+j*nsize)) = xadj(nodes_elmnts(l+j*nsize)) + 1
+ if (xadj(nodes_elmnts(l+j*nsize))>MAX_NEIGHBORS) &
+ stop 'ERROR : too much neighbours per element, modify the mesh.'
+
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! making adjacency arrays compact (to be used for partitioning)
+ do i = 0, nelmnts-1
+ k = xadj(i)
+ xadj(i) = num_edges
+ do j = 0, k-1
+ adjncy(num_edges) = adjncy(i*MAX_NEIGHBORS+j)
+ num_edges = num_edges + 1
+ enddo
+ enddo
+
+ xadj(nelmnts) = num_edges
+
+ end subroutine mesh2dual_ncommonnodes
+
+
+ !-----------------------------------------------
+ ! Read the weight for each vertices and edges of the graph (not curretly used)
+ !-----------------------------------------------
+ subroutine read_weights()
+
+ implicit none
+
+ allocate(vwgt(0:nelmnts-1))
+ allocate(adjwgt(0:nb_edges-1))
+
+ vwgt(:) = 1
+ adjwgt(:) = 1
+
+ end subroutine read_weights
+
+
+ !--------------------------------------------------
+ ! construct local numbering for the elements in each partition
+ !--------------------------------------------------
+ subroutine Construct_glob2loc_elmnts(nparts)
+
+ implicit none
+ integer, intent(in) :: nparts
+
+ integer :: num_glob, num_part
+ integer, dimension(0:nparts-1) :: num_loc
+
+
+ allocate(glob2loc_elmnts(0:nelmnts-1))
+
+ ! initializes number of local elements per partition
+ do num_part = 0, nparts-1
+ num_loc(num_part) = 0
+ enddo
+
+ ! local numbering
+ 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
+ enddo
+
+ end subroutine Construct_glob2loc_elmnts
+
+
+ !--------------------------------------------------
+ ! construct local numbering for the nodes in each partition
+ !--------------------------------------------------
+ subroutine Construct_glob2loc_nodes(nparts)
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: nparts
+
+ integer :: num_node
+ integer :: el
+ integer :: num_part
+ integer :: size_glob2loc_nodes
+ integer, dimension(0:nparts-1) :: parts_node
+ integer, dimension(0:nparts-1) :: num_parts
+
+ allocate(glob2loc_nodes_nparts(0:nnodes))
+
+ size_glob2loc_nodes = 0
+
+ parts_node(:) = 0
+
+
+ do num_node = 0, nnodes-1
+ glob2loc_nodes_nparts(num_node) = size_glob2loc_nodes
+ do el = 0, nnodes_elmnts(num_node)-1
+ parts_node(part(nodes_elmnts(el+nsize*num_node))) = 1
+ 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
+ endif
+ enddo
+
+ enddo
+
+ glob2loc_nodes_nparts(nnodes) = size_glob2loc_nodes
+
+ allocate(glob2loc_nodes_parts(0:glob2loc_nodes_nparts(nnodes)-1))
+ allocate(glob2loc_nodes(0:glob2loc_nodes_nparts(nnodes)-1))
+
+ glob2loc_nodes(0) = 0
+
+ parts_node(:) = 0
+ num_parts(:) = 0
+ size_glob2loc_nodes = 0
+
+
+ do num_node = 0, nnodes-1
+ do el = 0, nnodes_elmnts(num_node)-1
+ parts_node(part(nodes_elmnts(el+nsize*num_node))) = 1
+ enddo
+ do num_part = 0, nparts-1
+
+ if ( parts_node(num_part) == 1 ) then
+ glob2loc_nodes_parts(size_glob2loc_nodes) = num_part
+ glob2loc_nodes(size_glob2loc_nodes) = num_parts(num_part)
+ size_glob2loc_nodes = size_glob2loc_nodes + 1
+ num_parts(num_part) = num_parts(num_part) + 1
+ parts_node(num_part) = 0
+ endif
+
+ enddo
+ enddo
+
+ end subroutine Construct_glob2loc_nodes
+
+
+ !--------------------------------------------------
+ ! Construct interfaces between each partitions.
+ ! Two adjacent elements in distinct partitions make an entry in array tab_interfaces :
+ ! 1/ first element, 2/ second element, 3/ number of common nodes, 4/ first node,
+ ! 5/ second node, if relevant.
+ ! No interface between acoustic, elastic, and poroelastic elements.
+ !--------------------------------------------------
+ subroutine Construct_interfaces(nparts, elmnts_l, &
+ nb_materials, phi_material, num_material)
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: nparts
+ integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+ integer, intent(in) :: nb_materials
+ double precision, dimension(1:nb_materials), intent(in) :: phi_material
+
+ integer :: num_part, num_part_bis, el, el_adj, num_interface, num_edge, ncommon_nodes, &
+ num_node, num_node_bis
+ integer :: i, j
+ logical :: is_acoustic_el, is_acoustic_el_adj, is_elastic_el, is_elastic_el_adj
+
+ ninterfaces = 0
+ do i = 0, nparts-1
+ do j = i+1, nparts-1
+ ninterfaces = ninterfaces + 1
+ enddo
+ enddo
+
+ allocate(tab_size_interfaces(0:ninterfaces))
+ tab_size_interfaces(:) = 0
+
+ num_interface = 0
+ num_edge = 0
+
+ do num_part = 0, nparts-1
+ do num_part_bis = num_part+1, nparts-1
+ do el = 0, nelmnts-1
+ if ( part(el) == num_part ) then
+ ! sets material flag
+ if ( phi_material(num_material(el+1)) < TINYVAL) then
+ ! elastic element
+ is_acoustic_el = .false.
+ is_elastic_el = .true.
+ elseif ( phi_material(num_material(el+1)) >= 1.d0) then
+ ! acoustic element
+ is_acoustic_el = .true.
+ is_elastic_el = .false.
+ else
+ ! poroelastic element
+ is_acoustic_el = .false.
+ is_elastic_el = .false.
+ endif
+
+ ! looks at all neighbor elements
+ do el_adj = xadj_g(el), xadj_g(el+1)-1
+ ! sets neighbor material flag
+ if ( phi_material(num_material(adjncy_g(el_adj)+1)) < TINYVAL) then
+ is_acoustic_el_adj = .false.
+ is_elastic_el_adj = .true.
+ elseif ( phi_material(num_material(adjncy_g(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.
+ endif
+ ! adds element if neighbor element lies in next parition
+ ! and belongs to same material
+ if ( (part(adjncy_g(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
+ endif
+ enddo
+ endif
+ enddo
+ ! stores number of elements at interface
+ tab_size_interfaces(num_interface+1) = tab_size_interfaces(num_interface) + num_edge
+ num_edge = 0
+ num_interface = num_interface + 1
+
+ enddo
+ enddo
+
+ ! stores element indices for elements from above search at each interface
+ num_interface = 0
+ num_edge = 0
+
+ allocate(tab_interfaces(0:(tab_size_interfaces(ninterfaces)*5-1)))
+ tab_interfaces(:) = 0
+
+ do num_part = 0, nparts-1
+ do num_part_bis = num_part+1, nparts-1
+ do el = 0, nelmnts-1
+ if ( part(el) == num_part ) then
+ if ( phi_material(num_material(el+1)) < TINYVAL) then
+ is_acoustic_el = .false.
+ 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.
+ endif
+ do el_adj = xadj_g(el), xadj_g(el+1)-1
+ if ( phi_material(num_material(adjncy_g(el_adj)+1)) < TINYVAL) then
+ is_acoustic_el_adj = .false.
+ is_elastic_el_adj = .true.
+ elseif ( phi_material(num_material(adjncy_g(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.
+ endif
+ if ( (part(adjncy_g(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_g(el_adj)
+ ncommon_nodes = 0
+ do num_node = 0, 4-1
+ do num_node_bis = 0, 4-1
+ if ( elmnts_l(el*NCORNERS+num_node) == &
+ elmnts_l(adjncy_g(el_adj)*NCORNERS+num_node_bis) ) then
+ tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+3+ncommon_nodes) &
+ = elmnts_l(el*NCORNERS+num_node)
+ ncommon_nodes = ncommon_nodes + 1
+ 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
+ stop 'fatal error'
+ endif
+ num_edge = num_edge + 1
+ endif
+ enddo
+ endif
+
+ enddo
+ num_edge = 0
+ num_interface = num_interface + 1
+ enddo
+ enddo
+
+ end subroutine Construct_interfaces
+
+
+ !--------------------------------------------------
+ ! Write nodes (their coordinates) pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+ subroutine write_glob2loc_nodes_database(IIN_database, iproc, npgeo, num_phase)
+
+ implicit none
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc, num_phase
+ integer, intent(inout) :: npgeo
+
+ integer :: i, j
+
+ if ( num_phase == 1 ) then
+ npgeo = 0
+
+ do i = 0, nnodes-1
+ do j = glob2loc_nodes_nparts(i), glob2loc_nodes_nparts(i+1)-1
+ if ( glob2loc_nodes_parts(j) == iproc ) then
+ npgeo = npgeo + 1
+ endif
+ 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)
+ endif
+ enddo
+ enddo
+ endif
+
+ end subroutine Write_glob2loc_nodes_database
+
+
+ !--------------------------------------------------
+ ! Write elements (their nodes) pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+ subroutine write_partition_database(IIN_database, iproc, nspec, &
+ num_modele, ngnod, num_phase)
+
+ implicit none
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: num_phase, iproc
+ integer, intent(inout) :: nspec
+ integer, dimension(:) :: num_modele
+ integer, intent(in) :: ngnod
+
+ integer :: i,j,k
+ integer, dimension(0:ngnod-1) :: loc_nodes
+
+ if (num_phase == 1) then
+
+ nspec = 0
+
+ do i = 0, nelmnts-1
+ if (part(i) == iproc) nspec = nspec + 1
+ enddo
+
+ else
+ do i = 0, nelmnts-1
+ 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) 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)
+ endif
+ enddo
+
+ endif
+
+ end subroutine write_partition_database
+
+
+ !--------------------------------------------------
+ ! Write interfaces (element and common nodes) pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+ subroutine Write_interfaces_database(IIN_database, nparts, iproc, &
+ my_ninterface, my_interfaces, my_nb_interfaces, num_phase)
+
+ implicit none
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc
+ integer, intent(in) :: nparts
+ integer, intent(inout) :: my_ninterface
+ integer, dimension(0:ninterfaces-1), intent(inout) :: my_interfaces
+ integer, dimension(0:ninterfaces-1), intent(inout) :: my_nb_interfaces
+
+ integer, dimension(2) :: local_nodes
+ integer :: local_elmnt
+ integer :: num_phase
+
+ integer :: i, j, k, l
+ integer :: num_interface
+
+ num_interface = 0
+
+ if ( num_phase == 1 ) then
+
+ my_interfaces(:) = 0
+ my_nb_interfaces(:) = 0
+
+ do i = 0, nparts-1
+ do j = i+1, nparts-1
+ if ( (tab_size_interfaces(num_interface) < tab_size_interfaces(num_interface+1)) .and. &
+ (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)
+ endif
+ num_interface = num_interface + 1
+ enddo
+ enddo
+ my_ninterface = sum(my_interfaces(:))
+
+ else
+
+ do i = 0, nparts-1
+ do j = i+1, nparts-1
+ if ( my_interfaces(num_interface) == 1 ) then
+ if ( i == iproc ) then
+ write(IIN_database,*) j, my_nb_interfaces(num_interface)
+ else
+ write(IIN_database,*) i, my_nb_interfaces(num_interface)
+ 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
+ endif
+
+ if ( tab_interfaces(k*5+2) == 1 ) then
+ ! common node (single point)
+ 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
+ endif
+ enddo
+
+ write(IIN_database,*) local_elmnt, tab_interfaces(k*5+2), &
+ local_nodes(1), -1
+ else
+ if ( tab_interfaces(k*5+2) == 2 ) then
+ ! common edge (two nodes)
+ ! first node
+ 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
+ endif
+ enddo
+ ! second node
+ 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
+ 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)
+ endif
+ endif
+ enddo
+
+ endif
+
+ num_interface = num_interface + 1
+ enddo
+ enddo
+
+ endif
+
+ end subroutine Write_interfaces_database
+
+
+ !--------------------------------------------------
+ ! Write a surface (elements and nodes on the surface) pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+ subroutine Write_surface_database(IIN_database, nsurface, surface, &
+ nsurface_loc, iproc, num_phase)
+
+ implicit none
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc
+ integer :: nsurface
+ integer :: nsurface_loc
+ integer, dimension(:,:), pointer :: surface
+
+ integer, dimension(2) :: local_nodes
+ integer :: local_elmnt
+ integer :: num_phase
+
+ integer :: i, l
+
+ if ( num_phase == 1 ) then
+
+ nsurface_loc = 0
+
+ do i = 1, nsurface
+ if ( part(surface(1,i)) == iproc ) then
+ nsurface_loc = nsurface_loc + 1
+ endif
+ enddo
+
+ else
+
+ nsurface_loc = 0
+
+ do i = 1, nsurface
+ if ( part(surface(1,i)) == iproc ) then
+ nsurface_loc = nsurface_loc + 1
+
+ local_elmnt = glob2loc_elmnts(surface(1,i)) + 1
+
+ if ( surface(2,i) == 1 ) 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
+ endif
+ enddo
+
+ write(IIN_database,*) local_elmnt, surface(2,i), local_nodes(1), -1
+ 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
+ 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
+ endif
+ enddo
+
+ write(IIN_database,*) local_elmnt, surface(2,i), local_nodes(1), local_nodes(2)
+ endif
+
+ endif
+
+ enddo
+
+ 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 relation (this is the
+ ! reason arrays ibegin_..., iend_... were included here).
+ ! Under development : exluding points that have two different normals in two different elements.
+ !--------------------------------------------------
+
+ subroutine merge_abs_boundaries(nb_materials, phi_material, num_material, ngnod)
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: ngnod
+ integer :: nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+
+ logical, dimension(nb_materials) :: is_acoustic
+ integer :: num_edge, nedge_bound
+ integer :: match
+ integer :: nb_elmnts_abs
+ integer :: i
+ integer :: temp
+ integer :: iedge, inode1, inode2
+
+ allocate(abs_surface_char(4,nelemabs))
+ allocate(abs_surface_merge(nelemabs))
+ abs_surface_char(:,:) = .false.
+ abs_surface_merge(:) = -1
+
+ nedge_bound = nelemabs
+ nb_elmnts_abs = 0
+
+ do num_edge = 1, nedge_bound
+
+ match = 0
+ do i = 1, nb_elmnts_abs
+ if ( abs_surface(1,num_edge) == abs_surface_merge(i) ) then
+ match = i
+ exit
+ endif
+ enddo
+
+ if ( match == 0 ) then
+ nb_elmnts_abs = nb_elmnts_abs + 1
+ match = nb_elmnts_abs
+ endif
+
+ abs_surface_merge(match) = abs_surface(1,num_edge)
+
+
+ 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)+1)) ) then
+ abs_surface_char(1,match) = .true.
+
+ 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
+ temp = abs_surface(4,num_edge)
+ abs_surface(4,num_edge) = abs_surface(3,num_edge)
+ abs_surface(3,num_edge) = temp
+ abs_surface_char(1,match) = .true.
+
+ 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.
+
+ 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
+ temp = abs_surface(4,num_edge)
+ abs_surface(4,num_edge) = abs_surface(3,num_edge)
+ abs_surface(3,num_edge) = temp
+ abs_surface_char(4,match) = .true.
+
+ 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.
+
+ 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
+ temp = abs_surface(4,num_edge)
+ abs_surface(4,num_edge) = abs_surface(3,num_edge)
+ abs_surface(3,num_edge) = temp
+ abs_surface_char(2,match) = .true.
+
+ 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
+ temp = abs_surface(4,num_edge)
+ abs_surface(4,num_edge) = abs_surface(3,num_edge)
+ abs_surface(3,num_edge) = temp
+ abs_surface_char(3,match) = .true.
+
+ 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.
+
+ endif
+
+ enddo
+
+ nelemabs_merge = nb_elmnts_abs
+
+ allocate(ibegin_bottom(nelemabs_merge))
+ allocate(iend_bottom(nelemabs_merge))
+ allocate(jbegin_right(nelemabs_merge))
+ allocate(jend_right(nelemabs_merge))
+ allocate(ibegin_top(nelemabs_merge))
+ allocate(iend_top(nelemabs_merge))
+ allocate(jbegin_left(nelemabs_merge))
+ allocate(jend_left(nelemabs_merge))
+
+ ibegin_bottom(:) = 1
+ jbegin_right(:) = 1
+ ibegin_top(:) = 1
+ jbegin_left(:) = 1
+ iend_bottom(:) = NGLLX
+ jend_right(:) = NGLLZ
+ iend_top(:) = NGLLX
+ jend_left(:) = NGLLZ
+
+ is_acoustic(:) = .false.
+
+ do i = 1, nb_materials
+ if (phi_material(i) >= 1.d0) then
+ is_acoustic(i) = .true.
+ endif
+ enddo
+
+ do num_edge = 1, nedge_bound
+
+ match = 0
+ do i = 1, nelemabs_merge
+ if ( abs_surface(1,num_edge) == abs_surface_merge(i) ) then
+ match = i
+ exit
+ endif
+ enddo
+
+ if ( is_acoustic(num_material(abs_surface(1,num_edge)+1)) ) then
+
+ do iedge = 1, nedges_coupled
+
+ do inode1 = 0, 3
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_coupled(1,iedge)+inode1) ) then
+ do inode2 = 0, 3
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_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
+
+ 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
+
+ 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
+
+ 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
+
+ endif
+
+ endif
+ enddo
+
+ endif
+
+ if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_coupled(1,iedge)+inode1) ) then
+ do inode2 = 0, 3
+ if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_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
+
+ 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
+
+ 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
+
+ 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
+
+ endif
+ endif
+ enddo
+
+ endif
+
+ enddo
+
+
+ enddo
+
+ endif
+
+ enddo
+
+ end subroutine merge_abs_boundaries
+
+
+ !--------------------------------------------------
+ ! Write abs surface (elements and nodes on the surface) pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+
+ subroutine write_abs_merge_database(IIN_database, iproc, num_phase)
+
+ implicit none
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc
+ integer, intent(in) :: num_phase
+
+ integer :: i
+
+ if ( num_phase == 1 ) then
+ nelemabs_loc = 0
+ do i = 1, nelemabs_merge
+ if ( part(abs_surface_merge(i)) == iproc ) then
+ nelemabs_loc = nelemabs_loc + 1
+ endif
+ enddo
+ else
+ do i = 1, nelemabs_merge
+ if ( part(abs_surface_merge(i)) == iproc ) then
+
+ write(IIN_database,*) glob2loc_elmnts(abs_surface_merge(i))+1, abs_surface_char(1,i), &
+ abs_surface_char(2,i), abs_surface_char(3,i), abs_surface_char(4,i), &
+ ibegin_bottom(i), iend_bottom(i), &
+ jbegin_right(i), jend_right(i), &
+ ibegin_top(i), iend_top(i), &
+ jbegin_left(i), jend_left(i)
+
+ endif
+
+ enddo
+ endif
+
+ end subroutine write_abs_merge_database
+
+
+!! DK DK support for METIS now removed, we use SCOTCH instead
+!#ifdef USE_METIS
+! !--------------------------------------------------
+! ! Partitioning using METIS
+! !--------------------------------------------------
+! 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_NEIGHBORS*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
+! integer, dimension(0:4) :: metis_options
+!
+! integer :: wgtflag
+! integer :: num_start
+!
+! num_start = 0
+! wgtflag = 0
+!
+! 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));
+!
+! end subroutine Part_metis
+!#endif
+
+
+#ifdef USE_SCOTCH
+ !--------------------------------------------------
+ ! Partitioning using SCOTCH
+ !--------------------------------------------------
+ subroutine Part_scotch(nparts, edgecut)
+
+ implicit none
+ include "constants.h"
+
+ include "scotchf.h"
+
+ integer, intent(in) :: nparts
+ integer, intent(inout) :: edgecut
+
+ double precision, dimension(SCOTCH_GRAPHDIM) :: SCOTCHGRAPH
+ double precision, dimension(SCOTCH_STRATDIM) :: SCOTCHSTRAT
+ integer :: IERR
+
+ edgecut = vwgt(0)
+ edgecut = 0
+
+ ! we use default strategy for partitioning, thus omit specifing explicit strategy .
+ call scotchfstratinit (SCOTCHSTRAT(1), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot initialize strat'
+ STOP
+ ENDIF
+
+ CALL SCOTCHFGRAPHINIT (SCOTCHGRAPH (1), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot initialize graph'
+ STOP
+ ENDIF
+
+ ! fills graph structure : see user manual (scotch_user5.1.pdf, page 72/73)
+ ! arguments: #(1) graph_structure #(2) baseval(either 0/1) #(3) number_of_vertices
+ ! #(4) adjacency_index_array #(5) adjacency_end_index_array (optional)
+ ! #(6) vertex_load_array (optional) #(7) vertex_label_array
+ ! #(7) number_of_arcs #(8) adjacency_array
+ ! #(9) arc_load_array (optional) #(10) ierror
+ CALL SCOTCHFGRAPHBUILD (SCOTCHGRAPH (1), 0, nelmnts, &
+ xadj_g(0), xadj_g(0), &
+ xadj_g(0), xadj_g(0), &
+ nb_edges, &
+ adjncy_g(0), adjwgt (0), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot build graph'
+ STOP
+ ENDIF
+
+ CALL SCOTCHFGRAPHCHECK (SCOTCHGRAPH (1), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Invalid check'
+ STOP
+ ENDIF
+
+ call scotchfgraphpart (SCOTCHGRAPH (1), nparts, SCOTCHSTRAT(1), part(0), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot part graph'
+ STOP
+ ENDIF
+
+ CALL SCOTCHFGRAPHEXIT (SCOTCHGRAPH (1), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot destroy graph'
+ STOP
+ ENDIF
+
+ call scotchfstratexit (SCOTCHSTRAT(1), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot destroy strat'
+ STOP
+ ENDIF
+
+ end subroutine Part_scotch
+#endif
+
+
+ !--------------------------------------------------
+ ! Repartitioning : two coupled acoustic/elastic elements are transfered to the same partition
+ !--------------------------------------------------
+
+ subroutine acoustic_elastic_repartitioning (elmnts_l, nb_materials, &
+ phi_material, num_material, nproc)
+
+ implicit none
+ include "constants.h"
+
+ integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
+ integer, intent(in) :: nproc, nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+
+ ! local parameters
+ integer, dimension(:), allocatable :: xadj_l
+ integer, dimension(:), allocatable :: adjncy_l
+ logical, dimension(nb_materials) :: is_acoustic, is_elastic
+ integer :: i, num_edge
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ allocate(xadj_l(0:nelmnts))
+ allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
+
+ is_acoustic(:) = .false.
+ is_elastic(:) = .false.
+
+ do i = 1, nb_materials
+ if (phi_material(i) >= 1.d0) then
+ is_acoustic(i) = .true.
+ endif
+ if (phi_material(i) < TINYVAL) then
+ is_elastic(i) = .true.
+ endif
+ enddo
+
+ ! determines maximum neighbors based on 2 common nodes (common edge)
+ call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
+
+ nedges_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_coupled = nedges_coupled + 1
+ endif
+ enddo
+ endif
+ enddo
+
+ allocate(edges_coupled(2,nedges_coupled))
+
+ nedges_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_coupled = nedges_coupled + 1
+ edges_coupled(1,nedges_coupled) = el
+ edges_coupled(2,nedges_coupled) = adjncy_l(el_adj)
+ endif
+
+ enddo
+ endif
+ enddo
+
+ do i = 1, nedges_coupled*nproc
+ is_repartitioned = .false.
+ do num_edge = 1, nedges_coupled
+ if ( part(edges_coupled(1,num_edge)) /= part(edges_coupled(2,num_edge)) ) then
+ if ( part(edges_coupled(1,num_edge)) < part(edges_coupled(2,num_edge)) ) then
+ 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))
+ endif
+ is_repartitioned = .true.
+ endif
+
+ enddo
+ if ( .not. is_repartitioned ) then
+ exit
+ endif
+ enddo
+
+ deallocate(xadj_l,adjncy_l)
+
+ end subroutine acoustic_elastic_repartitioning
+
+
+ !--------------------------------------------------
+ ! Repartitioning : two coupled acoustic/poroelastic elements are transfered to the same partition
+ !--------------------------------------------------
+
+ subroutine acoustic_poro_repartitioning (elmnts_l, nb_materials, &
+ phi_material, num_material, nproc)
+
+ implicit none
+ include "constants.h"
+
+ integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
+ integer, intent(in) :: nproc, nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+
+ ! local parameters
+ integer, dimension(:), allocatable :: xadj_l
+ integer, dimension(:), allocatable :: adjncy_l
+ logical, dimension(nb_materials) :: is_acoustic,is_poroelastic
+ integer :: i, num_edge
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ allocate(xadj_l(0:nelmnts))
+ allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
+
+ is_acoustic(:) = .false.
+ is_poroelastic(:) = .false.
+
+ do i = 1, nb_materials
+ if (phi_material(i) >=1.d0) then
+ is_acoustic(i) = .true.
+ endif
+ if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
+ is_poroelastic(i) = .true.
+ endif
+ enddo
+
+ ! determines maximum neighbors based on 2 common nodes (common edge)
+ call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
+
+ nedges_acporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_poroelastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_acporo_coupled = nedges_acporo_coupled + 1
+ endif
+
+ enddo
+ endif
+ enddo
+
+ print *, 'nedges_coupled (acoustic/poroelastic)', nedges_acporo_coupled
+
+ allocate(edges_acporo_coupled(2,nedges_acporo_coupled))
+
+ nedges_acporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_poroelastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_acporo_coupled = nedges_acporo_coupled + 1
+ edges_acporo_coupled(1,nedges_acporo_coupled) = el
+ edges_acporo_coupled(2,nedges_acporo_coupled) = adjncy_l(el_adj)
+ endif
+
+ enddo
+ endif
+ enddo
+
+ do i = 1, nedges_acporo_coupled*nproc
+ is_repartitioned = .false.
+ do num_edge = 1, nedges_acporo_coupled
+ if ( part(edges_acporo_coupled(1,num_edge)) /= part(edges_acporo_coupled(2,num_edge)) ) then
+ if ( part(edges_acporo_coupled(1,num_edge)) < part(edges_acporo_coupled(2,num_edge)) ) then
+ part(edges_acporo_coupled(2,num_edge)) = part(edges_acporo_coupled(1,num_edge))
+ else
+ part(edges_acporo_coupled(1,num_edge)) = part(edges_acporo_coupled(2,num_edge))
+ endif
+ is_repartitioned = .true.
+ endif
+
+ enddo
+ if ( .not. is_repartitioned ) then
+ exit
+ endif
+ enddo
+
+ deallocate(xadj_l,adjncy_l)
+
+ end subroutine acoustic_poro_repartitioning
+
+
+ !--------------------------------------------------
+ ! Repartitioning : two coupled poroelastic/elastic elements are transfered to the same partition
+ !--------------------------------------------------
+
+ subroutine poro_elastic_repartitioning (elmnts_l, nb_materials, &
+ phi_material, num_material, nproc)
+
+ implicit none
+ include "constants.h"
+
+ integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
+ integer, intent(in) :: nproc, nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+
+ ! local parameters
+ integer, dimension(:), allocatable :: xadj_l
+ integer, dimension(:), allocatable :: adjncy_l
+ logical, dimension(nb_materials) :: is_elastic,is_poroelastic
+ integer :: i, num_edge
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ allocate(xadj_l(0:nelmnts))
+ allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
+
+ is_elastic(:) = .false.
+ is_poroelastic(:) = .false.
+
+ do i = 1, nb_materials
+ if (phi_material(i) < TINYVAL) then
+ is_elastic(i) = .true.
+ endif
+ if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
+ is_poroelastic(i) = .true.
+ endif
+ enddo
+
+ ! determines maximum neighbors based on 2 common nodes (common edge)
+ call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
+
+ nedges_elporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_poroelastic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_elporo_coupled = nedges_elporo_coupled + 1
+ endif
+
+ enddo
+ endif
+ enddo
+
+ print *, 'nedges_coupled (poroelastic/elastic)', nedges_elporo_coupled
+
+ allocate(edges_elporo_coupled(2,nedges_elporo_coupled))
+
+ nedges_elporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_poroelastic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_elporo_coupled = nedges_elporo_coupled + 1
+ edges_elporo_coupled(1,nedges_elporo_coupled) = el
+ edges_elporo_coupled(2,nedges_elporo_coupled) = adjncy_l(el_adj)
+ endif
+
+ enddo
+ endif
+ enddo
+
+ do i = 1, nedges_elporo_coupled*nproc
+ is_repartitioned = .false.
+ do num_edge = 1, nedges_elporo_coupled
+ if ( part(edges_elporo_coupled(1,num_edge)) /= part(edges_elporo_coupled(2,num_edge)) ) then
+ if ( part(edges_elporo_coupled(1,num_edge)) < part(edges_elporo_coupled(2,num_edge)) ) then
+ part(edges_elporo_coupled(2,num_edge)) = part(edges_elporo_coupled(1,num_edge))
+ else
+ part(edges_elporo_coupled(1,num_edge)) = part(edges_elporo_coupled(2,num_edge))
+ endif
+ is_repartitioned = .true.
+ endif
+
+ enddo
+ if ( .not. is_repartitioned ) then
+ exit
+ endif
+ enddo
+
+ deallocate(xadj_l,adjncy_l)
+
+ end subroutine poro_elastic_repartitioning
+
+
+ !--------------------------------------------------
+ ! Write fluid/solid edges (fluid (or porous) elements and corresponding solid (or porous) elements)
+ ! pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+
+ subroutine write_fluidsolid_edges_database(IIN_database, nedges_coupled_bis, nedges_coupled_loc_bis, &
+ edges_coupled_bis, iproc, num_phase)
+
+ implicit none
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: nedges_coupled_bis
+ integer, intent(inout) :: nedges_coupled_loc_bis
+ integer, dimension(:,:), pointer :: edges_coupled_bis
+ integer, intent(in) :: iproc
+ integer, intent(in) :: num_phase
+
+ integer :: i
+
+ if ( num_phase == 1 ) then
+ nedges_coupled_loc_bis = 0
+ do i = 1, nedges_coupled_bis
+ if ( part(edges_coupled_bis(1,i)) == iproc ) then
+ nedges_coupled_loc_bis = nedges_coupled_loc_bis + 1
+ endif
+ enddo
+ else
+ do i = 1, nedges_coupled_bis
+ if ( part(edges_coupled_bis(1,i)) == iproc ) then
+ write(IIN_database,*) glob2loc_elmnts(edges_coupled_bis(1,i))+1, glob2loc_elmnts(edges_coupled_bis(2,i))+1
+ endif
+ enddo
+ endif
+
+ end subroutine write_fluidsolid_edges_database
+
+end module part_unstruct
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_interfaces_file.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/read_interfaces_file.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_interfaces_file.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_interfaces_file.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,179 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+module interfaces_file
+
+ ! note: we use this module definition only to be able to allocate
+ ! arrays for receiverlines and materials in this subroutine rather than in the main
+ ! routine in meshfem2D.F90
+
+ ! note 2: the filename ending is .F90 to have pre-compilation with pragmas
+ ! (like #ifndef USE_MPI) working properly
+
+ implicit none
+
+contains
+
+ subroutine read_interfaces_file(interfacesfile,max_npoints_interface, &
+ number_of_interfaces,npoints_interface_bottom, &
+ number_of_layers,nz_layer,nx,nz,nxread,nzread,ngnod, &
+ nelmnts,elmnts)
+ implicit none
+ include "constants.h"
+
+ character(len=100) :: interfacesfile
+
+ integer :: max_npoints_interface,number_of_interfaces,npoints_interface_bottom
+ integer :: number_of_layers,nx,nz,nxread,nzread,ngnod
+ integer :: nelmnts
+ integer, dimension(:), pointer :: nz_layer
+ integer, dimension(:), pointer :: elmnts
+
+ ! local parameters
+ integer :: ios,interface_current,ipoint_current,ilayer,i,j,num_elmnt
+ double precision :: xinterface_dummy,zinterface_dummy,xinterface_dummy_previous
+
+ ! get interface data from external file to count the spectral elements along Z
+ print *,'Reading interface data from file DATA/',interfacesfile(1:len_trim(interfacesfile)),' to count the spectral elements'
+ open(unit=IIN_INTERFACES,file='DATA/'//interfacesfile,status='old',iostat=ios)
+ if( ios /= 0 ) then
+ print*,'error opening file: ',trim('DATA/'//interfacesfile)
+ stop 'error read interface file in meshfem2D'
+ endif
+
+ max_npoints_interface = -1
+
+ ! read number of interfaces
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,number_of_interfaces)
+ if(number_of_interfaces < 2) stop 'not enough interfaces (minimum is 2)'
+
+ ! loop on all the interfaces
+ do interface_current = 1,number_of_interfaces
+
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_bottom)
+ if(npoints_interface_bottom < 2) stop 'not enough interface points (minimum is 2)'
+ max_npoints_interface = max(npoints_interface_bottom,max_npoints_interface)
+ print *,'Reading ',npoints_interface_bottom,' points for interface ',interface_current
+
+ ! loop on all the points describing this interface
+ xinterface_dummy_previous = -HUGEVAL
+ do ipoint_current = 1,npoints_interface_bottom
+ call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK,xinterface_dummy,zinterface_dummy)
+ if(ipoint_current > 1 .and. xinterface_dummy <= xinterface_dummy_previous) &
+ stop 'interface points must be sorted in increasing X'
+ xinterface_dummy_previous = xinterface_dummy
+ enddo
+ enddo
+
+ ! define number of layers
+ number_of_layers = number_of_interfaces - 1
+
+ allocate(nz_layer(number_of_layers))
+
+ ! loop on all the layers
+ do ilayer = 1,number_of_layers
+
+ ! read number of spectral elements in vertical direction in this layer
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,nz_layer(ilayer))
+ if(nz_layer(ilayer) < 1) stop 'not enough spectral elements along Z in layer (minimum is 1)'
+ print *,'There are ',nz_layer(ilayer),' spectral elements along Z in layer ',ilayer
+
+ enddo
+
+ close(IIN_INTERFACES)
+
+ ! compute total number of spectral elements in vertical direction
+ nz = sum(nz_layer)
+
+ print *
+ print *,'Total number of spectral elements along Z = ',nz
+ print *
+
+ nxread = nx
+ nzread = nz
+
+ ! multiply by 2 if elements have 9 nodes
+ if(ngnod == 9) then
+ nx = nx * 2
+ nz = nz * 2
+ nz_layer(:) = nz_layer(:) * 2
+ endif
+
+ nelmnts = nxread * nzread
+ allocate(elmnts(0:ngnod*nelmnts-1))
+
+ if ( ngnod == 4 ) then
+ num_elmnt = 0
+ do j = 1, nzread
+ do i = 1, nxread
+ elmnts(num_elmnt*ngnod) = (j-1)*(nxread+1) + (i-1)
+ elmnts(num_elmnt*ngnod+1) = (j-1)*(nxread+1) + (i-1) + 1
+ 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
+ enddo
+ enddo
+ else
+ num_elmnt = 0
+ do j = 1, nzread
+ do i = 1, nxread
+ elmnts(num_elmnt*ngnod) = (j-1)*(nxread+1) + (i-1)
+ elmnts(num_elmnt*ngnod+1) = (j-1)*(nxread+1) + (i-1) + 1
+ elmnts(num_elmnt*ngnod+2) = j*(nxread+1) + (i-1) + 1
+ elmnts(num_elmnt*ngnod+3) = j*(nxread+1) + (i-1)
+ elmnts(num_elmnt*ngnod+4) = (nxread+1)*(nzread+1) + (j-1)*nxread + (i-1)
+ elmnts(num_elmnt*ngnod+5) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2 + 2
+ elmnts(num_elmnt*ngnod+6) = (nxread+1)*(nzread+1) + j*nxread + (i-1)
+ 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
+ enddo
+ enddo
+
+ endif
+
+
+ end subroutine read_interfaces_file
+
+end module interfaces_file
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_materials.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/read_materials.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_materials.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_materials.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,199 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine read_materials(nb_materials,icodemat,cp,cs, &
+ aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
+ Qp,Qs,rho_s,rho_f,phi,tortuosity, &
+ permxx,permxz,permzz,kappa_s,kappa_f,kappa_fr, &
+ eta_f,mu_fr)
+
+! reads in material definitions in DATA/Par_file
+
+ implicit none
+ include "constants.h"
+
+ integer :: nb_materials
+
+ integer, dimension(nb_materials) :: icodemat
+
+ double precision, dimension(nb_materials) :: rho_s,cp,cs, &
+ aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
+ double precision, dimension(nb_materials) :: rho_f,phi,tortuosity,permxx,permxz,&
+ permzz,kappa_s,kappa_f,kappa_fr,eta_f,mu_fr
+
+ ! local parameters
+ integer :: imaterial,i,icodematread
+ double precision :: val0read,val1read,val2read,val3read,val4read, &
+ val5read,val6read,val7read,val8read,val9read,val10read,val11read,val12read
+
+ ! initializes material properties
+ icodemat(:) = 0
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+ aniso3(:) = 0.d0
+ aniso4(:) = 0.d0
+ aniso5(:) = 0.d0
+ aniso6(:) = 0.d0
+ aniso7(:) = 0.d0
+ aniso8(:) = 0.d0
+ Qp(:) = 0.d0
+ Qs(:) = 0.d0
+ rho_s(:) = 0.d0
+ rho_f(:) = 0.d0
+ phi(:) = 0.d0
+ tortuosity(:) = 0.d0
+ permxx(:) = 0.d0
+ permxz(:) = 0.d0
+ permzz(:) = 0.d0
+ kappa_s(:) = 0.d0
+ kappa_f(:) = 0.d0
+ kappa_fr(:) = 0.d0
+ eta_f(:) = 0.d0
+ mu_fr(:) = 0.d0
+
+ ! reads in material parameters
+ do imaterial=1,nb_materials
+ call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread, &
+ val0read,val1read,val2read,val3read, &
+ val4read,val5read,val6read,val7read, &
+ val8read,val9read,val10read,val11read,val12read)
+
+ ! checks material id
+ if(i < 1 .or. i > nb_materials) stop 'Wrong material number!'
+ icodemat(i) = icodematread
+
+
+ ! sets material properties
+ if(icodemat(i) == ISOTROPIC_MATERIAL) then
+
+ ! isotropic materials
+
+ 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
+ elseif (icodemat(i) == ANISOTROPIC_MATERIAL) then
+
+ ! anisotropic materials
+
+ rho_s(i) = val0read
+ cp(i) = val1read
+ cs(i) = val2read
+ aniso3(i) = val3read
+ aniso4(i) = val4read
+ aniso5(i) = val5read
+ aniso6(i) = val6read
+ aniso7(i) = val7read
+ aniso8(i) = val8read
+ Qp(i) = val9read
+ Qs(i) = val10read
+ else
+
+ ! poroelastic materials
+
+ 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) then
+ stop 'negative value of modulus'
+ end if
+ if(Qs(i) <= 0.d0) stop 'negative value of Qs'
+ endif
+ enddo
+
+ ! user output
+ print *
+ print *, 'Nb of solid, fluid or porous materials = ',nb_materials
+ print *
+ do i=1,nb_materials
+ if(icodemat(i) /= ANISOTROPIC_MATERIAL .and. icodemat(i) /= POROELASTIC_MATERIAL) then
+ print *,'Material #',i,' isotropic'
+ print *,'rho,cp,cs = ',rho_s(i),cp(i),cs(i),Qp(i),Qs(i)
+ if(cs(i) < TINYVAL) then
+ print *,'Material is fluid'
+ else
+ print *,'Material is solid'
+ 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 *,'rho,cp,cs = ',rho_s(i),cp(i),cs(i)
+ print*,'c11,c13,c15,c33,c35,c55 = ',aniso3(i),aniso4(i),aniso5(i),aniso6(i),aniso7(i),aniso8(i)
+ print *,'Qp,Qs = ',Qp(i),Qs(i)
+ endif
+ print *
+ enddo
+
+ end subroutine read_materials
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_parameter_file.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/read_parameter_file.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_parameter_file.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_parameter_file.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,327 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+module parameter_file
+
+ ! note: we use this module definition only to be able to allocate
+ ! arrays for receiverlines and materials in this subroutine rather than in the main
+ ! routine in meshfem2D.F90
+
+ ! note 2: the filename ending is .F90 to have pre-compilation with pragmas
+ ! (like #ifndef USE_MPI) working properly
+
+ implicit none
+ character(len=100) :: interfacesfile,title
+
+ integer :: SIMULATION_TYPE
+ logical :: SAVE_FORWARD,read_external_mesh
+
+ character(len=256) :: mesh_file, nodes_coords_file, materials_file, &
+ free_surface_file, absorbing_surface_file
+ character(len=256) :: tangential_detection_curve_file
+
+ ! variables used for partitioning
+ integer :: nproc,partitioning_method
+
+ double precision :: xmin,xmax
+ integer :: nx,ngnod
+
+ logical :: initialfield,add_Bielak_conditions,assign_external_model, &
+ READ_EXTERNAL_SEP_FILE,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON
+
+ double precision :: Q0,freq0
+
+ logical :: p_sv
+ logical :: any_abs,absbottom,absright,abstop,absleft
+
+ integer :: nt
+ double precision :: deltat
+
+ integer :: NSOURCES
+ logical :: force_normal_to_surface
+
+ ! variables used for attenuation
+ integer :: N_SLS
+ double precision :: f0_attenuation
+
+ integer :: seismotype
+ logical :: generate_STATIONS
+
+ integer :: nreceiverlines
+ double precision :: anglerec
+ logical :: rec_normal_to_surface
+
+ integer, dimension(:), pointer :: nrec
+ double precision, dimension(:), pointer :: xdeb,zdeb,xfin,zfin
+ logical, dimension(:), pointer :: enreg_surf_same_vertical
+
+ integer :: NTSTEP_BETWEEN_OUTPUT_INFO
+ logical :: output_postscript_snapshot,output_color_image
+ integer :: imagetype
+ double precision :: cutsnaps
+ logical :: meshvect,modelvect,boundvect,interpol
+ integer :: pointsdisp,subsamp
+ double precision :: sizemax_arrows
+ logical :: gnuplot,outputgrid,OUTPUT_ENERGY
+ logical :: plot_lowerleft_corner_only
+
+ ! to store density and velocity model
+ integer :: nb_materials
+ integer, dimension(:),pointer :: icodemat
+ double precision, dimension(:),pointer :: rho_s,cp,cs, &
+ aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
+ double precision, dimension(:),pointer :: rho_f,phi,tortuosity,permxx,permxz,&
+ permzz,kappa_s,kappa_f,kappa_fr,eta_f,mu_fr
+
+contains
+
+ subroutine read_parameter_file()
+
+! reads in DATA/Par_file
+
+ implicit none
+ include "constants.h"
+
+ ! local parameters
+ integer :: ios,ireceiverlines
+
+ ! read file names and path for output
+ call read_value_string(IIN,IGNORE_JUNK,title)
+ call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
+
+ write(*,*) 'Title of the simulation'
+ write(*,*) title
+ print *
+
+ ! read type of simulation
+ call read_value_integer(IIN,IGNORE_JUNK,SIMULATION_TYPE)
+ call read_value_logical(IIN,IGNORE_JUNK,SAVE_FORWARD)
+
+ ! read info about external mesh
+ call read_value_logical(IIN,IGNORE_JUNK,read_external_mesh)
+ call read_value_string(IIN,IGNORE_JUNK,mesh_file)
+ call read_value_string(IIN,IGNORE_JUNK,nodes_coords_file)
+ 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,tangential_detection_curve_file)
+
+ ! read info about partitioning
+ call read_value_integer(IIN,IGNORE_JUNK,nproc)
+ call read_value_integer(IIN,IGNORE_JUNK,partitioning_method)
+
+ ! read grid parameters
+ call read_value_double_precision(IIN,IGNORE_JUNK,xmin)
+ call read_value_double_precision(IIN,IGNORE_JUNK,xmax)
+ call read_value_integer(IIN,IGNORE_JUNK,nx)
+ call read_value_integer(IIN,IGNORE_JUNK,ngnod)
+ call read_value_logical(IIN,IGNORE_JUNK,initialfield)
+ call read_value_logical(IIN,IGNORE_JUNK,add_Bielak_conditions)
+ call read_value_logical(IIN,IGNORE_JUNK,assign_external_model)
+ call read_value_logical(IIN,IGNORE_JUNK,READ_EXTERNAL_SEP_FILE)
+ call read_value_logical(IIN,IGNORE_JUNK,TURN_ATTENUATION_ON)
+ ! read viscous attenuation parameters (poroelastic media)
+ call read_value_logical(IIN,IGNORE_JUNK,TURN_VISCATTENUATION_ON)
+ call read_value_double_precision(IIN,IGNORE_JUNK,Q0)
+ call read_value_double_precision(IIN,IGNORE_JUNK,freq0)
+ ! determine if body or surface (membrane) waves calculation
+ call read_value_logical(IIN,IGNORE_JUNK,p_sv)
+
+ ! read absorbing boundaries parameters
+ call read_value_logical(IIN,IGNORE_JUNK,any_abs)
+ call read_value_logical(IIN,IGNORE_JUNK,absbottom)
+ call read_value_logical(IIN,IGNORE_JUNK,absright)
+ call read_value_logical(IIN,IGNORE_JUNK,abstop)
+ call read_value_logical(IIN,IGNORE_JUNK,absleft)
+
+ ! read time step parameters
+ call read_value_integer(IIN,IGNORE_JUNK,nt)
+ call read_value_double_precision(IIN,IGNORE_JUNK,deltat)
+
+ ! read source infos
+ call read_value_integer(IIN,IGNORE_JUNK,NSOURCES)
+ 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,f0_attenuation)
+
+ ! read receiver line parameters
+ call read_value_integer(IIN,IGNORE_JUNK,seismotype)
+ 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'
+
+ ! allocate receiver line arrays
+ allocate(nrec(nreceiverlines))
+ allocate(xdeb(nreceiverlines))
+ allocate(zdeb(nreceiverlines))
+ allocate(xfin(nreceiverlines))
+ allocate(zfin(nreceiverlines))
+ allocate(enreg_surf_same_vertical(nreceiverlines),stat=ios)
+ if( ios /= 0 ) stop 'error allocating receiver lines'
+
+ ! loop on all the receiver lines
+ do ireceiverlines = 1,nreceiverlines
+ call read_value_integer(IIN,IGNORE_JUNK,nrec(ireceiverlines))
+ call read_value_double_precision(IIN,IGNORE_JUNK,xdeb(ireceiverlines))
+ call read_value_double_precision(IIN,IGNORE_JUNK,zdeb(ireceiverlines))
+ 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_same_vertical(ireceiverlines))
+ if (read_external_mesh .and. enreg_surf_same_vertical(ireceiverlines)) then
+ stop 'Cannot use enreg_surf_same_vertical with external meshes!'
+ endif
+ enddo
+
+ ! read display parameters
+ call read_value_integer(IIN,IGNORE_JUNK,NTSTEP_BETWEEN_OUTPUT_INFO)
+ call read_value_logical(IIN,IGNORE_JUNK,output_postscript_snapshot)
+ call read_value_logical(IIN,IGNORE_JUNK,output_color_image)
+ call read_value_integer(IIN,IGNORE_JUNK,imagetype)
+ call read_value_double_precision(IIN,IGNORE_JUNK,cutsnaps)
+ call read_value_logical(IIN,IGNORE_JUNK,meshvect)
+ call read_value_logical(IIN,IGNORE_JUNK,modelvect)
+ call read_value_logical(IIN,IGNORE_JUNK,boundvect)
+ call read_value_logical(IIN,IGNORE_JUNK,interpol)
+ call read_value_integer(IIN,IGNORE_JUNK,pointsdisp)
+ call read_value_integer(IIN,IGNORE_JUNK,subsamp)
+ call read_value_double_precision(IIN,IGNORE_JUNK,sizemax_arrows)
+ call read_value_logical(IIN,IGNORE_JUNK,gnuplot)
+ call read_value_logical(IIN,IGNORE_JUNK,outputgrid)
+ call read_value_logical(IIN,IGNORE_JUNK,OUTPUT_ENERGY)
+
+
+ ! read the different material materials
+ call read_value_integer(IIN,IGNORE_JUNK,nb_materials)
+ 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(aniso5(nb_materials))
+ allocate(aniso6(nb_materials))
+ allocate(aniso7(nb_materials))
+ allocate(aniso8(nb_materials))
+ allocate(Qp(nb_materials))
+ allocate(Qs(nb_materials))
+ allocate(rho_s(nb_materials))
+ allocate(rho_f(nb_materials))
+ allocate(phi(nb_materials))
+ allocate(tortuosity(nb_materials))
+ allocate(permxx(nb_materials))
+ allocate(permxz(nb_materials))
+ allocate(permzz(nb_materials))
+ allocate(kappa_s(nb_materials))
+ allocate(kappa_f(nb_materials))
+ allocate(kappa_fr(nb_materials))
+ allocate(eta_f(nb_materials))
+ allocate(mu_fr(nb_materials))
+
+ call read_materials(nb_materials,icodemat,cp,cs, &
+ aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
+ Qp,Qs,rho_s,rho_f,phi,tortuosity, &
+ permxx,permxz,permzz,kappa_s,kappa_f,kappa_fr, &
+ eta_f,mu_fr)
+
+
+ ! checks input parameters
+ call check_parameters()
+
+ end subroutine read_parameter_file
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine check_parameters()
+
+ implicit none
+
+ ! checks partitioning
+ if ( nproc <= 0 ) then
+ print *, 'Number of processes (nproc) must be greater than or equal to one.'
+ stop
+ endif
+
+#ifndef USE_MPI
+ if ( nproc > 1 ) then
+ print *, 'Number of processes (nproc) must be equal to one when not using MPI.'
+ print *, 'Please recompile with -DUSE_MPI in order to enable use of MPI.'
+ stop
+ endif
+#endif
+
+ if(partitioning_method /= 1 .and. partitioning_method /= 3) then
+ print *, 'Invalid partitioning method number.'
+ print *, 'Partitioning method ',partitioning_method,' was requested, but is not available.'
+ print *, 'Support for the METIS graph partitioner has been discontinued, please use SCOTCH (option 3) instead.'
+ stop
+ endif
+
+ ! checks absorbing boundaries
+ if ( .not. any_abs ) then
+ absbottom = .false.
+ absright = .false.
+ abstop = .false.
+ absleft = .false.
+ endif
+
+ ! can use only one point to display lower-left corner only for interpolated snapshot
+ if(pointsdisp < 3) then
+ pointsdisp = 3
+ plot_lowerleft_corner_only = .true.
+ else
+ plot_lowerleft_corner_only = .false.
+ endif
+
+ end subroutine check_parameters
+
+end module parameter_file
+
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_regions.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/read_regions.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_regions.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_regions.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,145 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine read_regions(nbregion,nb_materials,icodemat,cp,cs, &
+ rho_s,Qp,Qs,aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
+ nelmnts,num_material,nxread,nzread)
+
+! reads in material definitions in DATA/Par_file
+
+ implicit none
+ include "constants.h"
+
+ integer :: nbregion,nb_materials
+ integer, dimension(nb_materials) :: icodemat
+ double precision, dimension(nb_materials) :: rho_s,cp,cs, &
+ aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
+
+ integer :: nelmnts
+ integer,dimension(nelmnts) :: num_material
+ integer :: nxread,nzread
+
+ ! local parameters
+ integer :: iregion,ixdebregion,ixfinregion,izdebregion,izfinregion,imaterial_number
+ integer :: i,j
+ double precision :: vpregion,vsregion,poisson_ratio
+
+ ! read the material numbers for each region
+ call read_value_integer(IIN,IGNORE_JUNK,nbregion)
+
+ if(nbregion <= 0) stop 'Negative number of regions not allowed!'
+
+ print *
+ print *, 'Nb of regions in the mesh = ',nbregion
+ print *
+
+ do iregion = 1,nbregion
+
+ call read_region_coordinates(IIN,DONT_IGNORE_JUNK,ixdebregion,ixfinregion, &
+ izdebregion,izfinregion,imaterial_number)
+
+ if(imaterial_number < 1) stop 'Negative material number not allowed!'
+ if(ixdebregion < 1) stop 'Left coordinate of region negative!'
+ if(ixfinregion > nxread) stop 'Right coordinate of region too high!'
+ if(izdebregion < 1) stop 'Bottom coordinate of region negative!'
+ if(izfinregion > nzread) stop 'Top coordinate of region too high!'
+
+ print *,'Region ',iregion
+ print *,'IX from ',ixdebregion,' to ',ixfinregion
+ print *,'IZ from ',izdebregion,' to ',izfinregion
+
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. icodemat(imaterial_number) /= POROELASTIC_MATERIAL) then
+
+ ! isotropic material
+ 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
+
+ ! poroelastic material
+ print *,'Material # ',imaterial_number,' isotropic'
+ print *,'Material is poroelastic'
+ else
+
+ ! anisotropic material
+ print *,'Material # ',imaterial_number,' anisotropic'
+ print *,'cp = ',cp(imaterial_number)
+ print *,'cs = ',cs(imaterial_number)
+ print *,'c11 = ',aniso3(imaterial_number)
+ print *,'c13 = ',aniso4(imaterial_number)
+ print *,'c15 = ',aniso5(imaterial_number)
+ print *,'c33 = ',aniso6(imaterial_number)
+ print *,'c35 = ',aniso7(imaterial_number)
+ print *,'c55 = ',aniso8(imaterial_number)
+ print *,'rho = ',rho_s(imaterial_number)
+ print *,'Qp = ',Qp(imaterial_number)
+ print *,'Qs = ',Qs(imaterial_number)
+ endif
+ print *,' -----'
+
+ ! store density and velocity model
+ do i = ixdebregion,ixfinregion
+ do j = izdebregion,izfinregion
+ num_material((j-1)*nxread+i) = imaterial_number
+ enddo
+ enddo
+
+ enddo
+
+ if(minval(num_material) <= 0) stop 'Velocity model not entirely set...'
+
+ end subroutine read_regions
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_source_file.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/read_source_file.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_source_file.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/read_source_file.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,144 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+module source_file
+
+ implicit none
+
+ ! source parameters
+ integer, dimension(:),pointer :: source_type,time_function_type
+ double precision, dimension(:),pointer :: xs,zs,f0,tshift_src,angleforce, &
+ Mxx,Mzz,Mxz,factor
+ logical, dimension(:),pointer :: source_surf
+
+contains
+
+ subroutine read_source_file(NSOURCES)
+
+! reads in source file DATA/SOURCE
+
+ implicit none
+ include "constants.h"
+
+ integer :: NSOURCES
+
+ ! local parameters
+ integer :: ios,icounter,i_source,num_sources
+ character(len=150) dummystring
+ integer, parameter :: IIN_SOURCE = 22
+
+ ! allocates memory arrays
+ allocate(source_surf(NSOURCES))
+ allocate(xs(NSOURCES))
+ allocate(zs(NSOURCES))
+ allocate(source_type(NSOURCES))
+ allocate(time_function_type(NSOURCES))
+ allocate(f0(NSOURCES))
+ allocate(tshift_src(NSOURCES))
+ allocate(angleforce(NSOURCES))
+ allocate(Mxx(NSOURCES))
+ allocate(Mxz(NSOURCES))
+ allocate(Mzz(NSOURCES))
+ allocate(factor(NSOURCES))
+
+ ! counts lines
+ open(unit=IIN_SOURCE,file='DATA/SOURCE',iostat=ios,status='old',action='read')
+ if(ios /= 0) stop 'error opening DATA/SOURCE file'
+
+ icounter = 0
+ do while(ios == 0)
+ read(IIN_SOURCE,"(a)",iostat=ios) dummystring
+ if(ios == 0) icounter = icounter + 1
+ enddo
+ close(IIN_SOURCE)
+
+ ! checks counter
+ if(mod(icounter,NLINES_PER_SOURCE) /= 0) &
+ stop 'total number of lines in SOURCE file should be a multiple of NLINES_PER_SOURCE'
+
+ ! total number of sources
+ num_sources = icounter / NLINES_PER_SOURCE
+
+ if(num_sources < 1) stop 'need at least one source in SOURCE file'
+ if(num_sources /= NSOURCES) &
+ stop 'total number of sources read is different than declared in Par_file'
+
+ ! reads in source parameters
+ open(unit=IIN_SOURCE,file='DATA/SOURCE',status='old',action='read')
+ do i_source=1,NSOURCES
+ 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))
+ call read_value_integer(IIN_SOURCE,IGNORE_JUNK,source_type(i_source))
+ call read_value_integer(IIN_SOURCE,IGNORE_JUNK,time_function_type(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,f0(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,tshift_src(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,angleforce(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mxx(i_source))
+ 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))
+
+ ! note: we will further process source info in solver,
+ ! here we just read in the given specifics and show them
+
+ print *
+ print *,'Source', i_source
+ print *,'Position xs, zs = ',xs(i_source),zs(i_source)
+ print *,'Frequency, delay = ',f0(i_source),tshift_src(i_source)
+ print *,'Source type (1=force, 2=explosion): ',source_type(i_source)
+ print *,'Time function type (1=Ricker, 2=First derivative, 3=Gaussian, 4=Dirac, 5=Heaviside): ',time_function_type(i_source)
+ print *,'Angle of the source if force = ',angleforce(i_source)
+ print *,'Mxx of the source if moment tensor = ',Mxx(i_source)
+ print *,'Mzz of the source if moment tensor = ',Mzz(i_source)
+ print *,'Mxz of the source if moment tensor = ',Mxz(i_source)
+ print *,'Multiplying factor = ',factor(i_source)
+ print *
+ enddo ! do i_source=1,NSOURCES
+ close(IIN_SOURCE)
+
+ end subroutine read_source_file
+
+end module source_file
+
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_databases.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/save_databases.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_databases.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_databases.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,263 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine save_databases(nspec,num_material, &
+ my_interfaces,my_nb_interfaces, &
+ nnodes_tangential_curve,nodes_tangential_curve )
+
+
+! generates the databases for the solver
+
+ use part_unstruct
+ use parameter_file
+ use source_file
+ implicit none
+ include "constants.h"
+
+ integer :: nspec
+ integer, dimension(nelmnts) :: num_material
+
+ integer, dimension(0:ninterfaces-1) :: my_interfaces
+ integer, dimension(0:ninterfaces-1) :: my_nb_interfaces
+
+ integer :: nnodes_tangential_curve
+ double precision, dimension(2,nnodes_tangential_curve) :: nodes_tangential_curve
+
+ ! local parameters
+ integer :: iproc,i_source,i,ios
+ integer :: npgeo
+ integer :: my_ninterface
+ integer :: nedges_coupled_loc
+ integer :: nedges_acporo_coupled_loc
+ integer :: nedges_elporo_coupled_loc
+
+ character(len=256) :: prname
+
+
+ do iproc = 0, nproc-1
+
+ ! opens Database file
+ write(prname, "('./OUTPUT_FILES/Database',i5.5)") iproc
+ open(unit=15,file=trim(prname),status='unknown',iostat=ios)
+ if( ios /= 0 ) stop 'error saving databases'
+
+ write(15,*) '#'
+ write(15,*) '# Database for SPECFEM2D'
+ write(15,*) '# Dimitri Komatitsch, (c) University of Pau, France'
+ write(15,*) '#'
+
+ write(15,*) 'Title of the simulation'
+ write(15,"(a100)") title
+
+ write(15,*) 'Type of simulation'
+ write(15,*) SIMULATION_TYPE, SAVE_FORWARD
+
+ call write_glob2loc_nodes_database(15, iproc, npgeo, 1)
+
+
+ call write_partition_database(15, iproc, nspec, num_material, ngnod, 1)
+
+
+ write(15,*) 'npgeo'
+ write(15,*) npgeo
+
+ write(15,*) 'gnuplot interpol'
+ write(15,*) gnuplot,interpol
+
+ write(15,*) 'NTSTEP_BETWEEN_OUTPUT_INFO'
+ write(15,*) NTSTEP_BETWEEN_OUTPUT_INFO
+
+ write(15,*) 'output_postscript_snapshot output_color_image colors numbers'
+ write(15,*) output_postscript_snapshot,output_color_image,' 1 0'
+
+ write(15,*) 'meshvect modelvect boundvect cutsnaps subsamp sizemax_arrows'
+ write(15,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
+
+ write(15,*) 'anglerec'
+ write(15,*) anglerec
+
+ write(15,*) 'initialfield add_Bielak_conditions'
+ write(15,*) initialfield,add_Bielak_conditions
+
+ write(15,*) 'seismotype imagetype'
+ write(15,*) seismotype,imagetype
+
+ write(15,*) 'assign_external_model READ_EXTERNAL_SEP_FILE'
+ write(15,*) assign_external_model,READ_EXTERNAL_SEP_FILE
+
+ write(15,*) 'outputgrid OUTPUT_ENERGY TURN_ATTENUATION_ON'
+ write(15,*) outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON
+
+ write(15,*) 'TURN_VISCATTENUATION_ON Q0 freq0'
+ write(15,*) TURN_VISCATTENUATION_ON,Q0,freq0
+
+ write(15,*) 'p_sv'
+ write(15,*) p_sv
+
+ write(15,*) 'nt deltat'
+ write(15,*) nt,deltat
+ write(15,*) 'NSOURCES'
+ write(15,*) NSOURCES
+
+ do i_source=1,NSOURCES
+ write(15,*) 'source', i_source
+ write(15,*) source_type(i_source),time_function_type(i_source), &
+ xs(i_source),zs(i_source),f0(i_source),tshift_src(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, f0_attenuation
+
+ write(15,*) 'Coordinates of macrobloc mesh (coorg):'
+
+ call write_glob2loc_nodes_database(15, iproc, npgeo, 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
+ call write_abs_merge_database(15, iproc, 1)
+ else
+ nelemabs_loc = 0
+ endif
+
+ call write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
+ iproc, 1)
+
+ call write_fluidsolid_edges_database(15,nedges_coupled, nedges_coupled_loc, &
+ edges_coupled, iproc, 1)
+ call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
+ edges_acporo_coupled, iproc, 1)
+ call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
+ edges_elporo_coupled, iproc, 1)
+
+ if (.not. ( force_normal_to_surface .or. rec_normal_to_surface ) ) then
+ nnodes_tangential_curve = 0
+ endif
+
+ 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 (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
+ if (icodemat(i) == ISOTROPIC_MATERIAL) then
+ write(15,*) i,icodemat(i),rho_s(i),cp(i),cs(i),0,0,Qp(i),Qs(i),0,0,0,0,0,0
+ elseif(icodemat(i) == POROELASTIC_MATERIAL) then
+ 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)
+ else
+ write(15,*) i,icodemat(i),rho_s(i),cp(i),cs(i), &
+ aniso3(i),aniso4(i),aniso5(i),aniso6(i),&
+ aniso7(i),aniso8(i),Qp(i),Qs(i),0,0
+ endif
+ enddo
+
+ write(15,*) 'Arrays kmato and knods for each bloc:'
+
+ call write_partition_database(15, iproc, nspec, num_material, ngnod, 2)
+
+ if ( nproc /= 1 ) then
+ call write_interfaces_database(15, nproc, iproc, &
+ my_ninterface, my_interfaces, my_nb_interfaces, 1)
+
+ write(15,*) 'Interfaces:'
+ write(15,*) my_ninterface, maxval(my_nb_interfaces)
+
+ call write_interfaces_database(15, nproc, iproc, &
+ my_ninterface, my_interfaces, my_nb_interfaces, 2)
+
+ else
+ write(15,*) 'Interfaces:'
+ write(15,*) 0, 0
+ endif
+
+
+ write(15,*) 'List of absorbing elements (bottom right top left):'
+ if ( any_abs ) then
+ call write_abs_merge_database(15, iproc, 2)
+ endif
+
+ write(15,*) 'List of acoustic free-surface elements:'
+ call write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
+ iproc, 2)
+
+
+ write(15,*) 'List of acoustic elastic coupled edges:'
+ call write_fluidsolid_edges_database(15, nedges_coupled, nedges_coupled_loc, &
+ edges_coupled, iproc, 2)
+
+ write(15,*) 'List of acoustic poroelastic coupled edges:'
+ call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
+ edges_acporo_coupled, iproc, 2)
+
+ write(15,*) 'List of poroelastic elastic coupled edges:'
+ call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
+ edges_elporo_coupled, iproc, 2)
+
+ write(15,*) 'List of tangential detection curve nodes:'
+ !write(15,*) nnodes_tangential_curve
+ write(15,*) force_normal_to_surface,rec_normal_to_surface
+
+ if (force_normal_to_surface .or. rec_normal_to_surface) then
+ do i = 1, nnodes_tangential_curve
+ write(15,*) nodes_tangential_curve(1,i),nodes_tangential_curve(2,i)
+ enddo
+ endif
+
+ ! closes Database file
+ close(15)
+
+ enddo
+
+ end subroutine save_databases
+
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_gnuplot_file.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/save_gnuplot_file.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_gnuplot_file.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_gnuplot_file.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,118 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine save_gnuplot_file(ngnod,nx,nz,x,z)
+
+! creates a Gnuplot file that displays the grid
+
+ implicit none
+
+ integer :: ngnod,nx,nz
+ double precision, dimension(0:nx,0:nz) :: x,z
+
+ ! local parameters
+ integer :: ios,istepx,istepz,ili,icol
+
+ print *
+ print *,'Saving the grid in Gnuplot format...'
+
+ open(unit=20,file='OUTPUT_FILES/gridfile.gnu',status='unknown',iostat=ios)
+ if( ios /= 0 ) stop 'error saving gnuplot file'
+
+ ! draw horizontal lines of the grid
+ print *,'drawing horizontal lines of the grid'
+ istepx = 1
+ if(ngnod == 4) then
+ istepz = 1
+ else
+ istepz = 2
+ endif
+ do ili=0,nz,istepz
+ do icol=0,nx-istepx,istepx
+ write(20,*) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,*) sngl(x(icol+istepx,ili)),sngl(z(icol+istepx,ili))
+ write(20,10)
+ enddo
+ enddo
+
+ ! draw vertical lines of the grid
+ print *,'drawing vertical lines of the grid'
+ if(ngnod == 4) then
+ istepx = 1
+ else
+ istepx = 2
+ endif
+ istepz = 1
+ do icol=0,nx,istepx
+ do ili=0,nz-istepz,istepz
+ write(20,*) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,*) sngl(x(icol,ili+istepz)),sngl(z(icol,ili+istepz))
+ write(20,10)
+ enddo
+ enddo
+
+10 format('')
+
+ close(20)
+
+ ! create a Gnuplot script to display the grid
+ open(unit=20,file='OUTPUT_FILES/plotgnu',status='unknown',iostat=ios)
+ if( ios /= 0 ) stop 'error saving plotgnu file'
+
+ write(20,*) '#set term X11'
+ write(20,*) 'set term postscript landscape monochrome solid "Helvetica" 22'
+ write(20,*) 'set output "grid.ps"'
+ write(20,*) '#set xrange [',sngl(minval(x)),':',sngl(maxval(x)),']'
+ write(20,*) '#set yrange [',sngl(minval(z)),':',sngl(maxval(z)),']'
+ ! use same unit length on both X and Y axes
+ write(20,*) 'set size ratio -1'
+ write(20,*) 'plot "gridfile.gnu" title "Macrobloc mesh" w l'
+ write(20,*) 'pause -1 "Hit any key..."'
+ close(20)
+
+ print *,'Grid saved in Gnuplot format...'
+ print *
+
+ end subroutine save_gnuplot_file
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_stations_file.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/save_stations_file.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_stations_file.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/save_stations_file.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,122 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine save_stations_file(nreceiverlines,nrec,xdeb,zdeb,xfin,zfin,enreg_surf_same_vertical, &
+ xinterface_top,zinterface_top,coefs_interface_top, &
+ npoints_interface_top,max_npoints_interface)
+
+ implicit none
+
+ integer :: nreceiverlines
+ integer, dimension(nreceiverlines) :: nrec
+ double precision, dimension(nreceiverlines) :: xdeb,zdeb,xfin,zfin
+ logical, dimension(nreceiverlines) :: enreg_surf_same_vertical
+
+ integer :: max_npoints_interface
+ double precision, dimension(max_npoints_interface) :: xinterface_top, &
+ zinterface_top,coefs_interface_top
+ integer :: npoints_interface_top
+
+ !local parameters
+ integer :: ireceiverlines,irec,irec_global_number,ios
+ integer :: nrec_total
+ double precision :: xrec,zrec
+ double precision, external :: value_spline
+
+ print *
+ print *,'writing the DATA/STATIONS_target file'
+ print *
+
+ ! total number of receivers in all the receiver lines
+ nrec_total = sum(nrec)
+
+ print *
+ print *,'There are ',nrec_total,' receivers'
+
+ print *
+ print *,'Position (x,z) of the ',nrec_total,' receivers'
+ print *
+
+ open(unit=15,file='DATA/STATIONS_target',status='unknown',iostat=ios)
+ if( ios /= 0 ) stop 'error saving STATIONS file'
+
+ irec_global_number = 0
+
+ ! loop on all the receiver lines
+ do ireceiverlines = 1,nreceiverlines
+
+ ! loop on all the receivers of this receiver line
+ do irec = 1,nrec(ireceiverlines)
+
+ ! compute global receiver number
+ irec_global_number = irec_global_number + 1
+
+ ! compute coordinates of the receiver
+ if(nrec(ireceiverlines) > 1) then
+ xrec = xdeb(ireceiverlines) + dble(irec-1)*(xfin(ireceiverlines) &
+ -xdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
+ zrec = zdeb(ireceiverlines) + dble(irec-1)*(zfin(ireceiverlines) &
+ -zdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
+ else
+ xrec = xdeb(ireceiverlines)
+ zrec = zdeb(ireceiverlines)
+ endif
+
+ ! modify position of receiver if we must record exactly at the surface
+ if(enreg_surf_same_vertical(ireceiverlines)) &
+ zrec = value_spline(xrec,xinterface_top,zinterface_top, &
+ coefs_interface_top,npoints_interface_top)
+
+ ! display position of the receiver
+ print *,'Receiver ',irec_global_number,' = ',xrec,zrec
+
+ write(15,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") irec_global_number,xrec,zrec
+
+ enddo
+ enddo
+
+ close(15)
+
+ end subroutine save_stations_file
+
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D/spline_routines.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/spline_routines.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D/spline_routines.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D/spline_routines.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,174 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! compute spline coefficients
+
+ subroutine spline_construction(xpoint,ypoint,npoint,tangent_first_point,tangent_last_point,spline_coefficients)
+
+ implicit none
+
+! tangent to the spline imposed at the first and last points
+ double precision, intent(in) :: tangent_first_point,tangent_last_point
+
+! number of input points and coordinates of the input points
+ integer, intent(in) :: npoint
+ double precision, dimension(npoint), intent(in) :: xpoint,ypoint
+
+! spline coefficients output by the routine
+ double precision, dimension(npoint), intent(out) :: spline_coefficients
+
+ integer :: i
+
+ double precision, dimension(:), allocatable :: temporary_array
+
+ allocate(temporary_array(npoint))
+
+ spline_coefficients(1) = - 1.d0 / 2.d0
+
+ temporary_array(1) = (3.d0/(xpoint(2)-xpoint(1)))*((ypoint(2)-ypoint(1))/(xpoint(2)-xpoint(1))-tangent_first_point)
+
+ do i = 2,npoint-1
+
+ spline_coefficients(i) = ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))-1.d0) &
+ / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
+
+ temporary_array(i) = (6.d0*((ypoint(i+1)-ypoint(i))/(xpoint(i+1)-xpoint(i)) &
+ - (ypoint(i)-ypoint(i-1))/(xpoint(i)-xpoint(i-1)))/(xpoint(i+1)-xpoint(i-1)) &
+ - (xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*temporary_array(i-1)) &
+ / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
+
+ enddo
+
+ spline_coefficients(npoint) = ((3.d0/(xpoint(npoint)-xpoint(npoint-1))) &
+ * (tangent_last_point-(ypoint(npoint)-ypoint(npoint-1))/(xpoint(npoint)-xpoint(npoint-1))) &
+ - 1.d0/2.d0*temporary_array(npoint-1))/(1.d0/2.d0*spline_coefficients(npoint-1)+1.d0)
+
+ do i = npoint-1,1,-1
+ spline_coefficients(i) = spline_coefficients(i)*spline_coefficients(i+1) + temporary_array(i)
+ enddo
+
+ deallocate(temporary_array)
+
+ end subroutine spline_construction
+
+!
+! ------------------------------------------------------------------------------------------------
+!
+
+! evaluate a spline
+
+ subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate_spline,y_spline_obtained)
+
+ implicit none
+
+! number of input points and coordinates of the input points
+ integer, intent(in) :: npoint
+ double precision, dimension(npoint), intent(in) :: xpoint,ypoint
+
+! spline coefficients to use
+ double precision, dimension(npoint), intent(in) :: spline_coefficients
+
+! abscissa at which we need to evaluate the value of the spline
+ double precision, intent(in):: x_evaluate_spline
+
+! ordinate evaluated by the routine for the spline at this abscissa
+ double precision, intent(out):: y_spline_obtained
+
+ integer :: index_loop,index_lower,index_higher
+
+ double precision :: coef1,coef2
+
+! initialize to the whole interval
+ index_lower = 1
+ index_higher = npoint
+
+! determine the right interval to use, by dichotomy
+ do while (index_higher - index_lower > 1)
+! compute the middle of the interval
+ index_loop = (index_higher + index_lower) / 2
+ if(xpoint(index_loop) > x_evaluate_spline) then
+ index_higher = index_loop
+ else
+ index_lower = index_loop
+ endif
+ enddo
+
+! test that the interval obtained does not have a size of zero
+! (this could happen for instance in the case of duplicates in the input list of points)
+ if(xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation'
+
+ coef1 = (xpoint(index_higher) - x_evaluate_spline) / (xpoint(index_higher) - xpoint(index_lower))
+ coef2 = (x_evaluate_spline - xpoint(index_lower)) / (xpoint(index_higher) - xpoint(index_lower))
+
+ y_spline_obtained = coef1*ypoint(index_lower) + coef2*ypoint(index_higher) + &
+ ((coef1**3 - coef1)*spline_coefficients(index_lower) + &
+ (coef2**3 - coef2)*spline_coefficients(index_higher))*((xpoint(index_higher) - xpoint(index_lower))**2)/6.d0
+
+ end subroutine spline_evaluation
+
+!
+! ------------------------------------------------------------------------------------------------
+!
+
+!--- spline to describe the interfaces
+
+double precision function value_spline(x,xinterface,zinterface,coefs_interface,npoints_interface)
+
+ implicit none
+
+ integer npoints_interface
+ double precision x,xp
+ double precision, dimension(npoints_interface) :: xinterface,zinterface,coefs_interface
+
+ value_spline = 0.d0
+
+ xp = x
+
+ ! assign the value on the edge if point is outside the model
+ if(xp < xinterface(1)) xp = xinterface(1)
+ if(xp > xinterface(npoints_interface)) xp = xinterface(npoints_interface)
+
+ call spline_evaluation(xinterface,zinterface,coefs_interface,npoints_interface,xp,value_spline)
+
+end function value_spline
Deleted: seismo/2D/SPECFEM2D/trunk/src/meshfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,942 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!========================================================================
-!
-! Basic mesh generator for SPECFEM2D
-!
-!========================================================================
-
-! If you use this code for your own research, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{VaCaSaKoVi99,
-! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
-! D. Komatitsch and J. P. Vilotte},
-! title = {Elastic wave propagation in an irregularly layered medium},
-! journal = {Soil Dynamics and Earthquake Engineering},
-! year = {1999},
-! volume = {18},
-! pages = {11-18},
-! number = {1},
-! doi = {10.1016/S0267-7261(98)00027-X}}
-!
-! @ARTICLE{LeChKoHuTr09,
-! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
-! Shouh Huang and Jeroen Tromp},
-! title = {Effects of realistic surface topography on seismic ground motion
-! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
-! method and {LiDAR DTM}},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {681-693},
-! number = {2A},
-! doi = {10.1785/0120080264}}
-!
-! @ARTICLE{LeChLiKoHuTr08,
-! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
-! and Bor Shouh Huang and Jeroen Tromp},
-! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
-! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2008},
-! volume = {98},
-! pages = {253-264},
-! number = {1},
-! doi = {10.1785/0120070033}}
-!
-! @ARTICLE{LeKoHuTr09,
-! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
-! title = {Effects of topography on seismic wave propagation: An example from
-! northern {T}aiwan},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {314-325},
-! number = {1},
-! doi = {10.1785/0120080020}}
-!
-! @ARTICLE{KoErGoMi10,
-! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
-! David Mich\'ea},
-! title = {High-order finite-element seismic wave propagation modeling with
-! {MPI} on a large {GPU} cluster},
-! journal = {J. Comput. Phys.},
-! year = {2010},
-! volume = {229},
-! pages = {7692-7714},
-! number = {20},
-! doi = {10.1016/j.jcp.2010.06.024}}
-!
-! @ARTICLE{KoGoErMi10,
-! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
-! David Mich\'ea},
-! title = {Modeling the propagation of elastic waves using spectral elements
-! on a cluster of 192 {GPU}s},
-! journal = {Computer Science Research and Development},
-! year = {2010},
-! volume = {25},
-! pages = {75-82},
-! number = {1-2},
-! doi = {10.1007/s00450-010-0109-1}}
-!
-! @ARTICLE{KoMiEr09,
-! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
-! title = {Porting a high-order finite-element earthquake modeling application
-! to {NVIDIA} graphics cards using {CUDA}},
-! journal = {Journal of Parallel and Distributed Computing},
-! year = {2009},
-! volume = {69},
-! pages = {451-460},
-! number = {5},
-! doi = {10.1016/j.jpdc.2009.01.006}}
-!
-! @ARTICLE{LiPoKoTr04,
-! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
-! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
-! journal={Bull. Seismol. Soc. Am.},
-! year = {2004},
-! volume = {94},
-! pages = {1748-1761},
-! number = {5},
-! doi = {10.1785/012004038}}
-!
-! @INCOLLECTION{ChKoViCaVaFe07,
-! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
-! Yann Capdeville and Bernard Valette and Gaetano Festa},
-! title = {Spectral Element Analysis in Seismology},
-! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
-! publisher = {Elsevier - Academic Press},
-! year = {2007},
-! editor = {Ru-Shan Wu and Val\'erie Maupin},
-! volume = {48},
-! series = {Advances in Geophysics},
-! pages = {365-419}}
-!
-! @ARTICLE{KoVi98,
-! author={D. Komatitsch and J. P. Vilotte},
-! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
-! journal={Bull. Seismol. Soc. Am.},
-! year=1998,
-! volume=88,
-! number=2,
-! pages={368-392}}
-!
-! @ARTICLE{KoTr99,
-! author={D. Komatitsch and J. Tromp},
-! year=1999,
-! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
-! journal={Geophys. J. Int.},
-! volume=139,
-! number=3,
-! pages={806-822},
-! doi={10.1046/j.1365-246x.1999.00967.x}}
-!
-! @ARTICLE{KoLiTrSuStSh04,
-! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
-! and Christiane Stidham and John H. Shaw},
-! year=2004,
-! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
-! based upon the Spectral-Element Method},
-! journal={Bull. Seism. Soc. Am.},
-! volume=94,
-! number=1,
-! pages={187-206}}
-!
-! @ARTICLE{MoTr08,
-! author={C. Morency and J. Tromp},
-! title={Spectral-element simulations of wave propagation in poroelastic media},
-! journal={Geophys. J. Int.},
-! year=2008,
-! volume=175,
-! pages={301-345}}
-!
-! and/or other articles from http://web.univ-pau.fr/~dkomati1/publications.html
-!
-! If you use the kernel capabilities of the code, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{LiTr06,
-! author={Qinya Liu and Jeroen Tromp},
-! title={Finite-frequency kernels based on adjoint methods},
-! journal={Bull. Seismol. Soc. Am.},
-! year=2006,
-! volume=96,
-! number=6,
-! pages={2383-2397},
-! doi={10.1785/0120060041}}
-!
-! @ARTICLE{MoLuTr09,
-! author={C. Morency and Y. Luo and J. Tromp},
-! title={Finite-frequency kernels for wave propagation in porous media based upon adjoint methods},
-! year=2009,
-! journal={Geophys. J. Int.},
-! doi={10.1111/j.1365-246X.2009.04332}}
-!
-! If you use the METIS / SCOTCH / CUBIT non-structured capabilities, please also cite:
-!
-! @ARTICLE{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},
-! journal = {Lecture Notes in Computer Science},
-! year = {2008},
-! volume = {5336},
-! pages = {350-363}}
-!
-! version 6.1, Christina Morency and Pieyre Le Loher, March 2010:
-! - added SH (membrane) waves calculation for elastic media
-! - added support for external fully anisotropic media
-! - fixed some bugs in acoustic kernels
-!
-! version 6.0, Christina Morency and Yang Luo, August 2009:
-! - support for poroelastic media
-! - adjoint method for acoustic/elastic/poroelastic
-!
-! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, February 2008:
-! - support for CUBIT and GiD meshes
-! - 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)
-! - merged loops in the solver for efficiency
-! - simplified input of external model
-! - added CPU time information
-! - translated many comments from French to English
-!
-! version 5.1, Dimitri Komatitsch, January 2005:
-! - more general mesher with any number of curved layers
-! - Dirac and Gaussian time sources and corresponding convolution routine
-! - option for acoustic medium instead of elastic
-! - receivers at any location, not only grid points
-! - moment-tensor source at any location, not only a grid point
-! - color snapshots
-! - more flexible DATA/Par_file with any number of comment lines
-! - Xsu scripts for seismograms
-! - subtract t0 from seismograms
-! - seismograms and snapshots in pressure in addition to vector field
-!
-! version 5.0, Dimitri Komatitsch, May 2004:
-! - got rid of useless routines, suppressed commons etc.
-! - weak formulation based explicitly on stress tensor
-! - implementation of full anisotropy
-! - implementation of attenuation based on memory variables
-!
-! based on SPECFEM2D version 4.2, June 1998
-! (c) by Dimitri Komatitsch, Harvard University, USA
-! and Jean-Pierre Vilotte, Institut de Physique du Globe de Paris, France
-!
-! itself based on SPECFEM2D version 1.0, 1995
-! (c) by Dimitri Komatitsch and Jean-Pierre Vilotte,
-! Institut de Physique du Globe de Paris, France
-!
-
-! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
-! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
-! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
-! This permits acoustic-elastic coupling based on a non-iterative time scheme.
-! Displacement is then: u = grad(Chi) / rho
-! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
-! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
-! The source in an acoustic element is a pressure source.
-! First-order acoustic-acoustic discontinuities are also handled automatically
-! because pressure is continuous at such an interface, therefore Chi_dot_dot
-! is continuous, therefore Chi is also continuous, which is consistent with
-! the spectral-element basis functions and with the assembling process.
-! This is the reason why a simple displacement potential u = grad(Chi) would
-! not work because it would be discontinuous at such an interface and would
-! therefore not be consistent with the basis functions.
-
-program meshfem2D
-
- use part_unstruct
- use parameter_file
- use source_file
- use interfaces_file
- implicit none
-
- include "constants.h"
-
- ! coordinates of the grid points of the mesh
- double precision, dimension(:,:), allocatable :: x,z
-
- ! to compute the coordinate transformation
- integer :: ioffset
- double precision :: gamma,absx,a00,a01,bot0,top0
-
- ! to store density and velocity model
- integer, dimension(:), allocatable :: num_material
-
- ! interface data
- integer :: max_npoints_interface,number_of_interfaces,npoints_interface_bottom, &
- npoints_interface_top
- integer :: number_of_layers
- integer :: nz,nxread,nzread
-
- integer :: ilayer,ipoint_current
- integer, dimension(:), pointer :: nz_layer
- double precision, dimension(:), allocatable :: &
- xinterface_bottom,zinterface_bottom,coefs_interface_bottom, &
- xinterface_top,zinterface_top,coefs_interface_top
-
- integer :: nspec
- integer :: nbregion
-
- ! external functions
- integer, external :: num_4, num_9
- double precision, external :: value_spline
-
- ! variables used for storing info about the mesh and partitions
- integer, dimension(:), allocatable :: my_interfaces
- integer, dimension(:), allocatable :: my_nb_interfaces
-
- integer :: num_start
- integer :: num_node
-
- ! variables used for tangential detection
- integer :: nnodes_tangential_curve
- double precision, dimension(:,:), allocatable :: nodes_tangential_curve
-
-#ifdef USE_SCOTCH
- integer :: edgecut
-#endif
-
- integer :: iproc
- integer :: ix,iz,i,j
- integer :: imaterial_number,inumelem
- integer :: i_source,ios
- double precision :: tang1,tangN
-
- ! ***
- ! *** read the parameter file
- ! ***
-
- print *,'Reading the parameter file ... '
- print *
-
- open(unit=IIN,file='DATA/Par_file',status='old',iostat=ios)
- if( ios /= 0 ) stop 'error opening DATA/Par_file file'
-
- ! reads in parameters in DATA/Par_file
- call read_parameter_file()
-
- ! reads in mesh elements
- if ( read_external_mesh ) then
- call read_external_mesh_file(mesh_file, num_start, ngnod)
-
- else
- call read_interfaces_file(interfacesfile,max_npoints_interface, &
- number_of_interfaces,npoints_interface_bottom, &
- number_of_layers,nz_layer,nx,nz,nxread,nzread,ngnod, &
- nelmnts,elmnts)
- endif
-
- allocate(num_material(nelmnts))
- num_material(:) = 0
-
- ! assigns materials to mesh elements
- if ( read_external_mesh ) then
- call read_mat(materials_file, num_material)
- else
- call read_regions(nbregion,nb_materials,icodemat,cp,cs, &
- rho_s,Qp,Qs,aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
- nelmnts,num_material,nxread,nzread)
- endif
-
- close(IIN)
-
- print *
- print *,'Parameter file successfully read... '
-
- ! reads in source descriptions
- call read_source_file(NSOURCES)
-
- ! reads in 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 = 1 ! dummy values instead of 0
- allocate(nodes_tangential_curve(2,1))
- endif
-
-
- !---
-
- if(ngnod /= 4 .and. ngnod /= 9) stop 'ngnod different from 4 or 9!'
-
- print *
- print *,'The mesh contains ',nelmnts,' elements'
- print *
- print *,'Control elements have ',ngnod,' nodes'
- print *
-
- !---
-
- if ( .not. read_external_mesh ) then
- ! allocate arrays for the grid
- allocate(x(0:nx,0:nz))
- allocate(z(0:nx,0:nz))
-
- x(:,:) = 0.d0
- z(:,:) = 0.d0
-
- ! get interface data from external file
- print *,'Reading interface data from file DATA/',interfacesfile(1:len_trim(interfacesfile))
- open(unit=IIN_INTERFACES,file='DATA/'//interfacesfile,status='old')
-
- allocate(xinterface_bottom(max_npoints_interface))
- allocate(zinterface_bottom(max_npoints_interface))
- allocate(coefs_interface_bottom(max_npoints_interface))
-
- allocate(xinterface_top(max_npoints_interface))
- allocate(zinterface_top(max_npoints_interface))
- allocate(coefs_interface_top(max_npoints_interface))
-
- ! read number of interfaces
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,number_of_interfaces)
-
- ! read bottom interface
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_bottom)
-
- ! loop on all the points describing this interface
- do ipoint_current = 1,npoints_interface_bottom
- call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
- xinterface_bottom(ipoint_current),zinterface_bottom(ipoint_current))
- enddo
-
- ! loop on all the layers
- do ilayer = 1,number_of_layers
-
- ! read top interface
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_top)
-
- ! loop on all the points describing this interface
- do ipoint_current = 1,npoints_interface_top
- call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
- xinterface_top(ipoint_current),zinterface_top(ipoint_current))
- enddo
-
- ! compute the spline for the bottom interface, impose the tangent on both edges
- tang1 = (zinterface_bottom(2)-zinterface_bottom(1)) / (xinterface_bottom(2)-xinterface_bottom(1))
- tangN = (zinterface_bottom(npoints_interface_bottom)-zinterface_bottom(npoints_interface_bottom-1)) / &
- (xinterface_bottom(npoints_interface_bottom)-xinterface_bottom(npoints_interface_bottom-1))
- call spline_construction(xinterface_bottom,zinterface_bottom,npoints_interface_bottom,tang1,tangN,coefs_interface_bottom)
-
- ! compute the spline for the top interface, impose the tangent on both edges
- tang1 = (zinterface_top(2)-zinterface_top(1)) / (xinterface_top(2)-xinterface_top(1))
- tangN = (zinterface_top(npoints_interface_top)-zinterface_top(npoints_interface_top-1)) / &
- (xinterface_top(npoints_interface_top)-xinterface_top(npoints_interface_top-1))
- call spline_construction(xinterface_top,zinterface_top,npoints_interface_top,tang1,tangN,coefs_interface_top)
-
- ! 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
- do i_source=1,NSOURCES
- 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
- ioffset = sum(nz_layer(1:ilayer-1))
- else
- ioffset = 0
- endif
-
- !--- definition of the mesh
-
- do ix = 0,nx
-
- ! evenly spaced points along X
- absx = xmin + (xmax - xmin) * dble(ix) / dble(nx)
-
- ! value of the bottom and top splines
- bot0 = value_spline(absx,xinterface_bottom,zinterface_bottom,coefs_interface_bottom,npoints_interface_bottom)
- top0 = value_spline(absx,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
-
- do iz = 0,nz_layer(ilayer)
-
- ! linear interpolation between bottom and top
- gamma = dble(iz) / dble(nz_layer(ilayer))
- a00 = 1.d0 - gamma
- a01 = gamma
-
- ! coordinates of the grid points
- x(ix,iz + ioffset) = absx
- z(ix,iz + ioffset) = a00*bot0 + a01*top0
-
- enddo
-
- enddo
-
- ! the top interface becomes the bottom interface before switching to the next layer
- npoints_interface_bottom = npoints_interface_top
- xinterface_bottom(:) = xinterface_top(:)
- zinterface_bottom(:) = zinterface_top(:)
-
- enddo
-
- close(IIN_INTERFACES)
-
- nnodes = (nz+1)*(nx+1)
- allocate(nodes_coords(2,nnodes))
- if ( ngnod == 4 ) then
- do j = 0, nz
- do i = 0, nx
- num_node = num_4(i,j,nxread)
- nodes_coords(1, num_node) = x(i,j)
- nodes_coords(2, num_node) = z(i,j)
-
- enddo
- enddo
-
- else
- do j = 0, nz
- do i = 0, nx
- num_node = num_9(i,j,nxread,nzread)
- nodes_coords(1, num_node) = x(i,j)
- nodes_coords(2, num_node) = z(i,j)
- enddo
- enddo
-
- endif
- else
- call read_nodes_coords(nodes_coords_file)
- endif
-
-
- if ( read_external_mesh ) then
- call read_acoustic_surface(free_surface_file, num_material, &
- ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
-
- if ( any_abs ) then
- call read_abs_surface(absorbing_surface_file, num_start)
- endif
-
- else
-
- ! count the number of acoustic free-surface elements
- nelem_acoustic_surface = 0
-
- ! if the surface is absorbing, it cannot be free at the same time
- if(.not. abstop) then
- 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
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- endif
- enddo
- endif
- if(.not. absbottom) then
- j = 1
- 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
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- endif
- enddo
- endif
- if(.not. absleft) then
- i = 1
- do j = 1,nzread
- imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- endif
- enddo
- endif
- if(.not. absright) then
- i = nxread
- do j = 1,nzread
- imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- endif
- enddo
- endif
-
-
- allocate(acoustic_surface(4,nelem_acoustic_surface))
-
- nelem_acoustic_surface = 0
-
- if(.not. abstop) then
- 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
- 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
- enddo
- endif
- if(.not. absbottom) then
- j = 1
- 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
- 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(0+ngnod*((j-1)*nxread+i-1))
- acoustic_surface(4,nelem_acoustic_surface) = elmnts(1+ngnod*((j-1)*nxread+i-1))
- endif
- enddo
- endif
- if(.not. absleft) then
- i = 1
- do j = 1,nzread
- imaterial_number = num_material((j-1)*nxread+i)
- 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(0+ngnod*((j-1)*nxread+i-1))
- acoustic_surface(4,nelem_acoustic_surface) = elmnts(3+ngnod*((j-1)*nxread+i-1))
- endif
- enddo
- endif
- if(.not. absright) then
- i = nxread
- do j = 1,nzread
- imaterial_number = num_material((j-1)*nxread+i)
- 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(1+ngnod*((j-1)*nxread+i-1))
- acoustic_surface(4,nelem_acoustic_surface) = elmnts(2+ngnod*((j-1)*nxread+i-1))
- endif
- enddo
- endif
-
- !
- !--- definition of absorbing boundaries
- !
- nelemabs = 0
- if(absbottom) nelemabs = nelemabs + nxread
- if(abstop) nelemabs = nelemabs + nxread
- if(absleft) nelemabs = nelemabs + nzread
- if(absright) nelemabs = nelemabs + nzread
-
- allocate(abs_surface(4,nelemabs))
-
- ! generate the list of absorbing elements
- if(nelemabs > 0) then
- nelemabs = 0
- do iz = 1,nzread
- do ix = 1,nxread
- inumelem = (iz-1)*nxread + ix
- if(absbottom .and. iz == 1) then
- nelemabs = nelemabs + 1
- abs_surface(1,nelemabs) = inumelem-1
- abs_surface(2,nelemabs) = 2
- abs_surface(3,nelemabs) = elmnts(0+ngnod*(inumelem-1))
- abs_surface(4,nelemabs) = elmnts(1+ngnod*(inumelem-1))
- endif
- if(absright .and. ix == nxread) then
- nelemabs = nelemabs + 1
- abs_surface(1,nelemabs) = inumelem-1
- abs_surface(2,nelemabs) = 2
- abs_surface(3,nelemabs) = elmnts(1+ngnod*(inumelem-1))
- abs_surface(4,nelemabs) = elmnts(2+ngnod*(inumelem-1))
- endif
- if(abstop .and. iz == nzread) then
- nelemabs = nelemabs + 1
- abs_surface(1,nelemabs) = inumelem-1
- abs_surface(2,nelemabs) = 2
- abs_surface(3,nelemabs) = elmnts(3+ngnod*(inumelem-1))
- abs_surface(4,nelemabs) = elmnts(2+ngnod*(inumelem-1))
- endif
- if(absleft .and. ix == 1) then
- nelemabs = nelemabs + 1
- abs_surface(1,nelemabs) = inumelem-1
- abs_surface(2,nelemabs) = 2
- abs_surface(3,nelemabs) = elmnts(0+ngnod*(inumelem-1))
- abs_surface(4,nelemabs) = elmnts(3+ngnod*(inumelem-1))
- endif
- enddo
- enddo
- endif
-
- endif
-
-
- ! compute min and max of X and Z in the grid
- print *
- print *,'Min and max value of X in the grid = ',minval(nodes_coords(1,:)),maxval(nodes_coords(1,:))
- print *,'Min and max value of Z in the grid = ',minval(nodes_coords(2,:)),maxval(nodes_coords(2,:))
- print *
-
-
- ! ***
- ! *** create a Gnuplot file that displays the grid
- ! ***
- if ( .not. read_external_mesh ) then
- call save_gnuplot_file(ngnod,nx,nz,x,z)
- endif
-
-
- !*****************************
- ! partitioning
- !*****************************
-
- ! allocates & initializes partioning of elements
- allocate(part(0:nelmnts-1))
- part(:) = -1
-
- if( nproc > 1 ) then
- allocate(xadj_g(0:nelmnts))
- allocate(adjncy_g(0:MAX_NEIGHBORS*nelmnts-1))
- xadj_g(:) = 0
- adjncy_g(:) = -1
- endif
-
- ! construction of the graph
-
- ! if ngnod == 9, we work on a subarray of elements that represents the elements with four nodes (four corners) only
- ! because the adjacency of the mesh elements can be entirely determined from the knowledge of the four corners only
- if ( ngnod == 9 ) then
- allocate(elmnts_bis(0:NCORNERS*nelmnts-1))
- do i = 0, nelmnts-1
- elmnts_bis(i*NCORNERS:i*NCORNERS+NCORNERS-1) = elmnts(i*ngnod:i*ngnod+NCORNERS-1)
- enddo
-
- if ( nproc > 1 ) then
-
-!! DK DK fixed problem in the previous implementation by Nicolas Le Goff:
-!! DK DK (nxread+1)*(nzread+1) is OK for a regular internal mesh only, not for non structured external meshes
-!! DK DK call mesh2dual_ncommonnodes(nelmnts, (nxread+1)*(nzread+1), elmnts_bis, xadj, adjncy, nnodes_elmnts, nodes_elmnts,1)
-!! DK DK the subset of element corners is not renumbered therefore we must still use the nnodes computed for 9 nodes here
- ! determines maximum neighbors based on 1 common node
- call mesh2dual_ncommonnodes(elmnts_bis,1,xadj_g,adjncy_g)
- endif
-
- else
- if ( nproc > 1 ) then
- ! determines maximum neighbors based on 1 common node
- call mesh2dual_ncommonnodes(elmnts,1,xadj_g,adjncy_g)
- endif
-
- endif
-
-
- if ( nproc == 1 ) then
- part(:) = 0 ! single process has rank 0
- else
-
- ! number of common edges
- nb_edges = xadj_g(nelmnts)
-
- ! giving weight to edges and vertices. Currently not used.
- call read_weights()
-
- ! partitioning
- 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
- 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
-! print *, 'This version of SPECFEM was not compiled with support of METIS.'
-! print *, 'Please recompile with -DUSE_METIS in order to enable use of METIS.'
-! stop
-!#endif
- stop 'support for the METIS graph partitioner has been discontinued, please use SCOTCH (option 3) instead'
-
- case(3)
-
-#ifdef USE_SCOTCH
- call Part_scotch(nproc, edgecut)
-#else
- print *, 'This version of SPECFEM was not compiled with support of SCOTCH.'
- print *, 'Please recompile with -DUSE_SCOTCH in order to enable use of SCOTCH.'
- stop
-#endif
-
- end select
-
- endif
-
- ! beware of fluid solid edges : coupled elements are transfered to the same partition
- if ( ngnod == 9 ) then
- call acoustic_elastic_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
- else
- call acoustic_elastic_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
- endif
- ! beware of fluid porous edges : coupled elements are transfered to the same partition
- if ( ngnod == 9 ) then
- call acoustic_poro_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
- else
- call acoustic_poro_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
- endif
- ! beware of porous solid edges : coupled elements are transfered to the same partition
- if ( ngnod == 9 ) then
- call poro_elastic_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
- else
- call poro_elastic_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
- endif
-
- ! local number of each element for each partition
- call Construct_glob2loc_elmnts(nproc)
-
- if ( ngnod == 9 ) then
- if( allocated(nnodes_elmnts) ) deallocate(nnodes_elmnts)
- if( allocated(nodes_elmnts) ) deallocate(nodes_elmnts)
- allocate(nnodes_elmnts(0:nnodes-1))
- allocate(nodes_elmnts(0:nsize*nnodes-1))
- nnodes_elmnts(:) = 0
- nodes_elmnts(:) = 0
- do i = 0, ngnod*nelmnts-1
- nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
- nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
- enddo
- else
- if ( nproc < 2 ) then
- if( .not. allocated(nnodes_elmnts) ) allocate(nnodes_elmnts(0:nnodes-1))
- if( .not. allocated(nodes_elmnts) ) allocate(nodes_elmnts(0:nsize*nnodes-1))
- nnodes_elmnts(:) = 0
- nodes_elmnts(:) = 0
- do i = 0, ngnod*nelmnts-1
- nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
- nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
- enddo
- endif
- endif
-
- ! local number of each node for each partition
- call Construct_glob2loc_nodes(nproc)
-
- ! construct the interfaces between partitions (used for MPI assembly)
- if ( nproc /= 1 ) then
- if ( ngnod == 9 ) then
- call Construct_interfaces(nproc, elmnts_bis, &
- nb_materials, phi, num_material)
- else
- call Construct_interfaces(nproc, elmnts, &
- nb_materials, phi, num_material)
- endif
- allocate(my_interfaces(0:ninterfaces-1))
- allocate(my_nb_interfaces(0:ninterfaces-1))
- endif
-
- ! setting absorbing boundaries by elements instead of edges
- if ( any_abs ) then
- call merge_abs_boundaries(nb_materials, phi, num_material, ngnod)
- endif
-
- ! *** generate the databases for the solver
- call save_databases(nspec,num_material, &
- my_interfaces,my_nb_interfaces, &
- nnodes_tangential_curve,nodes_tangential_curve)
-
- ! print position of the source
- do i_source=1,NSOURCES
- print *
- 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 (generate_STATIONS) then
- call save_stations_file(nreceiverlines,nrec,xdeb,zdeb,xfin,zfin,enreg_surf_same_vertical, &
- xinterface_top,zinterface_top,coefs_interface_top, &
- npoints_interface_top,max_npoints_interface)
- endif
-
- print *
- 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
Deleted: seismo/2D/SPECFEM2D/trunk/src/netlib_specfun_erf.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/netlib_specfun_erf.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/netlib_specfun_erf.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,318 +0,0 @@
-
- subroutine calerf(ARG,RESULT,JINT)
-
-!------------------------------------------------------------------
-!
-! This routine can be freely obtained from Netlib
-! at http://www.netlib.org/specfun/erf
-!
-! Most Netlib software packages have no restrictions on their use
-! but Netlib recommends that you check with the authors to be sure.
-! See http://www.netlib.org/misc/faq.html#2.3 for details.
-!
-!------------------------------------------------------------------
-!
-! This packet evaluates erf(x) for a real argument x.
-! It contains one FUNCTION type subprogram: ERF,
-! and one SUBROUTINE type subprogram, CALERF. The calling
-! statements for the primary entries are:
-!
-! Y = ERF(X)
-!
-! The routine CALERF is intended for internal packet use only,
-! all computations within the packet being concentrated in this
-! routine. The function subprograms invoke CALERF with the
-! statement
-!
-! call CALERF(ARG,RESULT,JINT)
-!
-! where the parameter usage is as follows
-!
-! Function Parameters for CALERF
-! call ARG Result JINT
-!
-! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0
-!
-! The main computation evaluates near-minimax approximations
-! from "Rational Chebyshev approximations for the error function"
-! by William J. Cody, Math. Comp., 1969, PP. 631-638. This
-! transportable program uses rational functions that theoretically
-! approximate erf(x) and erfc(x) to at least 18 significant
-! decimal digits. The accuracy achieved depends on the arithmetic
-! system, the compiler, the intrinsic functions, and proper
-! selection of the machine-dependent constants.
-!
-!*******************************************************************
-!*******************************************************************
-!
-! Explanation of machine-dependent constants
-!
-! XMIN = the smallest positive floating-point number.
-! XINF = the largest positive finite floating-point number.
-! XNEG = the largest negative argument acceptable to ERFCX;
-! the negative of the solution to the equation
-! 2*exp(x*x) = XINF.
-! XSMALL = argument below which erf(x) may be represented by
-! 2*x/sqrt(pi) and above which x*x will not underflow.
-! A conservative value is the largest machine number X
-! such that 1.0 + X = 1.0 to machine precision.
-! XBIG = largest argument acceptable to ERFC; solution to
-! the equation: W(x) * (1-0.5/x**2) = XMIN, where
-! W(x) = exp(-x*x)/[x*sqrt(pi)].
-! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to
-! machine precision. A conservative value is
-! 1/[2*sqrt(XSMALL)]
-! XMAX = largest acceptable argument to ERFCX; the minimum
-! of XINF and 1/[sqrt(pi)*XMIN].
-!
-! Approximate IEEE double precision values are defined below.
-!
-!*******************************************************************
-!*******************************************************************
-!
-! Error returns
-!
-! The program returns ERFC = 0 for ARG >= XBIG;
-!
-! Author: William J. Cody
-! Mathematics and Computer Science Division
-! Argonne National Laboratory
-! Argonne, IL 60439, USA
-!
-! Latest modification: March 19, 1990
-!
-! Converted to Fortran90 and slightly modified by
-! Dimitri Komatitsch, University of Pau, France, November 2007.
-!
-!------------------------------------------------------------------
-
- implicit none
-
- integer I,JINT
- double precision A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEEN,SQRPI, &
- TWO,THRESHOLD,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL, &
- Y,YSQ,ZERO
- dimension A(5),B(4),C(9),D(8),P(6),Q(5)
-
-!------------------------------------------------------------------
-! Mathematical constants
-!------------------------------------------------------------------
- data FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/, &
- SQRPI/5.6418958354775628695D-1/,THRESHOLD/0.46875D0/, &
- SIXTEEN/16.0D0/
-
-!------------------------------------------------------------------
-! Machine-dependent constants
-!------------------------------------------------------------------
- data XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/, &
- XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/
-
-!------------------------------------------------------------------
-! Coefficients for approximation to erf in first interval
-!------------------------------------------------------------------
- data A/3.16112374387056560D00,1.13864154151050156D02, &
- 3.77485237685302021D02,3.20937758913846947D03, &
- 1.85777706184603153D-1/
- data B/2.36012909523441209D01,2.44024637934444173D02, &
- 1.28261652607737228D03,2.84423683343917062D03/
-
-!------------------------------------------------------------------
-! Coefficients for approximation to erfc in second interval
-!------------------------------------------------------------------
- data C/5.64188496988670089D-1,8.88314979438837594D0, &
- 6.61191906371416295D01,2.98635138197400131D02, &
- 8.81952221241769090D02,1.71204761263407058D03, &
- 2.05107837782607147D03,1.23033935479799725D03, &
- 2.15311535474403846D-8/
- data D/1.57449261107098347D01,1.17693950891312499D02, &
- 5.37181101862009858D02,1.62138957456669019D03, &
- 3.29079923573345963D03,4.36261909014324716D03, &
- 3.43936767414372164D03,1.23033935480374942D03/
-
-!------------------------------------------------------------------
-! Coefficients for approximation to erfc in third interval
-!------------------------------------------------------------------
- data P/3.05326634961232344D-1,3.60344899949804439D-1, &
- 1.25781726111229246D-1,1.60837851487422766D-2, &
- 6.58749161529837803D-4,1.63153871373020978D-2/
- data Q/2.56852019228982242D00,1.87295284992346047D00, &
- 5.27905102951428412D-1,6.05183413124413191D-2, &
- 2.33520497626869185D-3/
-
- X = ARG
- Y = ABS(X)
- if (Y <= THRESHOLD) then
-
-!------------------------------------------------------------------
-! Evaluate erf for |X| <= 0.46875
-!------------------------------------------------------------------
- YSQ = ZERO
- if (Y > XSMALL) YSQ = Y * Y
- XNUM = A(5)*YSQ
- XDEN = YSQ
-
- do I = 1, 3
- XNUM = (XNUM + A(I)) * YSQ
- XDEN = (XDEN + B(I)) * YSQ
- enddo
-
- RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
- if (JINT /= 0) RESULT = ONE - RESULT
- if (JINT == 2) RESULT = EXP(YSQ) * RESULT
- goto 800
-
-!------------------------------------------------------------------
-! Evaluate erfc for 0.46875 <= |X| <= 4.0
-!------------------------------------------------------------------
- else if (Y <= FOUR) then
- XNUM = C(9)*Y
- XDEN = Y
-
- do I = 1, 7
- XNUM = (XNUM + C(I)) * Y
- XDEN = (XDEN + D(I)) * Y
- enddo
-
- RESULT = (XNUM + C(8)) / (XDEN + D(8))
- if (JINT /= 2) then
- YSQ = AINT(Y*SIXTEEN)/SIXTEEN
- DEL = (Y-YSQ)*(Y+YSQ)
- RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
- endif
-
-!------------------------------------------------------------------
-! Evaluate erfc for |X| > 4.0
-!------------------------------------------------------------------
- else
- RESULT = ZERO
- if (Y >= XBIG) then
- if (JINT /= 2 .OR. Y >= XMAX) goto 300
- if (Y >= XHUGE) then
- RESULT = SQRPI / Y
- goto 300
- endif
- endif
- YSQ = ONE / (Y * Y)
- XNUM = P(6)*YSQ
- XDEN = YSQ
-
- do I = 1, 4
- XNUM = (XNUM + P(I)) * YSQ
- XDEN = (XDEN + Q(I)) * YSQ
- enddo
-
- RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
- RESULT = (SQRPI - RESULT) / Y
- if (JINT /= 2) then
- YSQ = AINT(Y*SIXTEEN)/SIXTEEN
- DEL = (Y-YSQ)*(Y+YSQ)
- RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
- endif
- endif
-
-!------------------------------------------------------------------
-! Fix up for negative argument, erf, etc.
-!------------------------------------------------------------------
- 300 if (JINT == 0) then
- RESULT = (HALF - RESULT) + HALF
- if (X < ZERO) RESULT = -RESULT
- else if (JINT == 1) then
- if (X < ZERO) RESULT = TWO - RESULT
- else
- if (X < ZERO) then
- if (X < XNEG) then
- RESULT = XINF
- else
- YSQ = AINT(X*SIXTEEN)/SIXTEEN
- DEL = (X-YSQ)*(X+YSQ)
- Y = EXP(YSQ*YSQ) * EXP(DEL)
- RESULT = (Y+Y) - RESULT
- endif
- endif
- endif
-
- 800 return
-
- end subroutine calerf
-
-!--------------------------------------------------------------------
-
- double precision function netlib_specfun_erf(X)
-
-! This subprogram computes approximate values for erf(x).
-! (see comments heading CALERF).
-!
-! Author/date: William J. Cody, January 8, 1985
-
- implicit none
-
- integer JINT
- double precision X, RESULT
-
- JINT = 0
- call calerf(X,RESULT,JINT)
- netlib_specfun_erf = RESULT
-
- end function netlib_specfun_erf
-
-!
-! Subject: RE: Can one freely use and redistribute Fortran routines "specfun" from Netlib?
-! From: Jack Dongarra
-! Date: Wed, 21 Nov 2007 10:33:45 -0500
-! To: Rusty Lusk, Dimitri Komatitsch
-!
-! Yes the code can freely be used and incorporated into other software. You
-! should of course acknowledge the use of the software.
-!
-! Hope this helps,
-!
-! Jack Dongarra
-!
-! **********************************************************************
-! Prof. Jack Dongarra; Innovative Computing Laboratory; EECS Department;
-! 1122 Volunteer Blvd; University of Tennessee; Knoxville TN 37996-3450;
-! +1-865-974-8295; http://www.cs.utk.edu/~dongarra/
-!
-! -----Original Message-----
-! From: Rusty Lusk
-! Sent: Wednesday, November 21, 2007 10:29 AM
-! To: Dimitri Komatitsch
-! Cc: Jack Dongarra
-! Subject: Re: Can one freely use and redistribute Fortran routines "specfun"
-! from Netlib?
-!
-! Netlib is managed at the University of Tennesee, not Argonne at this
-! point. I have copied Jack Dongarra on this reply; he should be able
-! to answer questions about licensing issues for code from Netlib.
-!
-! Regards,
-! Rusty
-!
-! On Nov 21, 2007, at 8:36 AM, Dimitri Komatitsch wrote:
-!
-! >
-! > Dear Sir,
-! >
-! > Can one freely use and redistribute Fortran routines "specfun" from
-! > Netlib http://netlib2.cs.utk.edu/specfun/
-! > which were written back in 1985-1990 by William J. Cody
-! > from the Mathematics and Computer Science Division at Argonne?
-! >
-! > We use one of these routines (the error function, erf())
-! > in one of our source codes, which we would like to
-! > release as open source under GPL v2+, and we therefore
-! > wonder if we could include that erf() routine in the
-! > package in a separate file (of course saying in a comment in the
-! > header that it comes from Netlib and was written by William J. Cody from
-! > Argonne).
-! >
-! > Thank you,
-! > Best regards,
-! >
-! > Dimitri Komatitsch.
-! >
-! > --
-! > Dimitri Komatitsch - dimitri.komatitsch aT univ-pau.fr
-! > Professor, University of Pau, Institut universitaire de France
-! > and INRIA Magique3D, France http://www.univ-pau.fr/~dkomati1
-! >
Deleted: seismo/2D/SPECFEM2D/trunk/src/paco_beyond_critical.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/paco_beyond_critical.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/paco_beyond_critical.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,605 +0,0 @@
-!
-! This subroutine was written by Paco Sanchez-Sesma and his colleagues
-! from the Autonomous University of Mexico (UNAM), Mexico City, Mexico
-!
-! original name : DISTRAFF.f
-!
-! CALCULO DE DESPLAZAMIENTOS (UX, UZ) y TRACCIONES (TX, TZ) DE CAMPO LIBRE
-! EN UN SEMIESPACIO ELASTICO Y EN LA VECINDAD DE LA SUPERFICIE
-!
-! INCIDENCIA DE ONDAS P, SV Y DE RAYLEIGH
-!
-! 7 de febrero de 2007
-!
-! modified by Dimitri Komatitsch and Ronan Madec in March 2008
-! in particular, converted to Fortran90 and to double precision
-
-subroutine paco_beyond_critical(coord,npoin,deltat,NSTEP_global,angleforce,&
- f0,cp_local,cs_local,INCLUDE_ATTENUATION,QD,source_type,v0x_left,v0z_left,v0x_right,v0z_right,&
- v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot,left_bound,right_bound,&
- bot_bound,nleft,nright,nbot,displ_elastic,veloc_elastic,accel_elastic)
-
- implicit none
-
- include "constants.h"
-
- double precision :: f0,cp_local,cs_local,deltat,dt,TP,angleforce,QD,delta_in_period
- logical :: INCLUDE_ATTENUATION
- integer :: npt,NSTEP_global,source_type,nleft,nright,nbot,npoin
-
- integer, dimension(nleft) :: left_bound
- integer, dimension(nright) :: right_bound
- integer, dimension(nbot) :: bot_bound
-
- double precision, dimension(nleft,NSTEP_global) :: v0x_left,v0z_left, t0x_left,t0z_left
- double precision, dimension(nright,NSTEP_global) :: v0x_right,v0z_right, t0x_right,t0z_right
- double precision, dimension(nbot,NSTEP_global) :: v0x_bot,v0z_bot, t0x_bot,t0z_bot
-
- double precision, dimension(2,npoin) :: coord
- double precision, dimension(2,npoin) :: displ_elastic
- double precision, dimension(2,npoin) :: veloc_elastic
- double precision, dimension(2,npoin) :: accel_elastic
-
- integer, dimension(:),allocatable :: local_pt
-
- double precision, dimension(:), allocatable :: temp_field
-
- integer :: J, indice, NSTEP_local, FLAG, N, NFREC, NFREC1
-
- double precision :: ANU,BEALF,ALFBE,RLM,VNX,VNZ,A1,B1,TOTO,FJ,AKA,AQA,GAMR
-
-! location of the point
- double precision :: X, Z, xmin, xmax, zmin, zmax
- integer :: inode
-
- complex(selected_real_kind(15,300)) :: CAKA,CAQA,UI,UR
- complex(selected_real_kind(15,300)) :: UX,UZ,SX,SZ,SXZ,A2,B2,AL,AK,AM
-
- complex(selected_real_kind(15,300)) :: TX,TZ
-
- complex(selected_real_kind(15,300)), dimension(:),allocatable::Field_Ux,Field_Uz,Field_Tx,Field_Tz
-
- double precision :: TS
-
-! to move the place where the wave reflects on free surface (offset too)
- double precision :: offset
-
-! size of the model
- xmin=minval(coord(1,:))
- xmax=maxval(coord(1,:))
- zmin=minval(coord(2,:))
- zmax=maxval(coord(2,:))
-
-! offset of the origin of time of the Ricker (equivalent to t0 in SPECFEM2D)
- offset=4.d0*(xmax-xmin)/5.d0
- TS=2.d0/f0
-
-! dominant period of the Ricker (equivalent to 1/f0 in SPECFEM2D)
- TP=1.d0/f0
-
-! find optimal period
-! if period is too small, you should see several initial plane wave on your initial field
- delta_in_period=2.d0
- do while(delta_in_period<1.5*abs(xmax-xmin)/cs_local)
- delta_in_period=2.d0*delta_in_period
- end do
-
-! test Deltat compatibility
- DT=256.d0
- do while(DT>deltat)
- DT=DT/2.d0
- end do
- if (abs(DT-deltat)>1.0d-13) then
- print *, "you must take a deltat as a power of two (power can be negative)"
- print *, "for example you can take", DT
- stop "can't go further, restart with new deltat"
- end if
-
- DT=deltat/2.d0
-
- N=2
- do while(N<2*NSTEP_global+1)
- N=2.d0*N
- end do
-
- do while(DT<(delta_in_period/N))
- N=2.d0*N
- end do
-
- print *, 'N found to do frequency calcul :', N
- print *,'number of discrete frequencies = ',N/2
- print *,'delta in period (seconds) = ',delta_in_period
- print *,'delta in frequency (Hz) = ',1.d0/delta_in_period
- print *,'dt (here we need deltat/2) = ', DT
-
- NFREC=N/2
- NFREC1=NFREC+1
-
-
-!
-! FDT: FUNCION DE TRASFERENCIA
-!
-
-! calculation of Poisson's ratio
- ANU = (cp_local*cp_local-2.d0*cs_local*cs_local)/(2.d0*(cp_local*cp_local-cs_local*cs_local))
- print *,"Poisson's ratio = ",ANU
-
- UI=(0.0d0, 1.0d0)
- UR=(1.0d0, 0.0d0)
-
-! convert angle to radians
- GAMR = angleforce
-
- BEALF=SQRT((1.0d0-2.0d0*ANU)/(2.0d0*(1.0d0-ANU)))
- ALFBE=1.0d0/BEALF
- RLM=ALFBE**2-2.0d0
-
-! flags: interior=0, left=1, right=2, bottom=3
- do FLAG=0,3
-
- if (FLAG==0) then
- print *, "calcul of the initial field for every point of the mesh"
- npt=npoin
- allocate(local_pt(npt))
- do inode=1,npt
- local_pt(inode)=inode
- end do
- NSTEP_local=1
- else if(FLAG==1) then
- print *, "calcul of every time step on the left absorbing boundary"
- npt=nleft
- allocate(local_pt(npt))
- local_pt=left_bound
- NSTEP_local=NSTEP_global
- else if(FLAG==2) then
- print *, "calcul of every time step on the right absorbing boundary"
- npt=nright
- allocate(local_pt(npt))
- local_pt=right_bound
- NSTEP_local=NSTEP_global
- else if(FLAG==3) then
- print *, "calcul of every time step on the bottom absorbing boundary"
- npt=nbot
- allocate(local_pt(npt))
- local_pt=bot_bound
- NSTEP_local=NSTEP_global
- end if
-
-! to distinguish all model case and boundary case
- allocate(temp_field(NSTEP_local))
-
- allocate(Field_Ux(NFREC1))
- allocate(Field_Uz(NFREC1))
- allocate(Field_Tx(NFREC1))
- allocate(Field_Tz(NFREC1))
-
-
- if(mod(N,2) /= 0) stop 'N must be a multiple of 2'
-
-! normal vector to the edge at this grid point
-! therefore corners between two grid edges must be computed twice
-! because the normal will change
- if (FLAG==1) then
- VNZ = 0.d0
- VNX = 1.d0
- else if (FLAG==2) then
- VNZ = 0.d0
- VNX = 1.d0
- else if (FLAG==3) then
- VNZ = 1.d0
- VNX = 0.d0
- else
- VNZ = 0.d0
- VNX = 0.d0
- end if
-
-
- do indice=1,npt
-
- if (FLAG==0) then
- inode=indice
- X=coord(1,indice)-offset
-! specfem coordinate axes are implemented from bottom to top whereas for this code
-! we need from top to bottom
- Z=zmax-coord(2,indice)
- else
- inode=local_pt(indice)
- X=coord(1,inode)-offset
-! specfem coordinate axes are implemented from bottom to top whereas for this code
-! we need from top to bottom
- Z=zmax-coord(2,inode)
- end if
-
- if (mod(indice,500)==0) then
- print *, indice, "points have been treated on ",npt," total points"
- end if
-
-!
-! first handle the particular case of zero frequency
-!
- TOTO=0.01d0
- IF (source_type==1) CALL ONDASP(GAMR,0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
- IF (source_type==2) CALL ONDASS(GAMR,TOTO,0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
- IF (source_type==3) CALL ONDASR(0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
-
-
- TOTO=0.0d0
- CALL DESFXY(TOTO,TOTO,source_type,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
-
-! write the frequency seismograms
- TX = SX *VNX+SXZ*VNZ
- TZ = SXZ*VNX+SZ *VNZ
-
- Field_Ux(1)=UX
- Field_Uz(1)=UZ
- if (FLAG/=0) then
- Field_Tx(1)=TX
- Field_Tz(1)=TZ
- end if
-
-!
-! then loop on all the other discrete frequencies
-!
- do J=1,N/2
-
-! compute the value of the frequency (= index * delta in frequency = index * 1/delta in period)
- FJ = dble(J) * 1.d0 / delta_in_period
-
-! pulsation (= 2 * PI * frequency)
- AKA=2.0d0*PI*FJ
-
- AQA=AKA*BEALF
-
-! exclude attenuation completely if needed
- if(INCLUDE_ATTENUATION) then
- CAKA=CMPLX(AKA,-AKA/(2.0d0*QD))
- CAQA=CMPLX(AQA,-AQA/(2.0d0*QD))
- else
- CAKA=CMPLX(AKA,0)
- CAQA=CMPLX(AQA,0)
- endif
-
- IF (source_type==1) CALL ONDASP(GAMR,AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
- IF (source_type==2) CALL ONDASS(GAMR,AKA,AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
- IF (source_type==3) CALL ONDASR(AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
-
- CALL DESFXY(X,Z,source_type,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
-
-! write the frequency seismograms
- TX = SX *VNX+SXZ*VNZ
- TZ = SXZ*VNX+SZ *VNZ
-
- Field_Ux(J+1)=UX
- Field_Uz(J+1)=UZ
- if (FLAG/=0) then
- Field_Tx(J+1)=TX
- Field_Tz(J+1)=TZ
- end if
-
- enddo
-
-! to convert frequency field in time field
-! (number at the end are unit numbers for writing in the good file,
-! in the case of the traction we fill only one file per call)
-
-! global model case for initial field
- if (FLAG==0) then
- call paco_convolve_fft(Field_Ux,1,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- displ_elastic(1,indice)=temp_field(1)
- call paco_convolve_fft(Field_Uz,1,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- displ_elastic(2,indice)=temp_field(1)
- call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- veloc_elastic(1,indice)=temp_field(1)
- call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- veloc_elastic(2,indice)=temp_field(1)
- call paco_convolve_fft(Field_Ux,3,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- accel_elastic(1,indice)=temp_field(1)
- call paco_convolve_fft(Field_Uz,3,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- accel_elastic(2,indice)=temp_field(1)
-
-! absorbing boundaries
-
-! left case
- else if (FLAG==1) then
- call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0x_left(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0z_left(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0x_left(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0z_left(indice,:)=temp_field(:)
-
-! right case
- else if (FLAG==2) then
- call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0x_right(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0z_right(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0x_right(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0z_right(indice,:)=temp_field(:)
-
-! bottom case
- else if (FLAG==3) then
- call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0x_bot(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0z_bot(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0x_bot(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0z_bot(indice,:)=temp_field(:)
- end if
- enddo
-
- deallocate(temp_field)
- deallocate(local_pt)
-
- deallocate(Field_Ux)
- deallocate(Field_Uz)
- deallocate(Field_Tx)
- deallocate(Field_Tz)
-
- end do
-
-end subroutine paco_beyond_critical
-
-!---
-
-SUBROUTINE DESFXY(X,Z,ICAS,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
-
- implicit none
-
- double precision A1,B1,RLM,X,Z
- integer ICAS
- complex(selected_real_kind(15,300)) :: UX,UZ,SX,SZ,SXZ,A2,B2,AL,AK,AM
- complex(selected_real_kind(15,300)) :: UI,FAC
- complex(selected_real_kind(15,300)) :: AUX1,AUX2,FI1,FI2,PS1,PS2
-
- UI=(0.0d0,1.0d0)
- if (A1/=0.0d0) then
- AUX1=A1*EXP(UI*(AM*Z-AL*X)) ! campo P incidente
- else
- AUX1=CMPLX(0.0d0)
- end if
- if (A2/=0.0d0) then
- AUX2=A2*EXP(-UI*(AM*Z+AL*X)) *1.0d0 ! campo P reflejado
- else
- AUX2=CMPLX(0.0d0)
- end if
- FI1=AUX1+AUX2
- FI2=AUX1-AUX2
- if (B1/=0.0d0) then
- AUX1=B1*EXP(UI*(AK*Z-AL*X)) ! campo S incidente
- else
- AUX1=CMPLX(0.0d0)
- end if
- if (B2/=0.0d0) then
- AUX2=B2*EXP(-UI*(AK*Z+AL*X)) *1.0d0 ! campo S reflejado
- else
- AUX2=CMPLX(0.0d0)
- end if
- PS1=AUX1+AUX2
- PS2=AUX1-AUX2
-
-!
-! FAC ES PARA TENER CONSISTENCIA CON AKI & RICHARDS (1980)
-!
- FAC=UI
- IF (ICAS==2)FAC=-UI
-
- UX=(-UI*AL*FI1+UI*AK*PS2)*FAC
-
- UZ=(UI*AM*FI2+UI*AL*PS1)*FAC
-! Paco's convention for vertical coordinate axis is inverted
- UZ = - UZ
-
- AUX1=AL*AL+AM*AM
- SX=(-RLM*AUX1*FI1-2.0d0*AL*(AL*FI1-AK*PS2))*FAC
- SZ=(-RLM*AUX1*FI1-2.0d0*(AM*AM*FI1+AK*AL*PS2))*FAC
-
- SXZ=(2.0d0*AM*AL*FI2+(AL*AL-AK*AK)*PS1)*FAC
-! Paco's convention for vertical coordinate axis is inverted
- SXZ = - SXZ
-
-END SUBROUTINE DESFXY
-
-SUBROUTINE FAFB(CA,CB,FA,FB)
-
- implicit none
-
- double precision CA,CB,A,B
- complex(selected_real_kind(15,300)) :: FA,FB,ZER,UI
-
- ZER=(0.0d0,0.0d0)
- UI=(0.0d0,1.0d0)
- A=CA*CA-1.0d0
- B=CB*CB-1.0d0
-
- IF (CA<1.0d0) then
- FA=-UI*SQRT(-A)
- else
- FA=SQRT(A)+ZER
- end IF
-
- IF (CB<1.0d0) then
- FB=-UI*SQRT(-B)
- else
- FB=CMPLX(SQRT(B),0.0d0)
- end IF
-
-END SUBROUTINE FAFB
-
-SUBROUTINE A2B2(FA,FB,A2,B2)
-
- implicit none
-
- complex(selected_real_kind(15,300)) :: FA,FB,A2,B2,DEN,AUX
-
- AUX=FB*FB-1.0d0
- DEN=4.0d0*FA*FB+AUX*AUX
- A2=(4.0d0*FA*FB-AUX*AUX)/DEN
- B2=4.0d0*FA*AUX/DEN
-
-END SUBROUTINE A2B2
-
-! calculation of P waves
-SUBROUTINE ONDASP(GP,AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
-
- implicit none
-
- double precision A1,B1,ANU,CA,CB,GP,AQB,BEALF
- complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
-
- ZER=(0.0d0,0.0d0)
- BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
- A1=1.0d0/AQB
- B1=0.0d0
-
- IF (GP==0.0d0) then
- AL=ZER
- AK=ZER
- AM=AQB+ZER
- A2=(-1.0d0+ZER)/AQB
- B2=ZER
- RETURN
- end IF
-
- CA=1.0d0/SIN(GP)
- CB=CA/BEALF
- AL=AQB/CA+ZER
- CALL FAFB(CA,CB,FA,FB)
- AK=AL*FB
- AM=AL*FA
- CALL A2B2(FA,FB,A2,B2)
- A2=A2/AQB
- B2=B2/AQB
-
-END SUBROUTINE ONDASP
-
-! calculation of S waves
-SUBROUTINE ONDASS(GS,AKB,AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
-
- implicit none
-
- double precision A1,B1,ANU,CA,CB,GS,AQB,BEALF,AKB
- complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
-
- ZER=(0.0d0,0.0d0)
- BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
- A1=0.0d0
- B1=1.0d0/AKB
-
- IF (GS==0.0d0) then
- AL=ZER
- AK=AKB+ZER
- AM=ZER
- A2=ZER
- B2=(-1.0d0+ZER)/AKB
- return
- end IF
-
- CB=1.0d0/SIN(GS)
- CA=CB*BEALF
-
-!
-! case of the critical angle
-!
- IF (CA==1.d0) then
- AL=AQB+ZER
- AM=ZER
- CALL FAFB(CA,CB,FA,FB)
- AK=AL*FB
- B2=-B1
- A2=-4.0d0*COS(GS)*B1/(1./BEALF-2.*BEALF)
-
-! case of an angle that is not critical
- ELSE
- AL=AQB/CA+ZER
- CALL FAFB(CA,CB,FA,FB)
- AK=AL*FB
- AM=AL*FA
- CALL A2B2(FA,FB,B2,A2)
- A2=-A2*FB/FA
- A2=A2/AKB
- B2=B2/AKB
- endif
-
-END SUBROUTINE ONDASS
-
-! calculation of Rayleigh waves
-SUBROUTINE ONDASR(AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
-
- implicit none
-
- double precision A1,B1,ANU,CA,CB,AQB,BEALF,ba2
- complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
-
- double precision, external :: crb
-
- ZER=(0.0d0,0.0d0)
- A1=0.0d0
- B1=0.0d0
- B2=1.0d0+ZER
- BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
- BA2=BEALF*BEALF
- CB=CRB(BEALF)
- CA=CB*BEALF
- AL=AQB/CA+ZER
-
- CALL FAFB(CA,CB,FA,FB)
-
- AK=AL*FB
- AM=AL*FA
- A2=2.0d0*FB/(FB*FB-1.0d0)*B2
- B2=B2/(AL*A2+AK)
- A2=A2*B2
-
-END SUBROUTINE ONDASR
-
-FUNCTION CRB(BEALF)
-
- implicit none
-
- include "constants.h"
-
- double precision U3,BA2,P,Q,FIND,F1,F2,F12,FACT,CRB,BEALF
-
- U3=1.0d0/3.0d0
- BA2=BEALF*BEALF
- P=8.0d0/3.0d0-16.0d0*BA2
- Q=272.0d0/27.0d0-80.0d0/3.0d0*BA2
- FIND=Q*Q/4.0d0+P*P*P/27.0d0
- IF (FIND>=0.0d0) then
- F1=SQRT(FIND)-Q/2.0d0
- IF (F1>0.0d0) then
- F1=F1**U3
- else
- F1=-(-F1)**U3
- end IF
- F2=-SQRT(FIND)-Q/2.0d0
- IF (F2>0.0d0) then
- F2=F2**U3
- else
- F2=-(-F2)**U3
- end IF
- FACT=F1+F2+8.0d0/3.0d0
- CRB=SQRT(FACT)
- else
- F1=-27.0d0*Q*Q/(4.0d0*P*P*P)
- F1=SQRT(F1)
- IF (Q<0.0d0) then
- F1=COS((PI-ACOS(F1))/3.0d0)
- else
- F1=COS(ACOS(F1)/3.0d0)
- end IF
- F2=-P/3.0d0
- F2=SQRT(F2)
- F12=-2.0d0*F1*F2+8.0d0/3.0d0
- CRB=SQRT(F12)
- end IF
-
-END FUNCTION CRB
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/paco_convolve_fft.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/paco_convolve_fft.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/paco_convolve_fft.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,230 +0,0 @@
-!
-! This subroutine was written by Paco Sanchez-Sesma and his colleagues
-! from the Autonomous University of Mexico (UNAM), Mexico City, Mexico
-!
-! PROGRAMA PARA CALCULAR SISMOGRAMAS SINTETICOS DADA LA
-! FUNCION DE TRANSFERENCIA PARA COMPONENTES Ux, Uz, R2
-! Tx y Tz SOLUCION DE CAMPO LIBRE Caso P-SV, RAYLEIGH
-!
-! modified by Dimitri Komatitsch and Ronan Madec in March 2008
-! in particular, converted to Fortran90 and to double precision
-
-subroutine paco_convolve_fft(Field,label,NSTEP,dt,NFREC,output_field,tp,ts)
-
- implicit none
-
- integer :: NFREC,N,NSTEP
-
- complex(selected_real_kind(15,300)), dimension(NFREC+1) :: Field
-
- complex(selected_real_kind(15,300)) :: CR(2*NFREC)
-
- double precision, dimension(NSTEP) :: output_field
-
- integer :: J,label
-
- double precision :: AN,FUN,RAIZ,dt,tp,ts
-
- double precision, external :: RIC, deRIC, de2RIC
-
- N=2*NFREC
-
- AN = N
-
-!
-! label=1 <=> champ U en entree =>convolution par un ricker pour U
-! label=2 <=> champ U en entree =>convolution par la derivee de ricker pour V
-! label=3 <=> champ U en entree =>convolution par la derivee seconde de ricker pour A
-! label=4 <=> champ T en entree =>convolution par un ricker
-!
-! flag=0 on a besoin de U, V et A (pas T)
-! flag/=0 on a besoin de T et V (pas U ni A)
-!
-! NSTEP==1 <=> FLAG==0 (flags: interior=0, left=1, right=2, bottom=3)
-!
-
- do j=1,N
- if (label==1 .or. label==4) FUN=ric(j,tp,ts,dt)
- if (label==2) FUN=deric(j,tp,ts,dt)
- if (label==3) FUN=de2ric(j,tp,ts,dt)
- CR(j)=CMPLX(FUN,0.0d0)
- enddo
-
- CALL fourier_transform(N,CR,-1.0d0)
-
- RAIZ = SQRT(AN)
-
- CALL SINTER(Field,output_field,NSTEP,CR,RAIZ,NFREC,label,dt)
-
-END subroutine paco_convolve_fft
-
-SUBROUTINE SINTER(V,output_field,NSTEP,CR,RAIZ,NFREC,label,dt)
-
- implicit none
-
- integer NSTEP, j,jn,N,label,nfrec,mult,delay
-
- double precision :: RAIZ
-
- complex(selected_real_kind(15,300)) :: VC
-
- double precision VT(2*NFREC)
-
- double precision :: filt,dt
-
- double precision, dimension(NSTEP) :: output_field
-
- complex(selected_real_kind(15,300)), dimension(NFREC+1) :: V
-
- complex(selected_real_kind(15,300)) :: CY(2*NFREC),CR(2*NFREC)
-
- N=2*NFREC
-
- CY(1) = CR(1) * V(1) * RAIZ * dt
-
- DO J=2,N/2+1
- FILT = 1.0d0
- VC = V(J)
- CY(J)= CR(J)*VC * RAIZ * dt/ FILT
- JN = N-J+2
- CY(JN)=CONJG(CY(J))
- enddo
-
- CALL fourier_transform(N,CY,1.0d0)
-
- if (label==1 .or. label==3 .or. (label==2 .and. NSTEP==1)) then
-! coefficients to take time steps needed (t=0: first time step)
- mult=1
- delay=0
- else if(label==2 .and. NSTEP>1) then
-! coefficients to take time steps needed (t=i*deltat+1/2: one step on two starting at 1/2)
- mult=2
- delay=0
- else if(label==4) then
-! coefficients to take time steps needed (t=i*deltat+1: one step on two starting at 1)
- mult=2
- delay=1
- end if
-
- do J=1,NSTEP
- CY(mult*J+delay)=CY(mult*J+delay)/RAIZ/dt
- VT(mult*J+delay)=REAL(CY(mult*J+delay))
- output_field(J)=VT(mult*J+delay)
- enddo
-
-END SUBROUTINE SINTER
-
-!
-! Ricker time function
-!
-FUNCTION RIC(J,tp,ts,dt)
-
- implicit none
-
- include "constants.h"
-
- double precision :: A,RIC,tp,ts,dt
-
- integer j
-
- A=PI*(dt*(J-1)-ts)/tp
- A=A*A
- RIC=0.0d0
- IF(A>30.0d0) RETURN
- RIC=(A-0.5)*EXP(-A)
-
-END FUNCTION RIC
-
-!
-! first time derivative of Ricker time function
-!
-FUNCTION deRIC(J,tp,ts,dt)
-
- implicit none
-
- include "constants.h"
-
- double precision :: A,A_dot,deRIC,tp,ts,dt
- integer :: j
-
- A=PI*(dt*(J-1)-ts)/tp
- A=A*A
- A_dot=2*(PI/tp)**2*(dt*(J-1)-ts)
- deRIC=0.0d0
- IF(A>30.0d0) RETURN
- deRIC=A_dot*(1.5-A)*EXP(-A)
-
-END FUNCTION deRIC
-
-!
-! second time derivative of Ricker time function
-!
-FUNCTION de2RIC(J,tp,ts,dt)
-
- implicit none
-
- include "constants.h"
-
- double precision :: A,A_dot,A_dot_dot,de2RIC,tp,ts,dt
- integer j
-
- A=PI*(dt*(J-1)-ts)/tp
- A=A*A
- A_dot=2*(PI/tp)**2*(dt*(J-1)-ts)
- A_dot_dot=2*(PI/tp)**2
- de2RIC=0.0d0
- IF(A>30.0d0) RETURN
- de2RIC=(A_dot_dot*(1.5-A)-A_dot*A_dot-A_dot*(1.5-A)*A_dot)*EXP(-A)
-
-END FUNCTION de2RIC
-
-
-! Fourier transform
-SUBROUTINE fourier_transform(LX,CX,SIGNI)
-
- implicit none
-
- include "constants.h"
-
- integer LX,i,j,l,istep,m
-
- double precision SC
-
- complex(selected_real_kind(15,300)) :: CX(LX),CARG,CW,CTEMP
-
- double precision SIGNI
-
- J=1
- SC=SQRT(1.0d0/LX)
- DO I=1,LX
- IF (I<=J) then
- CTEMP=CX(J)*SC
- CX(J)=CX(I)*SC
- CX(I)=CTEMP
- end IF
- M=LX/2
- do while (M>=1 .and. M<J)
- J=J-M
- M=M/2
- end do
- J=J+M
- end DO
- L=1
-
- do while(L<LX)
- ISTEP=2*L
- DO M=1,L
- CARG=(0.0d0,1.0d0)*(PI*SIGNI*(M-1))/L
- CW=EXP(CARG)
- DO I=M,LX,ISTEP
- CTEMP=CW*CX(I+L)
- CX(I+L)=CX(I)-CTEMP
- CX(I)=CX(I)+CTEMP
- end DO
- end DO
-
- L=ISTEP
- end do
-
-END SUBROUTINE fourier_transform
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/part_unstruct.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/part_unstruct.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/part_unstruct.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,1654 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!
-! This module contains subroutines related to unstructured meshes and partitioning of the
-! corresponding graphs.
-!
-
-module part_unstruct
-
- implicit none
-
- integer :: nelmnts
- integer, dimension(:), pointer :: elmnts
- integer, dimension(:), allocatable :: elmnts_bis
- integer, dimension(:), allocatable :: vwgt
- integer, dimension(:), allocatable :: glob2loc_elmnts
- integer, dimension(:), allocatable :: part
-
- integer :: nb_edges
- integer, dimension(:), allocatable :: adjwgt
-
- integer, dimension(:), allocatable :: xadj_g
- integer, dimension(:), allocatable :: adjncy_g
-
- integer :: nnodes
- double precision, dimension(:,:), allocatable :: nodes_coords
- integer, dimension(:), allocatable :: nnodes_elmnts
- integer, dimension(:), allocatable :: nodes_elmnts
- integer, dimension(:), allocatable :: glob2loc_nodes_nparts
- integer, dimension(:), allocatable :: glob2loc_nodes_parts
- integer, dimension(:), allocatable :: glob2loc_nodes
-
- ! interface data
- integer :: ninterfaces
- integer, dimension(:), allocatable :: tab_size_interfaces, tab_interfaces
-
- integer :: nelem_acoustic_surface
- integer, dimension(:,:), pointer :: acoustic_surface
- integer :: nelem_acoustic_surface_loc
-
- integer :: nelemabs
- integer, dimension(:,:), allocatable :: abs_surface
- logical, dimension(:,:), allocatable :: abs_surface_char
- integer, dimension(:), allocatable :: abs_surface_merge
- integer :: nelemabs_loc
-
- integer :: nelemabs_merge
- integer, dimension(:), allocatable :: ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right
-
- ! for acoustic/elastic coupled elements
- integer :: nedges_coupled
- integer, dimension(:,:), pointer :: edges_coupled
-
- ! for acoustic/poroelastic coupled elements
- integer :: nedges_acporo_coupled
- integer, dimension(:,:), pointer :: edges_acporo_coupled
-
- ! for poroelastic/elastic coupled elements
- integer :: nedges_elporo_coupled
- integer, dimension(:,:), pointer :: edges_elporo_coupled
-
-contains
-
- !-----------------------------------------------
- ! Read the mesh and storing it in array 'elmnts' (which is allocated here).
- ! 'num_start' is used to have the numbering of the nodes starting at '0'.
- ! 'nelmnts' is the number of elements, 'nnodes' is the number of nodes in the mesh.
- !-----------------------------------------------
- subroutine read_external_mesh_file(filename, num_start, ngnod)
-
- implicit none
- !include "constants.h"
-
- character(len=256), intent(in) :: filename
- integer, intent(out) :: num_start
- integer, intent(in) :: ngnod
-
- integer :: i,ier
-
- open(unit=990, file=trim(filename), form='formatted' , status='old', action='read',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening file: ',trim(filename)
- stop 'error read external mesh file'
- endif
-
- read(990,*) nelmnts
-
- allocate(elmnts(0:ngnod*nelmnts-1))
-
- do i = 0, nelmnts-1
- if(ngnod == 4) then
- read(990,*) elmnts(i*ngnod), elmnts(i*ngnod+1), elmnts(i*ngnod+2), elmnts(i*ngnod+3)
- else if(ngnod == 9) then
- read(990,*) elmnts(i*ngnod), elmnts(i*ngnod+1), elmnts(i*ngnod+2), elmnts(i*ngnod+3), &
- elmnts(i*ngnod+4), elmnts(i*ngnod+5), elmnts(i*ngnod+6), elmnts(i*ngnod+7), elmnts(i*ngnod+8)
- else
- stop 'error, ngnod should be either 4 or 9 for external meshes'
- endif
- enddo
-
- close(990)
-
- num_start = minval(elmnts)
- elmnts(:) = elmnts(:) - num_start
- nnodes = maxval(elmnts) + 1
-
- end subroutine read_external_mesh_file
-
- !-----------------------------------------------
- ! Read the nodes coordinates and storing it in array 'nodes_coords'
- !-----------------------------------------------
- subroutine read_nodes_coords(filename)
-
- implicit none
-
- character(len=256), intent(in) :: filename
-
- integer :: i,ier
-
- open(unit=991, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening file: ',trim(filename)
- stop 'error read external nodes coords file'
- endif
-
- read(991,*) nnodes
- allocate(nodes_coords(2,nnodes))
- do i = 1, nnodes
- read(991,*) nodes_coords(1,i), nodes_coords(2,i)
- enddo
- close(991)
-
- end subroutine read_nodes_coords
-
-
- !-----------------------------------------------
- ! Read the material for each element and storing it in array 'num_materials'
- !-----------------------------------------------
- subroutine read_mat(filename, num_material)
-
- implicit none
-
- character(len=256), intent(in) :: filename
- integer, dimension(1:nelmnts), intent(out) :: num_material
-
- integer :: i,ier
-
- open(unit=992, file=trim(filename), form='formatted' , status='old', action='read',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening file: ',trim(filename)
- stop 'error read external mat file'
- endif
-
- do i = 1, nelmnts
- read(992,*) num_material(i)
- enddo
- close(992)
-
- end subroutine read_mat
-
-
- !-----------------------------------------------
- ! Read free surface.
- ! Edges from elastic elements are discarded.
- ! 'acoustic_surface' contains 1/ element number, 2/ number of nodes that form the free surface,
- ! 3/ first node on the free surface, 4/ second node on the free surface, if relevant (if 2/ is equal to 2)
- !-----------------------------------------------
- subroutine read_acoustic_surface(filename, num_material, &
- ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
-
- implicit none
-
- !include "constants.h"
-
- character(len=256), intent(in) :: filename
- integer, dimension(0:nelmnts-1) :: num_material
- 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
- integer, intent(in) :: num_start
-
-
- integer, dimension(:,:), allocatable :: acoustic_surface_tmp
- integer :: nelmnts_surface
- integer :: i,ier
- integer :: imaterial_number
-
-
- open(unit=993, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening file: ',trim(filename)
- stop 'error read acoustic surface file'
- endif
-
- read(993,*) nelmnts_surface
-
- allocate(acoustic_surface_tmp(4,nelmnts_surface))
-
- 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)
-
- enddo
-
- close(993)
- acoustic_surface_tmp(1,:) = acoustic_surface_tmp(1,:) - num_start
- acoustic_surface_tmp(3,:) = acoustic_surface_tmp(3,:) - num_start
- acoustic_surface_tmp(4,:) = acoustic_surface_tmp(4,:) - num_start
-
- nelem_acoustic_surface = 0
- do i = 1, nelmnts_surface
- imaterial_number = num_material(acoustic_surface_tmp(1,i))
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
-
- endif
- enddo
-
- allocate(acoustic_surface(4,nelem_acoustic_surface))
-
- nelem_acoustic_surface = 0
- do i = 1, nelmnts_surface
- imaterial_number = num_material(acoustic_surface_tmp(1,i))
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- acoustic_surface(:,nelem_acoustic_surface) = acoustic_surface_tmp(:,i)
- endif
- enddo
-
- end subroutine read_acoustic_surface
-
-
- !-----------------------------------------------
- ! Read absorbing surface.
- ! 'abs_surface' contains 1/ element number, 2/ number of nodes that form the absorbing edge
- ! (which currently must always be equal to two, see comment below),
- ! 3/ first node on the abs surface, 4/ second node on the abs surface
- !-----------------------------------------------
- subroutine read_abs_surface(filename, num_start)
-
- implicit none
- !include "constants.h"
-
- character(len=256), intent(in) :: filename
- integer, intent(in) :: num_start
-
- integer :: i,ier
-
- open(unit=994, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
- if( ier /= 0 ) then
- print *,'error opening file: ',trim(filename)
- stop 'error read absorbing surface file'
- endif
-
- read(994,*) nelemabs
-
- allocate(abs_surface(4,nelemabs))
-
- do i = 1, nelemabs
- read(994,*) abs_surface(1,i), abs_surface(2,i), abs_surface(3,i), abs_surface(4,i)
- if (abs_surface(2,i) /= 2) then
- print *,'The input format is currently limited: only two nodes per element can be listed.'
- print *,'If one of your elements has more than one edge along a given absorbing contour'
- print *,'(e.g., if that contour has a corner) then list it twice,'
- print *,'putting the first edge on the first line and the second edge on the second line.'
- print *,'if one of your elements has a single point along the absording contour rather than a full edge, do NOT list it'
- print *,'(it would have no weight in the contour integral anyway because it would consist of a single point).'
- print *,'If you are using 9-node elements, list only the first and last points of the edge and not the intermediate point'
- print *,'located around the middle of the edge; the right 9-node curvature will be restored automatically by the code.'
- stop 'only two nodes per element should be listed for absorbing edges'
- endif
- enddo
-
- close(994)
-
- abs_surface(1,:) = abs_surface(1,:) - num_start
- abs_surface(3,:) = abs_surface(3,:) - num_start
- abs_surface(4,:) = abs_surface(4,:) - num_start
-
- end subroutine read_abs_surface
-
-
- !-----------------------------------------------
- ! Creating dual graph (adjacency is defined by 'ncommonnodes' between two elements).
- !-----------------------------------------------
- subroutine mesh2dual_ncommonnodes(elmnts_l,ncommonnodes,xadj,adjncy)
-
- implicit none
- include "constants.h"
-
- integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
- integer, intent(in) :: ncommonnodes
- integer, dimension(0:nelmnts),intent(out) :: xadj
- integer, dimension(0:MAX_NEIGHBORS*nelmnts-1),intent(out) :: adjncy
-
- ! local parameters
- integer :: i, j, k, l, m, num_edges
- logical :: is_neighbour
- integer :: num_node, n
- integer :: elem_base, elem_target
- integer :: connectivity
-
- ! allocates memory for arrays
- if( .not. allocated(nnodes_elmnts) ) allocate(nnodes_elmnts(0:nnodes-1))
- if( .not. allocated(nodes_elmnts) ) allocate(nodes_elmnts(0:nsize*nnodes-1))
-
- ! initializes
- xadj(:) = 0
- adjncy(:) = 0
- nnodes_elmnts(:) = 0
- nodes_elmnts(:) = 0
- num_edges = 0
-
- ! list of elements per node
- do i = 0, NCORNERS*nelmnts-1
- nodes_elmnts(elmnts_l(i)*nsize + nnodes_elmnts(elmnts_l(i))) = i/NCORNERS
- nnodes_elmnts(elmnts_l(i)) = nnodes_elmnts(elmnts_l(i)) + 1
- enddo
-
- ! checking which elements are neighbours ('ncommonnodes' criteria)
- do j = 0, nnodes-1
- do k = 0, nnodes_elmnts(j)-1
- do l = k+1, nnodes_elmnts(j)-1
-
- connectivity = 0
- elem_base = nodes_elmnts(k+j*nsize)
- elem_target = nodes_elmnts(l+j*nsize)
- do n = 1, NCORNERS
- num_node = elmnts_l(NCORNERS*elem_base+n-1)
- do m = 0, nnodes_elmnts(num_node)-1
- if ( nodes_elmnts(m+num_node*nsize) == elem_target ) then
- connectivity = connectivity + 1
- endif
- enddo
- enddo
-
- ! sets adjacency (adjncy) and number of neighbors (xadj)
- ! according to ncommonnodes criteria
- if ( connectivity >= ncommonnodes) then
-
- is_neighbour = .false.
-
- do m = 0, xadj(nodes_elmnts(k+j*nsize))
- if ( .not.is_neighbour ) then
- if ( adjncy(nodes_elmnts(k+j*nsize)*MAX_NEIGHBORS+m) == nodes_elmnts(l+j*nsize) ) then
- is_neighbour = .true.
- endif
- endif
- enddo
- if ( .not.is_neighbour ) then
- adjncy(nodes_elmnts(k+j*nsize)*MAX_NEIGHBORS &
- + xadj(nodes_elmnts(k+j*nsize))) = nodes_elmnts(l+j*nsize)
-
- xadj(nodes_elmnts(k+j*nsize)) = xadj(nodes_elmnts(k+j*nsize)) + 1
- if (xadj(nodes_elmnts(k+j*nsize)) > MAX_NEIGHBORS) &
- stop 'ERROR : too much neighbours per element, modify the mesh.'
-
- adjncy(nodes_elmnts(l+j*nsize)*MAX_NEIGHBORS &
- + xadj(nodes_elmnts(l+j*nsize))) = nodes_elmnts(k+j*nsize)
-
- xadj(nodes_elmnts(l+j*nsize)) = xadj(nodes_elmnts(l+j*nsize)) + 1
- if (xadj(nodes_elmnts(l+j*nsize))>MAX_NEIGHBORS) &
- stop 'ERROR : too much neighbours per element, modify the mesh.'
-
- endif
- endif
- enddo
- enddo
- enddo
-
- ! making adjacency arrays compact (to be used for partitioning)
- do i = 0, nelmnts-1
- k = xadj(i)
- xadj(i) = num_edges
- do j = 0, k-1
- adjncy(num_edges) = adjncy(i*MAX_NEIGHBORS+j)
- num_edges = num_edges + 1
- enddo
- enddo
-
- xadj(nelmnts) = num_edges
-
- end subroutine mesh2dual_ncommonnodes
-
-
- !-----------------------------------------------
- ! Read the weight for each vertices and edges of the graph (not curretly used)
- !-----------------------------------------------
- subroutine read_weights()
-
- implicit none
-
- allocate(vwgt(0:nelmnts-1))
- allocate(adjwgt(0:nb_edges-1))
-
- vwgt(:) = 1
- adjwgt(:) = 1
-
- end subroutine read_weights
-
-
- !--------------------------------------------------
- ! construct local numbering for the elements in each partition
- !--------------------------------------------------
- subroutine Construct_glob2loc_elmnts(nparts)
-
- implicit none
- integer, intent(in) :: nparts
-
- integer :: num_glob, num_part
- integer, dimension(0:nparts-1) :: num_loc
-
-
- allocate(glob2loc_elmnts(0:nelmnts-1))
-
- ! initializes number of local elements per partition
- do num_part = 0, nparts-1
- num_loc(num_part) = 0
- enddo
-
- ! local numbering
- 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
- enddo
-
- end subroutine Construct_glob2loc_elmnts
-
-
- !--------------------------------------------------
- ! construct local numbering for the nodes in each partition
- !--------------------------------------------------
- subroutine Construct_glob2loc_nodes(nparts)
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: nparts
-
- integer :: num_node
- integer :: el
- integer :: num_part
- integer :: size_glob2loc_nodes
- integer, dimension(0:nparts-1) :: parts_node
- integer, dimension(0:nparts-1) :: num_parts
-
- allocate(glob2loc_nodes_nparts(0:nnodes))
-
- size_glob2loc_nodes = 0
-
- parts_node(:) = 0
-
-
- do num_node = 0, nnodes-1
- glob2loc_nodes_nparts(num_node) = size_glob2loc_nodes
- do el = 0, nnodes_elmnts(num_node)-1
- parts_node(part(nodes_elmnts(el+nsize*num_node))) = 1
- 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
- endif
- enddo
-
- enddo
-
- glob2loc_nodes_nparts(nnodes) = size_glob2loc_nodes
-
- allocate(glob2loc_nodes_parts(0:glob2loc_nodes_nparts(nnodes)-1))
- allocate(glob2loc_nodes(0:glob2loc_nodes_nparts(nnodes)-1))
-
- glob2loc_nodes(0) = 0
-
- parts_node(:) = 0
- num_parts(:) = 0
- size_glob2loc_nodes = 0
-
-
- do num_node = 0, nnodes-1
- do el = 0, nnodes_elmnts(num_node)-1
- parts_node(part(nodes_elmnts(el+nsize*num_node))) = 1
- enddo
- do num_part = 0, nparts-1
-
- if ( parts_node(num_part) == 1 ) then
- glob2loc_nodes_parts(size_glob2loc_nodes) = num_part
- glob2loc_nodes(size_glob2loc_nodes) = num_parts(num_part)
- size_glob2loc_nodes = size_glob2loc_nodes + 1
- num_parts(num_part) = num_parts(num_part) + 1
- parts_node(num_part) = 0
- endif
-
- enddo
- enddo
-
- end subroutine Construct_glob2loc_nodes
-
-
- !--------------------------------------------------
- ! Construct interfaces between each partitions.
- ! Two adjacent elements in distinct partitions make an entry in array tab_interfaces :
- ! 1/ first element, 2/ second element, 3/ number of common nodes, 4/ first node,
- ! 5/ second node, if relevant.
- ! No interface between acoustic, elastic, and poroelastic elements.
- !--------------------------------------------------
- subroutine Construct_interfaces(nparts, elmnts_l, &
- nb_materials, phi_material, num_material)
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: nparts
- integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
- integer, dimension(1:nelmnts), intent(in) :: num_material
- integer, intent(in) :: nb_materials
- double precision, dimension(1:nb_materials), intent(in) :: phi_material
-
- integer :: num_part, num_part_bis, el, el_adj, num_interface, num_edge, ncommon_nodes, &
- num_node, num_node_bis
- integer :: i, j
- logical :: is_acoustic_el, is_acoustic_el_adj, is_elastic_el, is_elastic_el_adj
-
- ninterfaces = 0
- do i = 0, nparts-1
- do j = i+1, nparts-1
- ninterfaces = ninterfaces + 1
- enddo
- enddo
-
- allocate(tab_size_interfaces(0:ninterfaces))
- tab_size_interfaces(:) = 0
-
- num_interface = 0
- num_edge = 0
-
- do num_part = 0, nparts-1
- do num_part_bis = num_part+1, nparts-1
- do el = 0, nelmnts-1
- if ( part(el) == num_part ) then
- ! sets material flag
- if ( phi_material(num_material(el+1)) < TINYVAL) then
- ! elastic element
- is_acoustic_el = .false.
- is_elastic_el = .true.
- elseif ( phi_material(num_material(el+1)) >= 1.d0) then
- ! acoustic element
- is_acoustic_el = .true.
- is_elastic_el = .false.
- else
- ! poroelastic element
- is_acoustic_el = .false.
- is_elastic_el = .false.
- endif
-
- ! looks at all neighbor elements
- do el_adj = xadj_g(el), xadj_g(el+1)-1
- ! sets neighbor material flag
- if ( phi_material(num_material(adjncy_g(el_adj)+1)) < TINYVAL) then
- is_acoustic_el_adj = .false.
- is_elastic_el_adj = .true.
- elseif ( phi_material(num_material(adjncy_g(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.
- endif
- ! adds element if neighbor element lies in next parition
- ! and belongs to same material
- if ( (part(adjncy_g(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
- endif
- enddo
- endif
- enddo
- ! stores number of elements at interface
- tab_size_interfaces(num_interface+1) = tab_size_interfaces(num_interface) + num_edge
- num_edge = 0
- num_interface = num_interface + 1
-
- enddo
- enddo
-
- ! stores element indices for elements from above search at each interface
- num_interface = 0
- num_edge = 0
-
- allocate(tab_interfaces(0:(tab_size_interfaces(ninterfaces)*5-1)))
- tab_interfaces(:) = 0
-
- do num_part = 0, nparts-1
- do num_part_bis = num_part+1, nparts-1
- do el = 0, nelmnts-1
- if ( part(el) == num_part ) then
- if ( phi_material(num_material(el+1)) < TINYVAL) then
- is_acoustic_el = .false.
- 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.
- endif
- do el_adj = xadj_g(el), xadj_g(el+1)-1
- if ( phi_material(num_material(adjncy_g(el_adj)+1)) < TINYVAL) then
- is_acoustic_el_adj = .false.
- is_elastic_el_adj = .true.
- elseif ( phi_material(num_material(adjncy_g(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.
- endif
- if ( (part(adjncy_g(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_g(el_adj)
- ncommon_nodes = 0
- do num_node = 0, 4-1
- do num_node_bis = 0, 4-1
- if ( elmnts_l(el*NCORNERS+num_node) == &
- elmnts_l(adjncy_g(el_adj)*NCORNERS+num_node_bis) ) then
- tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+3+ncommon_nodes) &
- = elmnts_l(el*NCORNERS+num_node)
- ncommon_nodes = ncommon_nodes + 1
- 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
- stop 'fatal error'
- endif
- num_edge = num_edge + 1
- endif
- enddo
- endif
-
- enddo
- num_edge = 0
- num_interface = num_interface + 1
- enddo
- enddo
-
- end subroutine Construct_interfaces
-
-
- !--------------------------------------------------
- ! Write nodes (their coordinates) pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
- subroutine write_glob2loc_nodes_database(IIN_database, iproc, npgeo, num_phase)
-
- implicit none
-
- integer, intent(in) :: IIN_database
- integer, intent(in) :: iproc, num_phase
- integer, intent(inout) :: npgeo
-
- integer :: i, j
-
- if ( num_phase == 1 ) then
- npgeo = 0
-
- do i = 0, nnodes-1
- do j = glob2loc_nodes_nparts(i), glob2loc_nodes_nparts(i+1)-1
- if ( glob2loc_nodes_parts(j) == iproc ) then
- npgeo = npgeo + 1
- endif
- 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)
- endif
- enddo
- enddo
- endif
-
- end subroutine Write_glob2loc_nodes_database
-
-
- !--------------------------------------------------
- ! Write elements (their nodes) pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
- subroutine write_partition_database(IIN_database, iproc, nspec, &
- num_modele, ngnod, num_phase)
-
- implicit none
-
- integer, intent(in) :: IIN_database
- integer, intent(in) :: num_phase, iproc
- integer, intent(inout) :: nspec
- integer, dimension(:) :: num_modele
- integer, intent(in) :: ngnod
-
- integer :: i,j,k
- integer, dimension(0:ngnod-1) :: loc_nodes
-
- if (num_phase == 1) then
-
- nspec = 0
-
- do i = 0, nelmnts-1
- if (part(i) == iproc) nspec = nspec + 1
- enddo
-
- else
- do i = 0, nelmnts-1
- 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) 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)
- endif
- enddo
-
- endif
-
- end subroutine write_partition_database
-
-
- !--------------------------------------------------
- ! Write interfaces (element and common nodes) pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
- subroutine Write_interfaces_database(IIN_database, nparts, iproc, &
- my_ninterface, my_interfaces, my_nb_interfaces, num_phase)
-
- implicit none
-
- integer, intent(in) :: IIN_database
- integer, intent(in) :: iproc
- integer, intent(in) :: nparts
- integer, intent(inout) :: my_ninterface
- integer, dimension(0:ninterfaces-1), intent(inout) :: my_interfaces
- integer, dimension(0:ninterfaces-1), intent(inout) :: my_nb_interfaces
-
- integer, dimension(2) :: local_nodes
- integer :: local_elmnt
- integer :: num_phase
-
- integer :: i, j, k, l
- integer :: num_interface
-
- num_interface = 0
-
- if ( num_phase == 1 ) then
-
- my_interfaces(:) = 0
- my_nb_interfaces(:) = 0
-
- do i = 0, nparts-1
- do j = i+1, nparts-1
- if ( (tab_size_interfaces(num_interface) < tab_size_interfaces(num_interface+1)) .and. &
- (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)
- endif
- num_interface = num_interface + 1
- enddo
- enddo
- my_ninterface = sum(my_interfaces(:))
-
- else
-
- do i = 0, nparts-1
- do j = i+1, nparts-1
- if ( my_interfaces(num_interface) == 1 ) then
- if ( i == iproc ) then
- write(IIN_database,*) j, my_nb_interfaces(num_interface)
- else
- write(IIN_database,*) i, my_nb_interfaces(num_interface)
- 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
- endif
-
- if ( tab_interfaces(k*5+2) == 1 ) then
- ! common node (single point)
- 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
- endif
- enddo
-
- write(IIN_database,*) local_elmnt, tab_interfaces(k*5+2), &
- local_nodes(1), -1
- else
- if ( tab_interfaces(k*5+2) == 2 ) then
- ! common edge (two nodes)
- ! first node
- 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
- endif
- enddo
- ! second node
- 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
- 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)
- endif
- endif
- enddo
-
- endif
-
- num_interface = num_interface + 1
- enddo
- enddo
-
- endif
-
- end subroutine Write_interfaces_database
-
-
- !--------------------------------------------------
- ! Write a surface (elements and nodes on the surface) pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
- subroutine Write_surface_database(IIN_database, nsurface, surface, &
- nsurface_loc, iproc, num_phase)
-
- implicit none
- integer, intent(in) :: IIN_database
- integer, intent(in) :: iproc
- integer :: nsurface
- integer :: nsurface_loc
- integer, dimension(:,:), pointer :: surface
-
- integer, dimension(2) :: local_nodes
- integer :: local_elmnt
- integer :: num_phase
-
- integer :: i, l
-
- if ( num_phase == 1 ) then
-
- nsurface_loc = 0
-
- do i = 1, nsurface
- if ( part(surface(1,i)) == iproc ) then
- nsurface_loc = nsurface_loc + 1
- endif
- enddo
-
- else
-
- nsurface_loc = 0
-
- do i = 1, nsurface
- if ( part(surface(1,i)) == iproc ) then
- nsurface_loc = nsurface_loc + 1
-
- local_elmnt = glob2loc_elmnts(surface(1,i)) + 1
-
- if ( surface(2,i) == 1 ) 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
- endif
- enddo
-
- write(IIN_database,*) local_elmnt, surface(2,i), local_nodes(1), -1
- 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
- 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
- endif
- enddo
-
- write(IIN_database,*) local_elmnt, surface(2,i), local_nodes(1), local_nodes(2)
- endif
-
- endif
-
- enddo
-
- 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 relation (this is the
- ! reason arrays ibegin_..., iend_... were included here).
- ! Under development : exluding points that have two different normals in two different elements.
- !--------------------------------------------------
-
- subroutine merge_abs_boundaries(nb_materials, phi_material, num_material, ngnod)
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: ngnod
- integer :: nb_materials
- double precision, dimension(nb_materials), intent(in) :: phi_material
- integer, dimension(1:nelmnts), intent(in) :: num_material
-
- logical, dimension(nb_materials) :: is_acoustic
- integer :: num_edge, nedge_bound
- integer :: match
- integer :: nb_elmnts_abs
- integer :: i
- integer :: temp
- integer :: iedge, inode1, inode2
-
- allocate(abs_surface_char(4,nelemabs))
- allocate(abs_surface_merge(nelemabs))
- abs_surface_char(:,:) = .false.
- abs_surface_merge(:) = -1
-
- nedge_bound = nelemabs
- nb_elmnts_abs = 0
-
- do num_edge = 1, nedge_bound
-
- match = 0
- do i = 1, nb_elmnts_abs
- if ( abs_surface(1,num_edge) == abs_surface_merge(i) ) then
- match = i
- exit
- endif
- enddo
-
- if ( match == 0 ) then
- nb_elmnts_abs = nb_elmnts_abs + 1
- match = nb_elmnts_abs
- endif
-
- abs_surface_merge(match) = abs_surface(1,num_edge)
-
-
- 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)+1)) ) then
- abs_surface_char(1,match) = .true.
-
- 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
- temp = abs_surface(4,num_edge)
- abs_surface(4,num_edge) = abs_surface(3,num_edge)
- abs_surface(3,num_edge) = temp
- abs_surface_char(1,match) = .true.
-
- 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.
-
- 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
- temp = abs_surface(4,num_edge)
- abs_surface(4,num_edge) = abs_surface(3,num_edge)
- abs_surface(3,num_edge) = temp
- abs_surface_char(4,match) = .true.
-
- 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.
-
- 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
- temp = abs_surface(4,num_edge)
- abs_surface(4,num_edge) = abs_surface(3,num_edge)
- abs_surface(3,num_edge) = temp
- abs_surface_char(2,match) = .true.
-
- 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
- temp = abs_surface(4,num_edge)
- abs_surface(4,num_edge) = abs_surface(3,num_edge)
- abs_surface(3,num_edge) = temp
- abs_surface_char(3,match) = .true.
-
- 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.
-
- endif
-
- enddo
-
- nelemabs_merge = nb_elmnts_abs
-
- allocate(ibegin_bottom(nelemabs_merge))
- allocate(iend_bottom(nelemabs_merge))
- allocate(jbegin_right(nelemabs_merge))
- allocate(jend_right(nelemabs_merge))
- allocate(ibegin_top(nelemabs_merge))
- allocate(iend_top(nelemabs_merge))
- allocate(jbegin_left(nelemabs_merge))
- allocate(jend_left(nelemabs_merge))
-
- ibegin_bottom(:) = 1
- jbegin_right(:) = 1
- ibegin_top(:) = 1
- jbegin_left(:) = 1
- iend_bottom(:) = NGLLX
- jend_right(:) = NGLLZ
- iend_top(:) = NGLLX
- jend_left(:) = NGLLZ
-
- is_acoustic(:) = .false.
-
- do i = 1, nb_materials
- if (phi_material(i) >= 1.d0) then
- is_acoustic(i) = .true.
- endif
- enddo
-
- do num_edge = 1, nedge_bound
-
- match = 0
- do i = 1, nelemabs_merge
- if ( abs_surface(1,num_edge) == abs_surface_merge(i) ) then
- match = i
- exit
- endif
- enddo
-
- if ( is_acoustic(num_material(abs_surface(1,num_edge)+1)) ) then
-
- do iedge = 1, nedges_coupled
-
- do inode1 = 0, 3
- if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_coupled(1,iedge)+inode1) ) then
- do inode2 = 0, 3
- if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_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
-
- 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
-
- 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
-
- 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
-
- endif
-
- endif
- enddo
-
- endif
-
- if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_coupled(1,iedge)+inode1) ) then
- do inode2 = 0, 3
- if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_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
-
- 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
-
- 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
-
- 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
-
- endif
- endif
- enddo
-
- endif
-
- enddo
-
-
- enddo
-
- endif
-
- enddo
-
- end subroutine merge_abs_boundaries
-
-
- !--------------------------------------------------
- ! Write abs surface (elements and nodes on the surface) pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
-
- subroutine write_abs_merge_database(IIN_database, iproc, num_phase)
-
- implicit none
-
- integer, intent(in) :: IIN_database
- integer, intent(in) :: iproc
- integer, intent(in) :: num_phase
-
- integer :: i
-
- if ( num_phase == 1 ) then
- nelemabs_loc = 0
- do i = 1, nelemabs_merge
- if ( part(abs_surface_merge(i)) == iproc ) then
- nelemabs_loc = nelemabs_loc + 1
- endif
- enddo
- else
- do i = 1, nelemabs_merge
- if ( part(abs_surface_merge(i)) == iproc ) then
-
- write(IIN_database,*) glob2loc_elmnts(abs_surface_merge(i))+1, abs_surface_char(1,i), &
- abs_surface_char(2,i), abs_surface_char(3,i), abs_surface_char(4,i), &
- ibegin_bottom(i), iend_bottom(i), &
- jbegin_right(i), jend_right(i), &
- ibegin_top(i), iend_top(i), &
- jbegin_left(i), jend_left(i)
-
- endif
-
- enddo
- endif
-
- end subroutine write_abs_merge_database
-
-
-!! DK DK support for METIS now removed, we use SCOTCH instead
-!#ifdef USE_METIS
-! !--------------------------------------------------
-! ! Partitioning using METIS
-! !--------------------------------------------------
-! 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_NEIGHBORS*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
-! integer, dimension(0:4) :: metis_options
-!
-! integer :: wgtflag
-! integer :: num_start
-!
-! num_start = 0
-! wgtflag = 0
-!
-! 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));
-!
-! end subroutine Part_metis
-!#endif
-
-
-#ifdef USE_SCOTCH
- !--------------------------------------------------
- ! Partitioning using SCOTCH
- !--------------------------------------------------
- subroutine Part_scotch(nparts, edgecut)
-
- implicit none
- include "constants.h"
-
- include "scotchf.h"
-
- integer, intent(in) :: nparts
- integer, intent(inout) :: edgecut
-
- double precision, dimension(SCOTCH_GRAPHDIM) :: SCOTCHGRAPH
- double precision, dimension(SCOTCH_STRATDIM) :: SCOTCHSTRAT
- integer :: IERR
-
- edgecut = vwgt(0)
- edgecut = 0
-
- ! we use default strategy for partitioning, thus omit specifing explicit strategy .
- call scotchfstratinit (SCOTCHSTRAT(1), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot initialize strat'
- STOP
- ENDIF
-
- CALL SCOTCHFGRAPHINIT (SCOTCHGRAPH (1), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot initialize graph'
- STOP
- ENDIF
-
- ! fills graph structure : see user manual (scotch_user5.1.pdf, page 72/73)
- ! arguments: #(1) graph_structure #(2) baseval(either 0/1) #(3) number_of_vertices
- ! #(4) adjacency_index_array #(5) adjacency_end_index_array (optional)
- ! #(6) vertex_load_array (optional) #(7) vertex_label_array
- ! #(7) number_of_arcs #(8) adjacency_array
- ! #(9) arc_load_array (optional) #(10) ierror
- CALL SCOTCHFGRAPHBUILD (SCOTCHGRAPH (1), 0, nelmnts, &
- xadj_g(0), xadj_g(0), &
- xadj_g(0), xadj_g(0), &
- nb_edges, &
- adjncy_g(0), adjwgt (0), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot build graph'
- STOP
- ENDIF
-
- CALL SCOTCHFGRAPHCHECK (SCOTCHGRAPH (1), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Invalid check'
- STOP
- ENDIF
-
- call scotchfgraphpart (SCOTCHGRAPH (1), nparts, SCOTCHSTRAT(1), part(0), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot part graph'
- STOP
- ENDIF
-
- CALL SCOTCHFGRAPHEXIT (SCOTCHGRAPH (1), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot destroy graph'
- STOP
- ENDIF
-
- call scotchfstratexit (SCOTCHSTRAT(1), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot destroy strat'
- STOP
- ENDIF
-
- end subroutine Part_scotch
-#endif
-
-
- !--------------------------------------------------
- ! Repartitioning : two coupled acoustic/elastic elements are transfered to the same partition
- !--------------------------------------------------
-
- subroutine acoustic_elastic_repartitioning (elmnts_l, nb_materials, &
- phi_material, num_material, nproc)
-
- implicit none
- include "constants.h"
-
- integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
- integer, intent(in) :: nproc, nb_materials
- double precision, dimension(nb_materials), intent(in) :: phi_material
- integer, dimension(1:nelmnts), intent(in) :: num_material
-
- ! local parameters
- integer, dimension(:), allocatable :: xadj_l
- integer, dimension(:), allocatable :: adjncy_l
- logical, dimension(nb_materials) :: is_acoustic, is_elastic
- integer :: i, num_edge
- integer :: el, el_adj
- logical :: is_repartitioned
-
- allocate(xadj_l(0:nelmnts))
- allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
-
- is_acoustic(:) = .false.
- is_elastic(:) = .false.
-
- do i = 1, nb_materials
- if (phi_material(i) >= 1.d0) then
- is_acoustic(i) = .true.
- endif
- if (phi_material(i) < TINYVAL) then
- is_elastic(i) = .true.
- endif
- enddo
-
- ! determines maximum neighbors based on 2 common nodes (common edge)
- call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
-
- nedges_coupled = 0
- do el = 0, nelmnts-1
- if ( is_acoustic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_coupled = nedges_coupled + 1
- endif
- enddo
- endif
- enddo
-
- allocate(edges_coupled(2,nedges_coupled))
-
- nedges_coupled = 0
- do el = 0, nelmnts-1
- if ( is_acoustic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_coupled = nedges_coupled + 1
- edges_coupled(1,nedges_coupled) = el
- edges_coupled(2,nedges_coupled) = adjncy_l(el_adj)
- endif
-
- enddo
- endif
- enddo
-
- do i = 1, nedges_coupled*nproc
- is_repartitioned = .false.
- do num_edge = 1, nedges_coupled
- if ( part(edges_coupled(1,num_edge)) /= part(edges_coupled(2,num_edge)) ) then
- if ( part(edges_coupled(1,num_edge)) < part(edges_coupled(2,num_edge)) ) then
- 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))
- endif
- is_repartitioned = .true.
- endif
-
- enddo
- if ( .not. is_repartitioned ) then
- exit
- endif
- enddo
-
- deallocate(xadj_l,adjncy_l)
-
- end subroutine acoustic_elastic_repartitioning
-
-
- !--------------------------------------------------
- ! Repartitioning : two coupled acoustic/poroelastic elements are transfered to the same partition
- !--------------------------------------------------
-
- subroutine acoustic_poro_repartitioning (elmnts_l, nb_materials, &
- phi_material, num_material, nproc)
-
- implicit none
- include "constants.h"
-
- integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
- integer, intent(in) :: nproc, nb_materials
- double precision, dimension(nb_materials), intent(in) :: phi_material
- integer, dimension(1:nelmnts), intent(in) :: num_material
-
- ! local parameters
- integer, dimension(:), allocatable :: xadj_l
- integer, dimension(:), allocatable :: adjncy_l
- logical, dimension(nb_materials) :: is_acoustic,is_poroelastic
- integer :: i, num_edge
- integer :: el, el_adj
- logical :: is_repartitioned
-
- allocate(xadj_l(0:nelmnts))
- allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
-
- is_acoustic(:) = .false.
- is_poroelastic(:) = .false.
-
- do i = 1, nb_materials
- if (phi_material(i) >=1.d0) then
- is_acoustic(i) = .true.
- endif
- if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
- is_poroelastic(i) = .true.
- endif
- enddo
-
- ! determines maximum neighbors based on 2 common nodes (common edge)
- call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
-
- nedges_acporo_coupled = 0
- do el = 0, nelmnts-1
- if ( is_acoustic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_poroelastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_acporo_coupled = nedges_acporo_coupled + 1
- endif
-
- enddo
- endif
- enddo
-
- print *, 'nedges_coupled (acoustic/poroelastic)', nedges_acporo_coupled
-
- allocate(edges_acporo_coupled(2,nedges_acporo_coupled))
-
- nedges_acporo_coupled = 0
- do el = 0, nelmnts-1
- if ( is_acoustic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_poroelastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_acporo_coupled = nedges_acporo_coupled + 1
- edges_acporo_coupled(1,nedges_acporo_coupled) = el
- edges_acporo_coupled(2,nedges_acporo_coupled) = adjncy_l(el_adj)
- endif
-
- enddo
- endif
- enddo
-
- do i = 1, nedges_acporo_coupled*nproc
- is_repartitioned = .false.
- do num_edge = 1, nedges_acporo_coupled
- if ( part(edges_acporo_coupled(1,num_edge)) /= part(edges_acporo_coupled(2,num_edge)) ) then
- if ( part(edges_acporo_coupled(1,num_edge)) < part(edges_acporo_coupled(2,num_edge)) ) then
- part(edges_acporo_coupled(2,num_edge)) = part(edges_acporo_coupled(1,num_edge))
- else
- part(edges_acporo_coupled(1,num_edge)) = part(edges_acporo_coupled(2,num_edge))
- endif
- is_repartitioned = .true.
- endif
-
- enddo
- if ( .not. is_repartitioned ) then
- exit
- endif
- enddo
-
- deallocate(xadj_l,adjncy_l)
-
- end subroutine acoustic_poro_repartitioning
-
-
- !--------------------------------------------------
- ! Repartitioning : two coupled poroelastic/elastic elements are transfered to the same partition
- !--------------------------------------------------
-
- subroutine poro_elastic_repartitioning (elmnts_l, nb_materials, &
- phi_material, num_material, nproc)
-
- implicit none
- include "constants.h"
-
- integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
- integer, intent(in) :: nproc, nb_materials
- double precision, dimension(nb_materials), intent(in) :: phi_material
- integer, dimension(1:nelmnts), intent(in) :: num_material
-
- ! local parameters
- integer, dimension(:), allocatable :: xadj_l
- integer, dimension(:), allocatable :: adjncy_l
- logical, dimension(nb_materials) :: is_elastic,is_poroelastic
- integer :: i, num_edge
- integer :: el, el_adj
- logical :: is_repartitioned
-
- allocate(xadj_l(0:nelmnts))
- allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
-
- is_elastic(:) = .false.
- is_poroelastic(:) = .false.
-
- do i = 1, nb_materials
- if (phi_material(i) < TINYVAL) then
- is_elastic(i) = .true.
- endif
- if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
- is_poroelastic(i) = .true.
- endif
- enddo
-
- ! determines maximum neighbors based on 2 common nodes (common edge)
- call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
-
- nedges_elporo_coupled = 0
- do el = 0, nelmnts-1
- if ( is_poroelastic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_elporo_coupled = nedges_elporo_coupled + 1
- endif
-
- enddo
- endif
- enddo
-
- print *, 'nedges_coupled (poroelastic/elastic)', nedges_elporo_coupled
-
- allocate(edges_elporo_coupled(2,nedges_elporo_coupled))
-
- nedges_elporo_coupled = 0
- do el = 0, nelmnts-1
- if ( is_poroelastic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_elporo_coupled = nedges_elporo_coupled + 1
- edges_elporo_coupled(1,nedges_elporo_coupled) = el
- edges_elporo_coupled(2,nedges_elporo_coupled) = adjncy_l(el_adj)
- endif
-
- enddo
- endif
- enddo
-
- do i = 1, nedges_elporo_coupled*nproc
- is_repartitioned = .false.
- do num_edge = 1, nedges_elporo_coupled
- if ( part(edges_elporo_coupled(1,num_edge)) /= part(edges_elporo_coupled(2,num_edge)) ) then
- if ( part(edges_elporo_coupled(1,num_edge)) < part(edges_elporo_coupled(2,num_edge)) ) then
- part(edges_elporo_coupled(2,num_edge)) = part(edges_elporo_coupled(1,num_edge))
- else
- part(edges_elporo_coupled(1,num_edge)) = part(edges_elporo_coupled(2,num_edge))
- endif
- is_repartitioned = .true.
- endif
-
- enddo
- if ( .not. is_repartitioned ) then
- exit
- endif
- enddo
-
- deallocate(xadj_l,adjncy_l)
-
- end subroutine poro_elastic_repartitioning
-
-
- !--------------------------------------------------
- ! Write fluid/solid edges (fluid (or porous) elements and corresponding solid (or porous) elements)
- ! pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
-
- subroutine write_fluidsolid_edges_database(IIN_database, nedges_coupled_bis, nedges_coupled_loc_bis, &
- edges_coupled_bis, iproc, num_phase)
-
- implicit none
-
- integer, intent(in) :: IIN_database
- integer, intent(in) :: nedges_coupled_bis
- integer, intent(inout) :: nedges_coupled_loc_bis
- integer, dimension(:,:), pointer :: edges_coupled_bis
- integer, intent(in) :: iproc
- integer, intent(in) :: num_phase
-
- integer :: i
-
- if ( num_phase == 1 ) then
- nedges_coupled_loc_bis = 0
- do i = 1, nedges_coupled_bis
- if ( part(edges_coupled_bis(1,i)) == iproc ) then
- nedges_coupled_loc_bis = nedges_coupled_loc_bis + 1
- endif
- enddo
- else
- do i = 1, nedges_coupled_bis
- if ( part(edges_coupled_bis(1,i)) == iproc ) then
- write(IIN_database,*) glob2loc_elmnts(edges_coupled_bis(1,i))+1, glob2loc_elmnts(edges_coupled_bis(2,i))+1
- endif
- enddo
- endif
-
- end subroutine write_fluidsolid_edges_database
-
-end module part_unstruct
Deleted: seismo/2D/SPECFEM2D/trunk/src/plotgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/plotgll.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/plotgll.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,258 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
-
-! output the Gauss-Lobatto-Legendre mesh in a gnuplot file
-
- implicit none
-
- include "constants.h"
-
- integer ispec,iy,ix,iglobnum,iglobnum2,ibloc,inode,npoin,npgeo,ngnod,nspec
-
- integer knods(ngnod,nspec),ibool(NGLLX,NGLLX,nspec)
-
- double precision coorg(NDIM,npgeo),coord(NDIM,npoin)
-
-! coordinates of the nodes for Gnuplot file
- integer, parameter :: MAXNGNOD = 9
- double precision xval(MAXNGNOD),zval(MAXNGNOD)
-
- character(len=70) name
-
-!
-!---- output the GLL mesh in a Gnuplot file
-!
-
- write(iout,*)
- write(iout,*) 'Generating gnuplot meshes...'
- write(iout,*)
-
-! create non empty files for the case of 4-node elements
-
- name='macros1.gnu'
- open(unit=30,file=name,status='unknown')
-
- name='macros2.gnu'
- open(unit=31,file=name,status='unknown')
- write(31,"('')")
-
- name='gllmesh1.gnu'
- open(unit=20,file=name,status='unknown')
-
- name='gllmesh2.gnu'
- open(unit=21,file=name,status='unknown')
- write(21,"('')")
-
- do ispec = 1,nspec
-
-!
-!---- plot the lines in xi-direction
-!
- do iy = 1,NGLLZ
- do ix = 1,NGLLX-1
-!
-!---- get the global point number
-!
- iglobnum = ibool(ix,iy,ispec)
-!
-!---- do the same for next point on horizontal line
-!
- iglobnum2 = ibool(ix+1,iy,ispec)
-
- write(20,*) coord(1,iglobnum),coord(2,iglobnum)
- write(20,*) coord(1,iglobnum2),coord(2,iglobnum2)
- write(20,"('')")
-
- if(iy == 1 .or. iy == NGLLZ) then
- write(21,*) coord(1,iglobnum),coord(2,iglobnum)
- write(21,*) coord(1,iglobnum2),coord(2,iglobnum2)
- write(21,"('')")
- endif
-
- enddo
- enddo
-
-!
-!---- plot the lines in eta-direction
-!
- do ix = 1,NGLLX
- do iy = 1,NGLLZ-1
-!
-!---- get the global point number
-!
- iglobnum = ibool(ix,iy,ispec)
-!
-!---- do the same for next point on vertical line
-!
- iglobnum2 = ibool(ix,iy+1,ispec)
-
- write(20,*) coord(1,iglobnum),coord(2,iglobnum)
- write(20,*) coord(1,iglobnum2),coord(2,iglobnum2)
- write(20,"('')")
-
- if(ix == 1 .or. ix == NGLLX) then
- write(21,*) coord(1,iglobnum),coord(2,iglobnum)
- write(21,*) coord(1,iglobnum2),coord(2,iglobnum2)
- write(21,"('')")
- endif
-
- enddo
- enddo
- enddo
-
-!
-!---- plot the macrobloc mesh using Gnuplot
-!
- do ibloc = 1,nspec
- do inode = 1,ngnod
-
- xval(inode) = coorg(1,knods(inode,ibloc))
- zval(inode) = coorg(2,knods(inode,ibloc))
-
- enddo
-
- if(ngnod == 4) then
-!
-!---- 4-node rectangular element
-!
-
-! draw the edges of the element using one color
- write(30,*) xval(1),zval(1)
- write(30,*) xval(2),zval(2)
- write(30,"('')")
- write(30,*) xval(2),zval(2)
- write(30,*) xval(3),zval(3)
- write(30,"('')")
- write(30,*) xval(3),zval(3)
- write(30,*) xval(4),zval(4)
- write(30,"('')")
- write(30,*) xval(4),zval(4)
- write(30,*) xval(1),zval(1)
- write(30,"('')")
-
- else
-
-!
-!---- 9-node rectangular element
-!
-
-! draw the edges of the element using one color
- write(30,*) xval(1),zval(1)
- write(30,*) xval(5),zval(5)
- write(30,"('')")
- write(30,*) xval(5),zval(5)
- write(30,*) xval(2),zval(2)
- write(30,"('')")
- write(30,*) xval(2),zval(2)
- write(30,*) xval(6),zval(6)
- write(30,"('')")
- write(30,*) xval(6),zval(6)
- write(30,*) xval(3),zval(3)
- write(30,"('')")
- write(30,*) xval(3),zval(3)
- write(30,*) xval(7),zval(7)
- write(30,"('')")
- write(30,*) xval(7),zval(7)
- write(30,*) xval(4),zval(4)
- write(30,"('')")
- write(30,*) xval(4),zval(4)
- write(30,*) xval(8),zval(8)
- write(30,"('')")
- write(30,*) xval(8),zval(8)
- write(30,*) xval(1),zval(1)
- write(30,"('')")
-
-! draw middle lines using another color
- write(31,*) xval(5),zval(5)
- write(31,*) xval(9),zval(9)
- write(31,"('')")
- write(31,*) xval(9),zval(9)
- write(31,*) xval(7),zval(7)
- write(31,"('')")
- write(31,*) xval(8),zval(8)
- write(31,*) xval(9),zval(9)
- write(31,"('')")
- write(31,*) xval(9),zval(9)
- write(31,*) xval(6),zval(6)
- write(31,"('')")
-
- endif
-
- enddo
-
- close(20)
- close(21)
-
- close(30)
- close(31)
-
-!
-!---- generate the command file for Gnuplot
-!
- open(unit=20,file='plotall_gll_mesh.gnu',status='unknown')
- write(20,*) 'set term x11'
- write(20,*) '# set term postscript landscape color solid "Helvetica" 22'
- write(20,*) '# set output "gll_mesh.ps"'
- write(20,*) 'set xlabel "X"'
- write(20,*) 'set ylabel "Y"'
- write(20,*) 'set title "Gauss-Lobatto-Legendre Mesh"'
- write(20,*) 'plot "gllmesh1.gnu" title '''' w l 2, "gllmesh2.gnu" title '''' w linesp 1 3'
- write(20,*) 'pause -1 "Hit any key to exit..."'
- close(20)
-
- open(unit=20,file='plotall_macro_mesh.gnu',status='unknown')
- write(20,*) 'set term x11'
- write(20,*) '# set term postscript landscape color solid "Helvetica" 22'
- write(20,*) '# set output "macro_mesh.ps"'
- write(20,*) 'set xlabel "X"'
- write(20,*) 'set ylabel "Y"'
- write(20,*) 'set title "Spectral Element (Macrobloc) Mesh"'
- write(20,*) 'plot "macros2.gnu" title '''' w l 2, "macros1.gnu" title '''' w linesp 1 3'
- write(20,*) 'pause -1 "Hit any key to exit..."'
- close(20)
-
- end subroutine plotgll
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/plotpost.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/plotpost.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/plotpost.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,3070 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- 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, &
- simulation_title,npoin,npgeo,vpmin,vpmax,nrec,NSOURCES, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
- 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)
-
-!
-! PostScript display routine
-!
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include 'mpif.h'
-#endif
-
-! color palette
- integer, parameter :: NUM_COLORS = 236
- double precision, dimension(NUM_COLORS) :: red,green,blue
-
- integer it,nrec,nelemabs,numat,pointsdisp,pointsdisp_loop,nspec
- integer i,npoin,npgeo,ngnod,NSOURCES
-
- integer kmato(nspec),knods(ngnod,nspec)
- integer ibool(NGLLX,NGLLZ,nspec)
-
- double precision xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
- double precision shapeint(ngnod,pointsdisp,pointsdisp)
- double precision Uxinterp(pointsdisp,pointsdisp)
- double precision Uzinterp(pointsdisp,pointsdisp)
- double precision flagrange(NGLLX,pointsdisp)
- double precision density(2,numat),poroelastcoef(4,3,numat),porosity(numat),tortuosity(numat)
-
- double precision dt,timeval
- double precision, dimension(NSOURCES) :: x_source,z_source
- double precision displ(3,npoin),coord(NDIM,npoin)
- double precision vpext(NGLLX,NGLLZ,nspec)
-
- double precision coorg(NDIM,npgeo)
- double precision, dimension(nrec) :: st_xval,st_zval
-
- integer numabs(nelemabs),codeabs(4,nelemabs)
- logical anyabs,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
- any_acoustic,any_poroelastic,plot_lowerleft_corner_only
-
-! for fluid/solid edge detection
- 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
-
-! for the file name
- character(len=100) :: file_name
-
-! to suppress useless white spaces in postscript lines
- character(len=100) :: postscript_line
- character(len=1), dimension(100) :: ch1,ch2
- equivalence (postscript_line,ch1)
- logical :: first
-
- double precision convert,x1,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
- double precision :: kappal_f,rhol_f
- double precision :: mul_fr,kappal_fr,phil,tortl
- double precision :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,rhol_bar
- double precision :: cpIsquare
-
- integer k,j,ispec,material,is,ir,imat,icol,l,line_length
- integer index_char,ii,ipoin,in,nnum,inum,ideb,ifin,iedge
-
- integer colors,numbers,subsamp,imagetype
- logical interpol,meshvect,modelvect,boundvect,assign_external_model
- double precision cutsnaps,sizemax_arrows
-
- double precision ratio_page,dispmax,xmin,zmin
-
-! title of the plot
- character(len=60) simulation_title
-
-! for free surface output
- integer :: nelem_acoustic_surface
- integer, dimension(4,max(1,nelem_acoustic_surface)) :: acoustic_edges
-
-#ifdef USE_MPI
- double precision :: xmin_glob, xmax_glob, zmin_glob, zmax_glob
- double precision :: dispmax_glob
-#endif
-
- double precision, dimension(:,:), allocatable :: coorg_send
- double precision, dimension(:,:), allocatable :: coorg_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, coupled_acoustic_poro_glob, &
- coupled_elastic_poro_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
-! 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)
-#endif
-
-! A4 or US letter paper
- if(US_LETTER) then
- usoffset = 1.75d0
- sizex = 27.94d0
- sizez = 21.59d0
- else
- usoffset = 0.d0
- sizex = 29.7d0
- sizez = 21.d0
- endif
-
-! height of domain numbers in centimeters
- height = 0.25d0
-
-! define color palette in random order
-
-! red
- red(1) = 1.00000000000000
- green(1) = 0.000000000000000E+000
- blue(1) = 0.000000000000000E+000
-
-! DodgerBlue2
- red(2) = 0.109803921568627
- green(2) = 0.525490196078431
- blue(2) = 0.933333333333333
-
-! gold
- red(3) = 1.00000000000000
- green(3) = 0.840000000000000
- blue(3) = 0.000000000000000E+000
-
-! springgreen
- red(4) = 0.000000000000000E+000
- green(4) = 1.00000000000000
- blue(4) = 0.500000000000000
-
-! NavajoWhite
- red(5) = 1.00000000000000
- green(5) = 0.870588235294118
- blue(5) = 0.678431372549020
-
-! SteelBlue3
- red(6) = 0.309803921568627
- green(6) = 0.580392156862745
- blue(6) = 0.803921568627451
-
-! Ivory3
- red(7) = 0.803921568627451
- green(7) = 0.803921568627451
- blue(7) = 0.756862745098039
-
-! SkyBlue4
- red(8) = 0.290196078431373
- green(8) = 0.439215686274510
- blue(8) = 0.545098039215686
-
-! Snow
- red(9) = 0.980392156862745
- green(9) = 0.980392156862745
- blue(9) = 0.980392156862745
-
-! SteelBlue
- red(10) = 0.274509803921569
- green(10) = 0.509803921568627
- blue(10) = 0.705882352941177
-
-! Bisque3
- red(11) = 0.803921568627451
- green(11) = 0.717647058823529
- blue(11) = 0.619607843137255
-
-! Salmon
- red(12) = 0.980392156862745
- green(12) = 0.501960784313725
- blue(12) = 0.447058823529412
-
-! SlateBlue2
- red(13) = 0.478431372549020
- green(13) = 0.403921568627451
- blue(13) = 0.933333333333333
-
-! NavajoWhite2
- red(14) = 0.933333333333333
- green(14) = 0.811764705882353
- blue(14) = 0.631372549019608
-
-! MediumBlue
- red(15) = 0.000000000000000E+000
- green(15) = 0.000000000000000E+000
- blue(15) = 0.803921568627451
-
-! LightCoral
- red(16) = 0.941176470588235
- green(16) = 0.501960784313725
- blue(16) = 0.501960784313725
-
-! FloralWhite
- red(17) = 1.00000000000000
- green(17) = 0.980392156862745
- blue(17) = 0.941176470588235
-
-! Cornsilk3
- red(18) = 0.803921568627451
- green(18) = 0.784313725490196
- blue(18) = 0.694117647058824
-
-! GhostWhite
- red(19) = 0.972549019607843
- green(19) = 0.972549019607843
- blue(19) = 1.00000000000000
-
-! blue
- red(20) = 0.000000000000000E+000
- green(20) = 0.000000000000000E+000
- blue(20) = 1.00000000000000
-
-! Linen
- red(21) = 0.980392156862745
- green(21) = 0.941176470588235
- blue(21) = 0.901960784313726
-
-! peachpuff
- red(22) = 1.00000000000000
- green(22) = 0.850000000000000
- blue(22) = 0.730000000000000
-
-! Cornsilk1
- red(23) = 1.00000000000000
- green(23) = 0.972549019607843
- blue(23) = 0.862745098039216
-
-! LightSalmon
- red(24) = 1.00000000000000
- green(24) = 0.627450980392157
- blue(24) = 0.478431372549020
-
-! DeepSkyBlue1
- red(25) = 0.000000000000000E+000
- green(25) = 0.749019607843137
- blue(25) = 1.00000000000000
-
-! LemonChiffon4
- red(26) = 0.545098039215686
- green(26) = 0.537254901960784
- blue(26) = 0.439215686274510
-
-! PeachPuff1
- red(27) = 1.00000000000000
- green(27) = 0.854901960784314
- blue(27) = 0.725490196078431
-
-! BlanchedAlmond
- red(28) = 1.00000000000000
- green(28) = 0.921568627450980
- blue(28) = 0.803921568627451
-
-! SlateBlue3
- red(29) = 0.411764705882353
- green(29) = 0.349019607843137
- blue(29) = 0.803921568627451
-
-! LightSkyBlue1
- red(30) = 0.690196078431373
- green(30) = 0.886274509803922
- blue(30) = 1.00000000000000
-
-! DarkViolet
- red(31) = 0.580392156862745
- green(31) = 0.000000000000000E+000
- blue(31) = 0.827450980392157
-
-! Azure3
- red(32) = 0.756862745098039
- green(32) = 0.803921568627451
- blue(32) = 0.803921568627451
-
-! LavenderBlush3
- red(33) = 0.803921568627451
- green(33) = 0.756862745098039
- blue(33) = 0.772549019607843
-
-! Honeydew1
- red(34) = 0.941176470588235
- green(34) = 1.00000000000000
- blue(34) = 0.941176470588235
-
-! Ivory2
- red(35) = 0.933333333333333
- green(35) = 0.933333333333333
- blue(35) = 0.878431372549020
-
-! RosyBrown
- red(36) = 0.737254901960784
- green(36) = 0.560784313725490
- blue(36) = 0.560784313725490
-
-! Thistle
- red(37) = 0.847058823529412
- green(37) = 0.749019607843137
- blue(37) = 0.847058823529412
-
-! Orange
- red(38) = 1.00000000000000
- green(38) = 0.647058823529412
- blue(38) = 0.000000000000000E+000
-
-! DarkSeaGreen
- red(39) = 0.560784313725490
- green(39) = 0.737254901960784
- blue(39) = 0.560784313725490
-
-! Moccasin
- red(40) = 1.00000000000000
- green(40) = 0.894117647058824
- blue(40) = 0.709803921568627
-
-! DeepSkyBlue2
- red(41) = 0.000000000000000E+000
- green(41) = 0.698039215686274
- blue(41) = 0.933333333333333
-
-! SlateGray4
- red(42) = 0.423529411764706
- green(42) = 0.482352941176471
- blue(42) = 0.545098039215686
-
-! Beige
- red(43) = 0.960784313725490
- green(43) = 0.960784313725490
- blue(43) = 0.862745098039216
-
-! Gold
- red(44) = 1.00000000000000
- green(44) = 0.843137254901961
- blue(44) = 0.000000000000000E+000
-
-! SlateBlue
- red(45) = 0.415686274509804
- green(45) = 0.352941176470588
- blue(45) = 0.803921568627451
-
-! SteelBlue1
- red(46) = 0.388235294117647
- green(46) = 0.721568627450980
- blue(46) = 1.00000000000000
-
-! SaddleBrown
- red(47) = 0.545098039215686
- green(47) = 0.270588235294118
- blue(47) = 7.450980392156863E-002
-
-! Pink
- red(48) = 1.00000000000000
- green(48) = 0.752941176470588
- blue(48) = 0.796078431372549
-
-! Black
- red(49) = 0.000000000000000E+000
- green(49) = 0.000000000000000E+000
- blue(49) = 0.000000000000000E+000
-
-! SlateGrey
- red(50) = 0.439215686274510
- green(50) = 0.501960784313725
- blue(50) = 0.564705882352941
-
-! Ivory
- red(51) = 1.00000000000000
- green(51) = 1.00000000000000
- blue(51) = 0.941176470588235
-
-! OliveDrab
- red(52) = 0.419607843137255
- green(52) = 0.556862745098039
- blue(52) = 0.137254901960784
-
-! Ivory1
- red(53) = 1.00000000000000
- green(53) = 1.00000000000000
- blue(53) = 0.941176470588235
-
-! SkyBlue
- red(54) = 0.529411764705882
- green(54) = 0.807843137254902
- blue(54) = 0.921568627450980
-
-! MistyRose3
- red(55) = 0.803921568627451
- green(55) = 0.717647058823529
- blue(55) = 0.709803921568627
-
-! LimeGreen
- red(56) = 0.196078431372549
- green(56) = 0.803921568627451
- blue(56) = 0.196078431372549
-
-! Purple
- red(57) = 0.627450980392157
- green(57) = 0.125490196078431
- blue(57) = 0.941176470588235
-
-! SkyBlue2
- red(58) = 0.494117647058824
- green(58) = 0.752941176470588
- blue(58) = 0.933333333333333
-
-! Red
- red(59) = 1.00000000000000
- green(59) = 0.000000000000000E+000
- blue(59) = 0.000000000000000E+000
-
-! DarkKhaki
- red(60) = 0.741176470588235
- green(60) = 0.717647058823529
- blue(60) = 0.419607843137255
-
-! MediumTurquoise
- red(61) = 0.282352941176471
- green(61) = 0.819607843137255
- blue(61) = 0.800000000000000
-
-! Grey
- red(62) = 0.745098039215686
- green(62) = 0.745098039215686
- blue(62) = 0.745098039215686
-
-! Coral
- red(63) = 1.00000000000000
- green(63) = 0.498039215686275
- blue(63) = 0.313725490196078
-
-! NavajoWhite4
- red(64) = 0.545098039215686
- green(64) = 0.474509803921569
- blue(64) = 0.368627450980392
-
-! SlateBlue4
- red(65) = 0.278431372549020
- green(65) = 0.235294117647059
- blue(65) = 0.545098039215686
-
-! RoyalBlue4
- red(66) = 0.152941176470588
- green(66) = 0.250980392156863
- blue(66) = 0.545098039215686
-
-! YellowGreen
- red(67) = 0.603921568627451
- green(67) = 0.803921568627451
- blue(67) = 0.196078431372549
-
-! DeepSkyBlue3
- red(68) = 0.000000000000000E+000
- green(68) = 0.603921568627451
- blue(68) = 0.803921568627451
-
-! goldenrod
- red(69) = 0.854901960784314
- green(69) = 0.647058823529412
- blue(69) = 0.125490196078431
-
-! AntiqueWhite4
- red(70) = 0.545098039215686
- green(70) = 0.513725490196078
- blue(70) = 0.470588235294118
-
-! lemonchiffon
- red(71) = 1.00000000000000
- green(71) = 0.980000000000000
- blue(71) = 0.800000000000000
-
-! GreenYellow
- red(72) = 0.678431372549020
- green(72) = 1.00000000000000
- blue(72) = 0.184313725490196
-
-! LightSlateGray
- red(73) = 0.466666666666667
- green(73) = 0.533333333333333
- blue(73) = 0.600000000000000
-
-! RoyalBlue
- red(74) = 0.254901960784314
- green(74) = 0.411764705882353
- blue(74) = 0.882352941176471
-
-! DarkGreen
- red(75) = 0.000000000000000E+000
- green(75) = 0.392156862745098
- blue(75) = 0.000000000000000E+000
-
-! NavajoWhite3
- red(76) = 0.803921568627451
- green(76) = 0.701960784313725
- blue(76) = 0.545098039215686
-
-! Azure1
- red(77) = 0.941176470588235
- green(77) = 1.00000000000000
- blue(77) = 1.00000000000000
-
-! PowderBlue
- red(78) = 0.690196078431373
- green(78) = 0.878431372549020
- blue(78) = 0.901960784313726
-
-! slateblue
- red(79) = 0.420000000000000
- green(79) = 0.350000000000000
- blue(79) = 0.800000000000000
-
-! MediumOrchid
- red(80) = 0.729411764705882
- green(80) = 0.333333333333333
- blue(80) = 0.827450980392157
-
-! turquoise
- red(81) = 0.250000000000000
- green(81) = 0.880000000000000
- blue(81) = 0.820000000000000
-
-! Snow1
- red(82) = 1.00000000000000
- green(82) = 0.980392156862745
- blue(82) = 0.980392156862745
-
-! violet
- red(83) = 0.930000000000000
- green(83) = 0.510000000000000
- blue(83) = 0.930000000000000
-
-! DeepPink
- red(84) = 1.00000000000000
- green(84) = 7.843137254901961E-002
- blue(84) = 0.576470588235294
-
-! MistyRose4
- red(85) = 0.545098039215686
- green(85) = 0.490196078431373
- blue(85) = 0.482352941176471
-
-! PeachPuff3
- red(86) = 0.803921568627451
- green(86) = 0.686274509803922
- blue(86) = 0.584313725490196
-
-! MediumSeaGreen
- red(87) = 0.235294117647059
- green(87) = 0.701960784313725
- blue(87) = 0.443137254901961
-
-! Honeydew4
- red(88) = 0.513725490196078
- green(88) = 0.545098039215686
- blue(88) = 0.513725490196078
-
-! Tan
- red(89) = 0.823529411764706
- green(89) = 0.705882352941177
- blue(89) = 0.549019607843137
-
-! DarkGoldenrod
- red(90) = 0.721568627450980
- green(90) = 0.525490196078431
- blue(90) = 4.313725490196078E-002
-
-! Blue2
- red(91) = 0.000000000000000E+000
- green(91) = 0.000000000000000E+000
- blue(91) = 0.933333333333333
-
-! Maroon
- red(92) = 0.690196078431373
- green(92) = 0.188235294117647
- blue(92) = 0.376470588235294
-
-! LightSkyBlue3
- red(93) = 0.552941176470588
- green(93) = 0.713725490196078
- blue(93) = 0.803921568627451
-
-! LemonChiffon2
- red(94) = 0.933333333333333
- green(94) = 0.913725490196078
- blue(94) = 0.749019607843137
-
-! Snow3
- red(95) = 0.803921568627451
- green(95) = 0.788235294117647
- blue(95) = 0.788235294117647
-
-! Ivory4
- red(96) = 0.545098039215686
- green(96) = 0.545098039215686
- blue(96) = 0.513725490196078
-
-! AntiqueWhite3
- red(97) = 0.803921568627451
- green(97) = 0.752941176470588
- blue(97) = 0.690196078431373
-
-! Bisque4
- red(98) = 0.545098039215686
- green(98) = 0.490196078431373
- blue(98) = 0.419607843137255
-
-! Snow2
- red(99) = 0.933333333333333
- green(99) = 0.913725490196078
- blue(99) = 0.913725490196078
-
-! SlateGray1
- red(100) = 0.776470588235294
- green(100) = 0.886274509803922
- blue(100) = 1.00000000000000
-
-! Seashell2
- red(101) = 0.933333333333333
- green(101) = 0.898039215686275
- blue(101) = 0.870588235294118
-
-! Aquamarine
- red(102) = 0.498039215686275
- green(102) = 1.00000000000000
- blue(102) = 0.831372549019608
-
-! SlateGray2
- red(103) = 0.725490196078431
- green(103) = 0.827450980392157
- blue(103) = 0.933333333333333
-
-! White
- red(104) = 1.00000000000000
- green(104) = 1.00000000000000
- blue(104) = 1.00000000000000
-
-! LavenderBlush
- red(105) = 1.00000000000000
- green(105) = 0.941176470588235
- blue(105) = 0.960784313725490
-
-! DodgerBlue3
- red(106) = 9.411764705882353E-002
- green(106) = 0.454901960784314
- blue(106) = 0.803921568627451
-
-! RoyalBlue3
- red(107) = 0.227450980392157
- green(107) = 0.372549019607843
- blue(107) = 0.803921568627451
-
-! LightYellow
- red(108) = 1.00000000000000
- green(108) = 1.00000000000000
- blue(108) = 0.878431372549020
-
-! DeepSkyBlue
- red(109) = 0.000000000000000E+000
- green(109) = 0.749019607843137
- blue(109) = 1.00000000000000
-
-! AntiqueWhite2
- red(110) = 0.933333333333333
- green(110) = 0.874509803921569
- blue(110) = 0.800000000000000
-
-! CornflowerBlue
- red(111) = 0.392156862745098
- green(111) = 0.584313725490196
- blue(111) = 0.929411764705882
-
-! PeachPuff4
- red(112) = 0.545098039215686
- green(112) = 0.466666666666667
- blue(112) = 0.396078431372549
-
-! SpringGreen
- red(113) = 0.000000000000000E+000
- green(113) = 1.00000000000000
- blue(113) = 0.498039215686275
-
-! Honeydew
- red(114) = 0.941176470588235
- green(114) = 1.00000000000000
- blue(114) = 0.941176470588235
-
-! Honeydew2
- red(115) = 0.878431372549020
- green(115) = 0.933333333333333
- blue(115) = 0.878431372549020
-
-! LightSeaGreen
- red(116) = 0.125490196078431
- green(116) = 0.698039215686274
- blue(116) = 0.666666666666667
-
-! NavyBlue
- red(117) = 0.000000000000000E+000
- green(117) = 0.000000000000000E+000
- blue(117) = 0.501960784313725
-
-! Azure4
- red(118) = 0.513725490196078
- green(118) = 0.545098039215686
- blue(118) = 0.545098039215686
-
-! MediumAquamarine
- red(119) = 0.400000000000000
- green(119) = 0.803921568627451
- blue(119) = 0.666666666666667
-
-! SkyBlue3
- red(120) = 0.423529411764706
- green(120) = 0.650980392156863
- blue(120) = 0.803921568627451
-
-! LavenderBlush2
- red(121) = 0.933333333333333
- green(121) = 0.878431372549020
- blue(121) = 0.898039215686275
-
-! Bisque1
- red(122) = 1.00000000000000
- green(122) = 0.894117647058824
- blue(122) = 0.768627450980392
-
-! DarkOrange
- red(123) = 1.00000000000000
- green(123) = 0.549019607843137
- blue(123) = 0.000000000000000E+000
-
-! LightSteelBlue
- red(124) = 0.690196078431373
- green(124) = 0.768627450980392
- blue(124) = 0.870588235294118
-
-! SteelBlue2
- red(125) = 0.360784313725490
- green(125) = 0.674509803921569
- blue(125) = 0.933333333333333
-
-! LemonChiffon3
- red(126) = 0.803921568627451
- green(126) = 0.788235294117647
- blue(126) = 0.647058823529412
-
-! DarkSlateBlue
- red(127) = 0.282352941176471
- green(127) = 0.239215686274510
- blue(127) = 0.545098039215686
-
-! Seashell
- red(128) = 1.00000000000000
- green(128) = 0.960784313725490
- blue(128) = 0.933333333333333
-
-! Firebrick
- red(129) = 0.698039215686274
- green(129) = 0.133333333333333
- blue(129) = 0.133333333333333
-
-! LightGray
- red(130) = 0.827450980392157
- green(130) = 0.827450980392157
- blue(130) = 0.827450980392157
-
-! Blue
- red(131) = 0.000000000000000E+000
- green(131) = 0.000000000000000E+000
- blue(131) = 1.00000000000000
-
-! Bisque2
- red(132) = 0.933333333333333
- green(132) = 0.835294117647059
- blue(132) = 0.717647058823529
-
-! WhiteSmoke
- red(133) = 0.960784313725490
- green(133) = 0.960784313725490
- blue(133) = 0.960784313725490
-
-! SeaGreen
- red(134) = 0.180392156862745
- green(134) = 0.545098039215686
- blue(134) = 0.341176470588235
-
-! Burlywood
- red(135) = 0.870588235294118
- green(135) = 0.721568627450980
- blue(135) = 0.529411764705882
-
-! RoyalBlue2
- red(136) = 0.262745098039216
- green(136) = 0.431372549019608
- blue(136) = 0.933333333333333
-
-! RoyalBlue1
- red(137) = 0.282352941176471
- green(137) = 0.462745098039216
- blue(137) = 1.00000000000000
-
-! SteelBlue4
- red(138) = 0.211764705882353
- green(138) = 0.392156862745098
- blue(138) = 0.545098039215686
-
-! AliceBlue
- red(139) = 0.941176470588235
- green(139) = 0.972549019607843
- blue(139) = 1.00000000000000
-
-! LightSlateBlue
- red(140) = 0.517647058823529
- green(140) = 0.439215686274510
- blue(140) = 1.00000000000000
-
-! MistyRose1
- red(141) = 1.00000000000000
- green(141) = 0.894117647058824
- blue(141) = 0.882352941176471
-
-! SandyBrown
- red(142) = 0.956862745098039
- green(142) = 0.643137254901961
- blue(142) = 0.376470588235294
-
-! DarkOliveGreen
- red(143) = 0.333333333333333
- green(143) = 0.419607843137255
- blue(143) = 0.184313725490196
-
-! Yellow
- red(144) = 1.00000000000000
- green(144) = 1.00000000000000
- blue(144) = 0.000000000000000E+000
-
-! SlateGray3
- red(145) = 0.623529411764706
- green(145) = 0.713725490196078
- blue(145) = 0.803921568627451
-
-! HotPink
- red(146) = 1.00000000000000
- green(146) = 0.411764705882353
- blue(146) = 0.705882352941177
-
-! Violet
- red(147) = 0.933333333333333
- green(147) = 0.509803921568627
- blue(147) = 0.933333333333333
-
-! LightSkyBlue
- red(148) = 0.529411764705882
- green(148) = 0.807843137254902
- blue(148) = 0.980392156862745
-
-! Cornsilk2
- red(149) = 0.933333333333333
- green(149) = 0.909803921568627
- blue(149) = 0.803921568627451
-
-! MidnightBlue
- red(150) = 9.803921568627451E-002
- green(150) = 9.803921568627451E-002
- blue(150) = 0.439215686274510
-
-! AntiqueWhite
- red(151) = 0.980392156862745
- green(151) = 0.921568627450980
- blue(151) = 0.843137254901961
-
-! PaleGreen
- red(152) = 0.596078431372549
- green(152) = 0.984313725490196
- blue(152) = 0.596078431372549
-
-! MedSpringGreen
- red(153) = 0.000000000000000E+000
- green(153) = 0.980392156862745
- blue(153) = 0.603921568627451
-
-! DodgerBlue1
- red(154) = 0.117647058823529
- green(154) = 0.564705882352941
- blue(154) = 1.00000000000000
-
-! Blue3
- red(155) = 0.000000000000000E+000
- green(155) = 0.000000000000000E+000
- blue(155) = 0.803921568627451
-
-! Cyan
- red(156) = 0.000000000000000E+000
- green(156) = 1.00000000000000
- blue(156) = 1.00000000000000
-
-! LemonChiffon
- red(157) = 1.00000000000000
- green(157) = 0.980392156862745
- blue(157) = 0.803921568627451
-
-! mediumorchid
- red(158) = 0.730000000000000
- green(158) = 0.330000000000000
- blue(158) = 0.830000000000000
-
-! Turquoise
- red(159) = 0.250980392156863
- green(159) = 0.878431372549020
- blue(159) = 0.815686274509804
-
-! IndianRed
- red(160) = 0.803921568627451
- green(160) = 0.360784313725490
- blue(160) = 0.360784313725490
-
-! DodgerBlue
- red(161) = 0.117647058823529
- green(161) = 0.564705882352941
- blue(161) = 1.00000000000000
-
-! Seashell3
- red(162) = 0.803921568627451
- green(162) = 0.772549019607843
- blue(162) = 0.749019607843137
-
-! BlueViolet
- red(163) = 0.541176470588235
- green(163) = 0.168627450980392
- blue(163) = 0.886274509803922
-
-! DeepSkyBlue4
- red(164) = 0.000000000000000E+000
- green(164) = 0.407843137254902
- blue(164) = 0.545098039215686
-
-! PaleVioletRed
- red(165) = 0.858823529411765
- green(165) = 0.439215686274510
- blue(165) = 0.576470588235294
-
-! Azure2
- red(166) = 0.878431372549020
- green(166) = 0.933333333333333
- blue(166) = 0.933333333333333
-
-! greenyellow
- red(167) = 0.680000000000000
- green(167) = 1.00000000000000
- blue(167) = 0.180000000000000
-
-! LightGoldenrod
- red(168) = 0.933333333333333
- green(168) = 0.866666666666667
- blue(168) = 0.509803921568627
-
-! MistyRose
- red(169) = 1.00000000000000
- green(169) = 0.894117647058824
- blue(169) = 0.882352941176471
-
-! LightSkyBlue4
- red(170) = 0.376470588235294
- green(170) = 0.482352941176471
- blue(170) = 0.545098039215686
-
-! OrangeRed
- red(171) = 1.00000000000000
- green(171) = 0.270588235294118
- blue(171) = 0.000000000000000E+000
-
-! DimGrey
- red(172) = 0.411764705882353
- green(172) = 0.411764705882353
- blue(172) = 0.411764705882353
-
-! MediumVioletRed
- red(173) = 0.780392156862745
- green(173) = 8.235294117647059E-002
- blue(173) = 0.521568627450980
-
-! DarkSlateGray
- red(174) = 0.184313725490196
- green(174) = 0.309803921568627
- blue(174) = 0.309803921568627
-
-! yellow
- red(175) = 1.00000000000000
- green(175) = 1.00000000000000
- blue(175) = 0.000000000000000E+000
-
-! Plum
- red(176) = 0.866666666666667
- green(176) = 0.627450980392157
- blue(176) = 0.866666666666667
-
-! DarkTurquoise
- red(177) = 0.000000000000000E+000
- green(177) = 0.807843137254902
- blue(177) = 0.819607843137255
-
-! DodgerBlue4
- red(178) = 6.274509803921569E-002
- green(178) = 0.305882352941176
- blue(178) = 0.545098039215686
-
-! Cornsilk
- red(179) = 1.00000000000000
- green(179) = 0.972549019607843
- blue(179) = 0.862745098039216
-
-! SkyBlue1
- red(180) = 0.529411764705882
- green(180) = 0.807843137254902
- blue(180) = 1.00000000000000
-
-! Seashell1
- red(181) = 1.00000000000000
- green(181) = 0.960784313725490
- blue(181) = 0.933333333333333
-
-! lavender
- red(182) = 0.901960784313726
- green(182) = 0.901960784313726
- blue(182) = 0.980392156862745
-
-! Snow4
- red(183) = 0.545098039215686
- green(183) = 0.537254901960784
- blue(183) = 0.537254901960784
-
-! Peru
- red(184) = 0.803921568627451
- green(184) = 0.521568627450980
- blue(184) = 0.247058823529412
-
-! PeachPuff
- red(185) = 1.00000000000000
- green(185) = 0.854901960784314
- blue(185) = 0.725490196078431
-
-! Green
- red(186) = 0.000000000000000E+000
- green(186) = 1.00000000000000
- blue(186) = 0.000000000000000E+000
-
-! Blue1
- red(187) = 0.000000000000000E+000
- green(187) = 0.000000000000000E+000
- blue(187) = 1.00000000000000
-
-! Seashell4
- red(188) = 0.545098039215686
- green(188) = 0.525490196078431
- blue(188) = 0.509803921568627
-
-! dodgerblue
- red(189) = 0.120000000000000
- green(189) = 0.560000000000000
- blue(189) = 1.00000000000000
-
-! MistyRose2
- red(190) = 0.933333333333333
- green(190) = 0.835294117647059
- blue(190) = 0.823529411764706
-
-! Tomato
- red(191) = 1.00000000000000
- green(191) = 0.388235294117647
- blue(191) = 0.278431372549020
-
-! Wheat
- red(192) = 0.960784313725490
- green(192) = 0.870588235294118
- blue(192) = 0.701960784313725
-
-! LightBlue
- red(193) = 0.678431372549020
- green(193) = 0.847058823529412
- blue(193) = 0.901960784313726
-
-! Chocolate
- red(194) = 0.823529411764706
- green(194) = 0.411764705882353
- blue(194) = 0.117647058823529
-
-! Blue4
- red(195) = 0.000000000000000E+000
- green(195) = 0.000000000000000E+000
- blue(195) = 0.545098039215686
-
-! LavenderBlush1
- red(196) = 1.00000000000000
- green(196) = 0.941176470588235
- blue(196) = 0.960784313725490
-
-! Magenta
- red(197) = 1.00000000000000
- green(197) = 0.000000000000000E+000
- blue(197) = 1.00000000000000
-
-! darkturquoise
- red(198) = 0.000000000000000E+000
- green(198) = 0.810000000000000
- blue(198) = 0.820000000000000
-
-! blueviolet
- red(199) = 0.540000000000000
- green(199) = 0.170000000000000
- blue(199) = 0.890000000000000
-
-! MintCream
- red(200) = 0.960784313725490
- green(200) = 1.00000000000000
- blue(200) = 0.980392156862745
-
-! PaleGoldenrod
- red(201) = 0.933333333333333
- green(201) = 0.909803921568627
- blue(201) = 0.666666666666667
-
-! MediumPurple
- red(202) = 0.576470588235294
- green(202) = 0.439215686274510
- blue(202) = 0.858823529411765
-
-! PapayaWhip
- red(203) = 1.00000000000000
- green(203) = 0.937254901960784
- blue(203) = 0.835294117647059
-
-! LavenderBlush4
- red(204) = 0.545098039215686
- green(204) = 0.513725490196078
- blue(204) = 0.525490196078431
-
-! Cornsilk4
- red(205) = 0.545098039215686
- green(205) = 0.533333333333333
- blue(205) = 0.470588235294118
-
-! LtGoldenrodYello
- red(206) = 0.980392156862745
- green(206) = 0.980392156862745
- blue(206) = 0.823529411764706
-
-! limegreen
- red(207) = 0.200000000000000
- green(207) = 0.800000000000000
- blue(207) = 0.200000000000000
-
-! LemonChiffon1
- red(208) = 1.00000000000000
- green(208) = 0.980392156862745
- blue(208) = 0.803921568627451
-
-! DarkOrchid
- red(209) = 0.600000000000000
- green(209) = 0.196078431372549
- blue(209) = 0.800000000000000
-
-! SlateBlue1
- red(210) = 0.513725490196078
- green(210) = 0.435294117647059
- blue(210) = 1.00000000000000
-
-! chartreuse
- red(211) = 0.500000000000000
- green(211) = 1.00000000000000
- blue(211) = 0.000000000000000E+000
-
-! PaleTurquoise
- red(212) = 0.686274509803922
- green(212) = 0.933333333333333
- blue(212) = 0.933333333333333
-
-! NavajoWhite1
- red(213) = 1.00000000000000
- green(213) = 0.870588235294118
- blue(213) = 0.678431372549020
-
-! LightSkyBlue2
- red(214) = 0.643137254901961
- green(214) = 0.827450980392157
- blue(214) = 0.933333333333333
-
-! VioletRed
- red(215) = 0.815686274509804
- green(215) = 0.125490196078431
- blue(215) = 0.564705882352941
-
-! mocassin
- red(216) = 1.00000000000000
- green(216) = 0.890000000000000
- blue(216) = 0.710000000000000
-
-! OldLace
- red(217) = 0.992156862745098
- green(217) = 0.960784313725490
- blue(217) = 0.901960784313726
-
-! deeppink
- red(218) = 1.00000000000000
- green(218) = 8.000000000000000E-002
- blue(218) = 0.580000000000000
-
-! Honeydew3
- red(219) = 0.756862745098039
- green(219) = 0.803921568627451
- blue(219) = 0.756862745098039
-
-! Gainsboro
- red(220) = 0.862745098039216
- green(220) = 0.862745098039216
- blue(220) = 0.862745098039216
-
-! DarkSalmon
- red(221) = 0.913725490196078
- green(221) = 0.588235294117647
- blue(221) = 0.478431372549020
-
-! AntiqueWhite1
- red(222) = 1.00000000000000
- green(222) = 0.937254901960784
- blue(222) = 0.858823529411765
-
-! LightCyan
- red(223) = 0.878431372549020
- green(223) = 1.00000000000000
- blue(223) = 1.00000000000000
-
-! ForestGreen
- red(224) = 0.133333333333333
- green(224) = 0.545098039215686
- blue(224) = 0.133333333333333
-
-! Orchid
- red(225) = 0.854901960784314
- green(225) = 0.439215686274510
- blue(225) = 0.839215686274510
-
-! PeachPuff2
- red(226) = 0.933333333333333
- green(226) = 0.796078431372549
- blue(226) = 0.678431372549020
-
-! LightPink
- red(227) = 1.00000000000000
- green(227) = 0.713725490196078
- blue(227) = 0.756862745098039
-
-! Sienna
- red(228) = 0.627450980392157
- green(228) = 0.321568627450980
- blue(228) = 0.176470588235294
-
-! darkorchid
- red(229) = 0.600000000000000
- green(229) = 0.200000000000000
- blue(229) = 0.800000000000000
-
-! MediumSlateBlue
- red(230) = 0.482352941176471
- green(230) = 0.407843137254902
- blue(230) = 0.933333333333333
-
-! CadetBlue
- red(231) = 0.372549019607843
- green(231) = 0.619607843137255
- blue(231) = 0.627450980392157
-
-! LawnGreen
- red(232) = 0.486274509803922
- green(232) = 0.988235294117647
- blue(232) = 0.000000000000000E+000
-
-! Chartreuse
- red(233) = 0.498039215686275
- green(233) = 1.00000000000000
- blue(233) = 0.000000000000000E+000
-
-! Brown
- red(234) = 0.647058823529412
- green(234) = 0.164705882352941
- blue(234) = 0.164705882352941
-
-! Azure
- red(235) = 0.941176470588235
- green(235) = 1.00000000000000
- blue(235) = 1.00000000000000
-
-! Bisque
- red(236) = 1.00000000000000
- green(236) = 0.894117647058824
- blue(236) = 0.768627450980392
-
-! get minimum and maximum values of mesh coordinates
- xmin = minval(coord(1,:))
- zmin = minval(coord(2,:))
- xmax = maxval(coord(1,:))
- zmax = maxval(coord(2,:))
-
-#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
-
- if ( myrank == 0 ) then
- write(IOUT,*) 'X min, max = ',xmin,xmax
- write(IOUT,*) 'Z min, max = ',zmin,zmax
- endif
-
-! ratio of physical page size/size of the domain meshed
- ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
-
-! compute the maximum of the norm of the vector
- dispmax = maxval(sqrt(displ(1,:)**2 + displ(3,:)**2))
-#ifdef USE_MPI
- call MPI_ALLREDUCE (dispmax, dispmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- dispmax = dispmax_glob
-#endif
- if ( myrank == 0 ) then
- write(IOUT,*) 'Max norm = ',dispmax
- endif
-
-!
-!---- open PostScript file
-!
- if ( myrank == 0 ) then
- write(file_name,"('OUTPUT_FILES/vect',i7.7,'.ps')") it
- open(unit=24,file=file_name,status='unknown')
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% gray levels for the velocity model'
- write(24,*) '/BK {setgray fill} def'
- write(24,*) '% black and white version'
- write(24,*) '%/BK {pop 1 setgray fill} def'
- write(24,*) '%'
- write(24,*) '% magenta for vectors'
- write(24,*) '/Colvects {0 setlinewidth 1. 0. 1. RG} def'
- write(24,*) '% black and white version'
- write(24,*) '%/Colvects {0 setlinewidth 0. setgray} def'
- write(24,*) '%'
- write(24,*) '% chartreuse for macrobloc mesh'
- write(24,*) '/Colmesh {0 setlinewidth 0.5 1. 0. RG} def'
- write(24,*) '% black and white version'
- write(24,*) '%/Colmesh {0 setlinewidth 0. setgray} def'
- write(24,*) '%'
- write(24,*) '% cyan for sources and receivers'
- write(24,*) '/Colreceiv {0. 1. 1. RG} def'
- write(24,*) '% black and white version'
- write(24,*) '%/Colreceiv {0. setgray} def'
- write(24,*) '%'
- write(24,*) '% macro to draw an arrow'
- write(24,*) '/F {MV LR gsave LR ST grestore LR ST} def'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '0 setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- write(24,*) '%'
- write(24,*) '/vshift ',-height/2,' CM def'
- write(24,*) '/Rshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop neg vshift MR show } def'
- write(24,*) '/Cshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
- write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '% uncomment this to zoom on parts of the mesh'
- write(24,*) '% -32 CM -21 CM translate 3. 3. scale'
- write(24,*) '% -52 CM -24 CM translate 4. 4. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '24. CM 1.2 CM MV'
- write(24,610) usoffset,it
- write(24,*) '%'
-
- write(24,*) '24. CM 1.95 CM MV'
- timeval = it*dt
- if(timeval >= 1.d-3 .and. timeval < 1000.d0) then
- write(24,600) usoffset,timeval
- else
- write(24,601) usoffset,timeval
- endif
- write(24,*) '%'
- write(24,*) '24. CM 2.7 CM MV'
- write(24,640) usoffset,dispmax
- write(24,*) '%'
- write(24,*) '24. CM 3.45 CM MV'
- write(24,620) usoffset,cutsnaps*100.d0
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- if(colors == 1) write(24,*) '.4 .9 .9 setrgbcolor'
- write(24,*) '11 CM 1.1 CM MV'
- write(24,*) '(X axis) show'
- write(24,*) '%'
- write(24,*) '1.4 CM 9.5 CM MV'
- write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
- write(24,*) '(Z axis) show'
- write(24,*) 'grestore'
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.7 CM scalefont setfont'
- if(colors == 1) write(24,*) '.8 0 .8 setrgbcolor'
- 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'
- if(imagetype == 1) then
- write(24,*) '(Displacement vector field) show'
- else if(imagetype == 2) then
- write(24,*) '(Velocity vector field) show'
- else if(imagetype == 3) then
- write(24,*) '(Acceleration vector field) show'
- else
- call exit_MPI('Bad field code in PostScript display')
- endif
- write(24,*) 'grestore'
- write(24,*) '25.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,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
-
- if(coupled_acoustic_elastic) then
- write(24,*) '(Coupled Acoustic/Elastic Wave 2D - SEM) show'
- else if(coupled_acoustic_poro) then
- write(24,*) '(Coupled Acoustic/Poroelastic Wave 2D - SEM) show'
- else if(coupled_elastic_poro) 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
-
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- print the spectral elements mesh in PostScript
-!
-
- endif
-
-
- convert = PI / 180.d0
-
-!
-!---- draw the velocity model in background
-!
- if(modelvect) then
-
- buffer_offset = 0
- RGB_offset = 0
-
- do ispec=1,nspec
- do i=1,NGLLX-subsamp,subsamp
- do j=1,NGLLX-subsamp,subsamp
-
- if((vpmax-vpmin)/vpmin > 0.02d0) then
- if(assign_external_model) then
- x1 = (vpext(i,j,ispec)-vpmin) / (vpmax-vpmin)
- else
- material = kmato(ispec)
-! get elastic parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
- rhol_s = density(1,kmato(ispec))
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
-!frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
- rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
-!Biot coefficients for the input phi
- D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + FOUR_THIRDS*mul_fr
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
-! Approximated velocities (no viscous dissipation)
- afactor = rhol_bar - phil/tortl*rhol_f
- bfactor = H_biot + phil*rhol_bar/(tortl*rhol_f)*M_biot - 2.d0*phil/tortl*C_biot
- cfactor = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
- cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
- cpIloc = sqrt(cpIsquare)
- x1 = (cpIloc-vpmin)/(vpmax-vpmin)
- endif
- else
- x1 = 0.5d0
- endif
-
-! rescale to avoid very dark gray levels
- x1 = x1*0.7 + 0.2
- if(x1 > 1.d0) x1=1.d0
-
-! invert scale: white = vpmin, dark gray = vpmax
- x1 = 1.d0 - x1
-
- xw = coord(1,ibool(i,j,ispec))
- zw = coord(2,ibool(i,j,ispec))
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- if ( myrank == 0 ) then
- write(24,500) xw,zw
- else
- buffer_offset = buffer_offset + 1
- 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))
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- if ( myrank == 0 ) then
- write(24,499) xw,zw
- else
- buffer_offset = buffer_offset + 1
- 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))
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- if ( myrank == 0 ) then
- write(24,499) xw,zw
- else
- buffer_offset = buffer_offset + 1
- 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))
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- if ( myrank == 0 ) then
- write(24,499) xw,zw
- else
- buffer_offset = buffer_offset + 1
- 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_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)
- 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_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
- RGB_offset = 0
- do ispec = 1, nspec_recv
- do i=1,NGLLX-subsamp,subsamp
- do j=1,NGLLX-subsamp,subsamp
- buffer_offset = buffer_offset + 1
- 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_ps_velocity_model(1,buffer_offset), &
- coorg_recv_ps_velocity_model(2,buffer_offset)
- buffer_offset = buffer_offset + 1
- 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_ps_velocity_model(1,buffer_offset), &
- coorg_recv_ps_velocity_model(2,buffer_offset)
- RGB_offset = RGB_offset + 1
- write(24,604) RGB_recv_ps_velocity_model(1,RGB_offset)
- enddo
- enddo
- enddo
-
- enddo
- else
- call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- 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_ps_velocity_model(1,1), nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
- MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
- endif
-
-
-#endif
-
-
- endif
-
-!
-!---- draw the spectral element mesh
-!
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- endif
-
- buffer_offset = 0
- RGB_offset = 0
-
- do ispec=1,nspec
-
- if ( myrank == 0 ) write(24,*) '% elem ',ispec
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- if ( myrank == 0 ) then
- write(24,*) 'mark'
- write(24,681) x1,z1
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x1
- coorg_send_ps_element_mesh(2,buffer_offset) = z1
- endif
-
- if(ngnod == 4) then
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
-
- else
-
-! draw curved lines if elements have 9 nodes
- do ir=2,pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
- enddo
-
- ir=pointsdisp
- do is=2,pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
- enddo
-
- is=pointsdisp
- do ir=pointsdisp-1,1,-1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
- enddo
-
- ir=1
- do is=pointsdisp-1,2,-1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- 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'
- endif
-
- if(colors == 1) then
-
-! use a different color for each material set
- imat = kmato(ispec)
- icol = mod(imat - 1,NUM_COLORS) + 1
-
- if ( myrank == 0 ) then
- if(meshvect) then
- write(24,680) red(icol),green(icol),blue(icol)
- else
- write(24,679) red(icol),green(icol),blue(icol)
- endif
- else
- RGB_offset = RGB_offset + 1
- color_send_ps_element_mesh(RGB_offset) = icol
- endif
-
- endif
-
- if ( myrank == 0 ) then
- if(meshvect) then
- if(modelvect) then
- write(24,*) 'Colmesh ST'
- else
- write(24,*) '0 setgray ST'
- endif
- endif
- endif
-
-! write the element number, the group number and the material number inside the element
- if(numbers == 1) then
-
- xw = (coorg(1,knods(1,ispec)) + coorg(1,knods(2,ispec)) + coorg(1,knods(3,ispec)) + coorg(1,knods(4,ispec))) / 4.d0
- zw = (coorg(2,knods(1,ispec)) + coorg(2,knods(2,ispec)) + coorg(2,knods(3,ispec)) + coorg(2,knods(4,ispec))) / 4.d0
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
-
- if ( myrank == 0 ) then
- if(colors == 1) write(24,*) '1 setgray'
- endif
-
- if ( myrank == 0 ) then
- write(24,500) xw,zw
- else
- buffer_offset = buffer_offset + 1
- 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_ps_element_mesh(RGB_offset) = ispec
- endif
-
- endif
-
- enddo
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
- nb_coorg_per_elem = 1
- if ( numbers == 1 ) then
- nb_coorg_per_elem = nb_coorg_per_elem + 1
- 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)
- endif
- nb_color_per_elem = 0
- if ( colors == 1 ) then
- nb_color_per_elem = nb_color_per_elem + 1
- endif
- if ( numbers == 1 ) then
- nb_color_per_elem = nb_color_per_elem + 1
- endif
-
- 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_ps_element_mesh(1), nspec_recv*nb_coorg_per_elem, &
- MPI_INTEGER, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
-
- buffer_offset = 0
- RGB_offset = 0
- num_spec = nspec
- do ispec = 1, nspec_recv
- num_spec = num_spec + 1
- write(24,*) '% elem ',num_spec
- buffer_offset = buffer_offset + 1
- write(24,*) 'mark'
- 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_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- buffer_offset = buffer_offset + 1
- 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_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- buffer_offset = buffer_offset + 1
- 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_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_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_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_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- enddo
-
- endif
-
- write(24,*) 'CO'
- if ( colors == 1 ) then
- if(meshvect) then
- RGB_offset = RGB_offset + 1
- 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_ps_element_mesh(RGB_offset)),&
- green(color_recv_ps_element_mesh(RGB_offset)),&
- blue(color_recv_ps_element_mesh(RGB_offset))
- endif
- endif
- if(meshvect) then
- if(modelvect) then
- write(24,*) 'Colmesh ST'
- else
- write(24,*) '0 setgray ST'
- endif
- endif
- if(numbers == 1) then
- if(colors == 1) write(24,*) '1 setgray'
- buffer_offset = buffer_offset + 1
- 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_ps_element_mesh(RGB_offset)
- endif
-
- enddo
-
- 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
- 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)
- endif
- nb_color_per_elem = 0
- if ( colors == 1 ) then
- nb_color_per_elem = nb_color_per_elem + 1
- endif
- if ( numbers == 1 ) then
- nb_color_per_elem = nb_color_per_elem + 1
- 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_ps_element_mesh(1), nspec*nb_color_per_elem, &
- MPI_INTEGER, 0, 43, MPI_COMM_WORLD, ier)
- endif
-
- endif
-
-#endif
-
-!
-!--- draw absorbing boundaries with a thick color line
-!
- anyabs_glob = anyabs
-#ifdef USE_MPI
- call MPI_ALLREDUCE(anyabs, anyabs_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- if(anyabs_glob .and. boundvect) then
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% boundary conditions on the mesh'
- write(24,*) '%'
-
-! use green color
- write(24,*) '0 1 0 RG'
-
- write(24,*) '0.02 CM setlinewidth'
- endif
-
- buffer_offset = 0
-
- if ( anyabs ) then
- do inum = 1,nelemabs
- ispec = numabs(inum)
-
- do iedge = 1,4
-
- if(codeabs(iedge,inum) /= 0) then
-
- 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 absorbing boundary 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_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
- 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
- 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_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_ps_abs(1,1), 4*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
- endif
-
- endif
-
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0 setlinewidth'
- endif
-
- endif
-
-!
-!--- draw free surface with a thick color line
-!
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% free surface on the mesh'
- write(24,*) '%'
-
-! use orange color
- write(24,*) '1 0.66 0 RG'
-
- write(24,*) '0.02 CM setlinewidth'
- endif
-
- buffer_offset = 0
-
- if ( nelem_acoustic_surface > 0 ) then
- do inum = 1,nelem_acoustic_surface
- ispec = acoustic_edges(1,inum)
-
- x1 = (coorg(1,acoustic_edges(3,inum))-xmin)*ratio_page + orig_x
- z1 = (coorg(2,acoustic_edges(3,inum))-zmin)*ratio_page + orig_z
- x2 = (coorg(1,acoustic_edges(4,inum))-xmin)*ratio_page + orig_x
- z2 = (coorg(2,acoustic_edges(4,inum))-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_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
- 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
- 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_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_ps_free_surface(1,1), 4*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
- endif
-
- endif
-
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0 setlinewidth'
- endif
-
-!
-!---- draw the fluid-solid coupling edges with a thick color line
-!
- coupled_acoustic_elastic_glob = coupled_acoustic_elastic
-#ifdef USE_MPI
- call MPI_ALLREDUCE(coupled_acoustic_elastic, coupled_acoustic_elastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- if(coupled_acoustic_elastic_glob .and. boundvect) then
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% fluid-solid coupling edges in the mesh'
- write(24,*) '%'
-
- write(24,*) '0.02 CM setlinewidth'
- endif
-
- 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
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec = fluid_solid_acoustic_ispec(inum)
- iedge = fluid_solid_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
- 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 setlinewidth'
- endif
-
- endif
-
-!
-!---- draw the fluid-porous coupling edges with a thick color line
-!
- coupled_acoustic_poro_glob = coupled_acoustic_poro
-#ifdef USE_MPI
- call MPI_ALLREDUCE(coupled_acoustic_poro, coupled_acoustic_poro_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- if(coupled_acoustic_poro_glob .and. boundvect) then
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% fluid-porous coupling edges in the mesh'
- write(24,*) '%'
-
- 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
- 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 setlinewidth'
- endif
-
- endif
-
-!
-!---- draw the solid-porous coupling edges with a thick color line
-!
- coupled_elastic_poro_glob = coupled_elastic_poro
-#ifdef USE_MPI
- call MPI_ALLREDUCE(coupled_elastic_poro, coupled_elastic_poro_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- if(coupled_elastic_poro_glob .and. boundvect) then
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% solid-porous coupling edges in the mesh'
- write(24,*) '%'
-
- 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 setlinewidth'
- endif
-
- endif
-
-!
-!---- draw the normalized vector field
-!
-
- if ( myrank == 0 ) then
-! return if the maximum vector equals zero (no source)
- if(dispmax == 0.d0) then
- write(IOUT,*) 'null vector: returning!'
- return
- endif
-
- write(24,*) '%'
- write(24,*) '% vector field'
- write(24,*) '%'
-
-! color arrows if we draw the velocity model in the background
- if(modelvect) then
- write(24,*) 'Colvects'
- else
- write(24,*) '0 setgray'
- endif
- endif
-
- if(interpol) then
-
- 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
- pointsdisp_loop = 1
- else
- pointsdisp_loop = pointsdisp
- endif
-
- buffer_offset = 0
-
- do ispec=1,nspec
-
-! interpolation on a uniform grid
-#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
-
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
-
- Uxinterp(i,j) = 0.d0
- Uzinterp(i,j) = 0.d0
-
- do k=1,NGLLX
- do l=1,NGLLX
-
- Uxinterp(i,j) = Uxinterp(i,j) + displ(1,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
- Uzinterp(i,j) = Uzinterp(i,j) + displ(3,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
-
- enddo
- enddo
-
- x1 =(xinterp(i,j)-xmin)*ratio_page
- z1 =(zinterp(i,j)-zmin)*ratio_page
-
- x2 = Uxinterp(i,j)*sizemax_arrows/dispmax
- z2 = Uzinterp(i,j)*sizemax_arrows/dispmax
-
- d = sqrt(x2**2 + z2**2)
-
-! ignore if vector is too small
- if(d > cutsnaps*sizemax_arrows) then
-
- d1 = d * ARROW_RATIO
- d2 = d1 * cos(ARROW_ANGLE*convert)
-
- dummy = x2/d
- if(dummy > 0.9999d0) dummy = 0.9999d0
- if(dummy < -0.9999d0) dummy = -0.9999d0
- theta = acos(dummy)
-
- if(z2 < 0.d0) theta = 360.d0*convert - theta
- thetaup = theta - ARROW_ANGLE*convert
- thetadown = theta + ARROW_ANGLE*convert
-
-! draw the vector
- x1 = (orig_x+x1) * centim
- z1 = (orig_z+z1) * centim
- x2 = x2 * centim
- z2 = z2 * centim
- xa = -d2*cos(thetaup)
- za = -d2*sin(thetaup)
- xa = xa * centim
- za = za * centim
- xb = -d2*cos(thetadown)
- zb = -d2*sin(thetadown)
- xb = xb * centim
- zb = zb * centim
- if ( myrank == 0 ) then
- 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)
-
- line_length = len_trim(postscript_line)
- index_char = 1
- first = .false.
- do ii = 1,line_length-1
- if(ch1(ii) /= ' ' .or. first) then
- if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
- ch2(index_char) = ch1(ii)
- index_char = index_char + 1
- first = .true.
- endif
- endif
- enddo
- ch2(index_char) = ch1(line_length)
- write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
-
- else
- buffer_offset = buffer_offset + 1
- 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
- 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
- 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_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)
-
- line_length = len_trim(postscript_line)
- index_char = 1
- first = .false.
- do ii = 1,line_length-1
- if(ch1(ii) /= ' ' .or. first) then
- if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
- ch2(index_char) = ch1(ii)
- index_char = index_char + 1
- first = .true.
- endif
- endif
- enddo
- ch2(index_char) = ch1(line_length)
- write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
- 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_ps_vector_field(1,1), 8*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 46, MPI_COMM_WORLD, ier)
- endif
-
- endif
-
-#endif
-
-
-! draw the vectors at the nodes of the mesh if we do not interpolate the display on a regular grid
- else
-
- buffer_offset = 0
-
- do ipoin=1,npoin
-
- x1 =(coord(1,ipoin)-xmin)*ratio_page
- z1 =(coord(2,ipoin)-zmin)*ratio_page
-
- x2 = displ(1,ipoin)*sizemax_arrows/dispmax
- z2 = displ(3,ipoin)*sizemax_arrows/dispmax
-
- d = sqrt(x2**2 + z2**2)
-
-! ignore if vector is too small
- if(d > cutsnaps*sizemax_arrows) then
-
- d1 = d * ARROW_RATIO
- d2 = d1 * cos(ARROW_ANGLE*convert)
-
- dummy = x2/d
- if(dummy > 0.9999d0) dummy = 0.9999d0
- if(dummy < -0.9999d0) dummy = -0.9999d0
- theta = acos(dummy)
-
- if(z2 < 0.d0) theta = 360.d0*convert - theta
- thetaup = theta - ARROW_ANGLE*convert
- thetadown = theta + ARROW_ANGLE*convert
-
-! draw the vector
- x1 = (orig_x+x1) * centim
- z1 = (orig_z+z1) * centim
- x2 = x2 * centim
- z2 = z2 * centim
- xa = -d2*cos(thetaup)
- za = -d2*sin(thetaup)
- xa = xa * centim
- za = za * centim
- xb = -d2*cos(thetadown)
- zb = -d2*sin(thetadown)
- xb = xb * centim
- zb = zb * centim
- if ( myrank == 0 ) then
- 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)
-
- line_length = len_trim(postscript_line)
- index_char = 1
- first = .false.
- do ii = 1,line_length-1
- if(ch1(ii) /= ' ' .or. first) then
- if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
- ch2(index_char) = ch1(ii)
- index_char = index_char + 1
- first = .true.
- endif
- endif
- enddo
- ch2(index_char) = ch1(line_length)
- write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
-
- else
- buffer_offset = buffer_offset + 1
- 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
- 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_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)
-
- line_length = len_trim(postscript_line)
- index_char = 1
- first = .false.
- do ii = 1,line_length-1
- if(ch1(ii) /= ' ' .or. first) then
- if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
- ch2(index_char) = ch1(ii)
- index_char = index_char + 1
- first = .true.
- endif
- endif
- enddo
- ch2(index_char) = ch1(line_length)
- write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
- 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_ps_vector_field(1,1), 8*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 47, MPI_COMM_WORLD, ier)
- endif
- endif
-
-#endif
-
- endif
-
- if ( myrank == 0 ) then
- write(24,*) '0 setgray'
-
-! sources and receivers in color if velocity model
- if(modelvect) then
- write(24,*) 'Colreceiv'
- else
- write(24,*) '0 setgray'
- endif
-
-!
-!---- write position of the source
-!
- do i=1,NSOURCES
- if(i == 1) write(24,*) '% beginning of source line'
- if(i == NSOURCES) write(24,*) '% end of source line'
- xw = x_source(i)
- zw = z_source(i)
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- write(24,500) xw,zw
- write(24,*) 'Cross'
- enddo
-
-!
-!---- write position of the receivers
-!
- do i=1,nrec
- if(i == 1) write(24,*) '% beginning of receiver line'
- if(i == nrec) write(24,*) '% end of receiver line'
-
- xw = st_xval(i)
- zw = st_zval(i)
-
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- write(24,500) xw,zw
- write(24,*) 'Diamond'
- enddo
-
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
- endif
-
- 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a100,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
- 600 format(f6.3,' neg CM 0 MR (Time =',f8.3,' s) show')
- 601 format(f6.3,' neg CM 0 MR (Time =',1pe12.3,' s) show')
- 610 format(f6.3,' neg CM 0 MR (Time step = ',i7,') show')
- 620 format(f6.3,' neg CM 0 MR (Cut =',f5.2,' \%) show')
- 640 format(f6.3,' neg CM 0 MR (Max norm =',1pe12.3,') show')
-
- 499 format(f8.3,1x,f8.3,' L')
- 500 format(f8.3,1x,f8.3,' M')
- 502 format('fN (',i4,') Cshow')
- 679 format(f12.6,1x,f12.6,1x,f12.6,' RG fill stroke')
- 680 format(f12.6,1x,f12.6,1x,f12.6,' RG GF')
- 681 format(f6.2,1x,f6.2)
- 602 format(f6.2,1x,f6.2,' M ',f6.2,1x,f6.2,' L ST')
- 604 format('CP ',f12.6,' BK')
- 700 format(8(f6.2,1x),'F')
-
- end subroutine plotpost
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/prepare_absorb.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/prepare_absorb.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/prepare_absorb.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,522 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine prepare_absorb_files(myrank,any_elastic,any_poroelastic,any_acoustic, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,SIMULATION_TYPE)
-
- implicit none
- include "constants.h"
-
- integer :: myrank,SIMULATION_TYPE
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- logical :: any_elastic,any_poroelastic,any_acoustic
-
- ! local parameters
- character(len=150) :: outputname,outputname2
-
-
- if(any_elastic) then
-
- !--- left absorbing boundary
- if( nspec_xmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_elastic_left',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=35,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=35,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of left absorbing boundary
-
- !--- right absorbing boundary
- if( nspec_xmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_elastic_right',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=36,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=36,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of right absorbing boundary
-
- !--- bottom absorbing boundary
- if( nspec_zmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_elastic_bottom',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=37,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=37,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of bottom absorbing boundary
-
- !--- top absorbing boundary
- if( nspec_zmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_elastic_top',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=38,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=38,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of top absorbing boundary
-
- endif ! any_elastic
-
- if(any_poroelastic) then
-
- !--- left absorbing boundary
- if( nspec_xmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_poro_s_left',myrank,'.bin'
- write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_left',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=45,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- open(unit=25,file='OUTPUT_FILES/'//outputname2,status='old',&
- form='unformatted')
- else
- open(unit=45,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- open(unit=25,file='OUTPUT_FILES/'//outputname2,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of left absorbing boundary
-
- !--- right absorbing boundary
- if( nspec_xmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_poro_s_right',myrank,'.bin'
- write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_right',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=46,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- open(unit=26,file='OUTPUT_FILES/'//outputname2,status='old',&
- form='unformatted')
- else
- open(unit=46,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- open(unit=26,file='OUTPUT_FILES/'//outputname2,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of right absorbing boundary
-
- !--- bottom absorbing boundary
- if( nspec_zmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_poro_s_bottom',myrank,'.bin'
- write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_bottom',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=47,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- open(unit=29,file='OUTPUT_FILES/'//outputname2,status='old',&
- form='unformatted')
- else
- open(unit=47,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- open(unit=29,file='OUTPUT_FILES/'//outputname2,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of bottom absorbing boundary
-
- !--- top absorbing boundary
- if( nspec_zmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_poro_s_top',myrank,'.bin'
- write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_top',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=48,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- open(unit=28,file='OUTPUT_FILES/'//outputname2,status='old',&
- form='unformatted')
- else
- open(unit=48,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- open(unit=28,file='OUTPUT_FILES/'//outputname2,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of top absorbing boundary
-
- endif !any_poroelastic
-
- if(any_acoustic) then
-
- !--- left absorbing boundary
- if( nspec_xmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_acoustic_left',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=65,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=65,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of left absorbing boundary
-
- !--- right absorbing boundary
- if( nspec_xmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_acoustic_right',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=66,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=66,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of right absorbing boundary
-
- !--- bottom absorbing boundary
- if( nspec_zmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_acoustic_bottom',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=67,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=67,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of bottom absorbing boundary
-
- !--- top absorbing boundary
- if( nspec_zmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_acoustic_top',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=68,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=68,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of top absorbing boundary
-
- endif !any_acoustic
-
-
- end subroutine prepare_absorb_files
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_absorb_elastic(NSTEP,p_sv, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_elastic_left,b_absorb_elastic_right, &
- b_absorb_elastic_bottom,b_absorb_elastic_top)
-
- implicit none
- include "constants.h"
-
- logical :: p_sv
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer :: NSTEP
- real(kind=CUSTOM_REAL) :: b_absorb_elastic_left(3,NGLLZ,nspec_xmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_elastic_right(3,NGLLZ,nspec_xmax,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_elastic_bottom(3,NGLLX,nspec_zmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_elastic_top(3,NGLLX,nspec_zmax,NSTEP)
-
- ! local parameters
- integer :: ispec,i,it
-
- do it =1, NSTEP
-
- !--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLZ
- read(35) b_absorb_elastic_left(1,i,ispec,it)
- enddo
- do i=1,NGLLZ
- read(35) b_absorb_elastic_left(3,i,ispec,it)
- enddo
- b_absorb_elastic_left(2,:,ispec,it) = ZERO
- else!SH (membrane) waves
- do i=1,NGLLZ
- read(35) b_absorb_elastic_left(2,i,ispec,it)
- enddo
- b_absorb_elastic_left(1,:,ispec,it) = ZERO
- b_absorb_elastic_left(3,:,ispec,it) = ZERO
- endif
-
- enddo
- endif
-
- !--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLZ
- read(36) b_absorb_elastic_right(1,i,ispec,it)
- enddo
- do i=1,NGLLZ
- read(36) b_absorb_elastic_right(3,i,ispec,it)
- enddo
- b_absorb_elastic_right(2,:,ispec,it) = ZERO
- else!SH (membrane) waves
- do i=1,NGLLZ
- read(36) b_absorb_elastic_right(2,i,ispec,it)
- enddo
- b_absorb_elastic_right(1,:,ispec,it) = ZERO
- b_absorb_elastic_right(3,:,ispec,it) = ZERO
- endif
-
- enddo
- endif
-
- !--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLX
- read(37) b_absorb_elastic_bottom(1,i,ispec,it)
- enddo
- do i=1,NGLLX
- read(37) b_absorb_elastic_bottom(3,i,ispec,it)
- enddo
- b_absorb_elastic_bottom(2,:,ispec,it) = ZERO
- else!SH (membrane) waves
- do i=1,NGLLZ
- read(37) b_absorb_elastic_bottom(2,i,ispec,it)
- enddo
- b_absorb_elastic_bottom(1,:,ispec,it) = ZERO
- b_absorb_elastic_bottom(3,:,ispec,it) = ZERO
- endif
-
- enddo
- endif
-
- !--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLX
- read(38) b_absorb_elastic_top(1,i,ispec,it)
- enddo
- do i=1,NGLLX
- read(38) b_absorb_elastic_top(3,i,ispec,it)
- enddo
- b_absorb_elastic_top(2,:,ispec,it) = ZERO
- else!SH (membrane) waves
- do i=1,NGLLZ
- read(38) b_absorb_elastic_top(2,i,ispec,it)
- enddo
- b_absorb_elastic_top(1,:,ispec,it) = ZERO
- b_absorb_elastic_top(3,:,ispec,it) = ZERO
- endif
-
- enddo
- endif
-
- enddo
-
- end subroutine prepare_absorb_elastic
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_absorb_poroelastic(NSTEP, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_poro_s_left,b_absorb_poro_w_left, &
- b_absorb_poro_s_right,b_absorb_poro_w_right, &
- b_absorb_poro_s_bottom,b_absorb_poro_w_bottom, &
- b_absorb_poro_s_top,b_absorb_poro_w_top)
-
- implicit none
- include "constants.h"
-
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
-
- integer :: NSTEP
- real(kind=CUSTOM_REAL) :: b_absorb_poro_s_left(NDIM,NGLLZ,nspec_xmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_s_right(NDIM,NGLLZ,nspec_xmax,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_s_bottom(NDIM,NGLLX,nspec_zmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_s_top(NDIM,NGLLX,nspec_zmax,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_w_left(NDIM,NGLLZ,nspec_xmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_w_right(NDIM,NGLLZ,nspec_xmax,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_w_bottom(NDIM,NGLLX,nspec_zmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_w_top(NDIM,NGLLX,nspec_zmax,NSTEP)
-
- ! local parameters
- integer :: ispec,i,it,id
-
- do it =1, NSTEP
-
- !--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
- do id =1,2
- do i=1,NGLLZ
- read(45) b_absorb_poro_s_left(id,i,ispec,it)
- read(25) b_absorb_poro_w_left(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
- !--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
- do id =1,2
- do i=1,NGLLZ
- read(46) b_absorb_poro_s_right(id,i,ispec,it)
- read(26) b_absorb_poro_w_right(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
- !--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
- do id =1,2
- do i=1,NGLLX
- read(47) b_absorb_poro_s_bottom(id,i,ispec,it)
- read(29) b_absorb_poro_w_bottom(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
- !--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
- do id =1,2
- do i=1,NGLLX
- read(48) b_absorb_poro_s_top(id,i,ispec,it)
- read(28) b_absorb_poro_w_top(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
- enddo
-
- end subroutine prepare_absorb_poroelastic
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_absorb_acoustic(NSTEP, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_acoustic_left,b_absorb_acoustic_right, &
- b_absorb_acoustic_bottom,b_absorb_acoustic_top)
-
- implicit none
- include "constants.h"
-
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
-
- integer :: NSTEP
- real(kind=CUSTOM_REAL) :: b_absorb_acoustic_left(NGLLZ,nspec_xmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_acoustic_right(NGLLZ,nspec_xmax,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_acoustic_bottom(NGLLX,nspec_zmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_acoustic_top(NGLLX,nspec_zmax,NSTEP)
-
-
- ! local parameters
- integer :: ispec,i,it
-
- do it =1, NSTEP
-
- !--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
- do i=1,NGLLZ
- read(65) b_absorb_acoustic_left(i,ispec,it)
- enddo
- enddo
- endif
-
- !--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
- do i=1,NGLLZ
- read(66) b_absorb_acoustic_right(i,ispec,it)
- enddo
- enddo
- endif
-
- !--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
- do i=1,NGLLX
- read(67) b_absorb_acoustic_bottom(i,ispec,it)
- enddo
- enddo
- endif
-
- !--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
- do i=1,NGLLX
- read(68) b_absorb_acoustic_top(i,ispec,it)
- enddo
- enddo
- endif
-
- enddo
-
- end subroutine prepare_absorb_acoustic
-
\ No newline at end of file
Deleted: seismo/2D/SPECFEM2D/trunk/src/prepare_assemble_MPI.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/prepare_assemble_MPI.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/prepare_assemble_MPI.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,340 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!
-! 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.
-!
-
-#ifdef USE_MPI
-
-!-----------------------------------------------
-! Determines the points that are on the interfaces with other partitions, to help
-! 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 (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, &
- 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 )
-
- implicit none
-
- include 'constants.h'
-
- integer, intent(in) :: nspec, npoin, ngnod
- logical, dimension(nspec), intent(in) :: elastic, poroelastic
- integer, dimension(ngnod,nspec), intent(in) :: knods
- integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
-
- integer :: ninterface
- integer :: max_interface_size
- integer, dimension(ninterface) :: my_nelmnts_neighbours
- integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
- integer, dimension(NGLLX*max_interface_size,ninterface) :: &
- ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
- integer, dimension(ninterface) :: &
- nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
-
- integer, dimension(ninterface), intent(out) :: &
- inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
- integer, intent(out) :: ninterface_acoustic, ninterface_elastic, ninterface_poroelastic
-
- logical, dimension(nspec), intent(inout) :: mask_ispec_inner_outer
-
- ! local parameters
- integer :: num_interface
- integer :: ispec_interface
- logical, dimension(npoin) :: mask_ibool_acoustic
- logical, dimension(npoin) :: mask_ibool_elastic
- logical, dimension(npoin) :: mask_ibool_poroelastic
- integer :: ixmin, ixmax, izmin, izmax, ix, iz
- integer, dimension(ngnod) :: n
- integer :: e1, e2, itype, ispec, k, sens, iglob
- integer :: npoin_interface_acoustic
- integer :: npoin_interface_elastic
- integer :: npoin_interface_poroelastic
-
- ! initializes
- ibool_interfaces_acoustic(:,:) = 0
- nibool_interfaces_acoustic(:) = 0
- ibool_interfaces_elastic(:,:) = 0
- nibool_interfaces_elastic(:) = 0
- ibool_interfaces_poroelastic(:,:) = 0
- nibool_interfaces_poroelastic(:) = 0
-
- do num_interface = 1, ninterface
- ! initializes interface point counters
- npoin_interface_acoustic = 0
- npoin_interface_elastic = 0
- npoin_interface_poroelastic = 0
- mask_ibool_acoustic(:) = .false.
- mask_ibool_elastic(:) = .false.
- mask_ibool_poroelastic(:) = .false.
-
- do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
- ! element id
- ispec = my_interfaces(1,ispec_interface,num_interface)
- ! type of interface: 1 = common point, 2 = common edge
- itype = my_interfaces(2,ispec_interface,num_interface)
- ! element control node ids
- do k = 1, ngnod
- n(k) = knods(k,ispec)
- end do
- ! common node ids
- e1 = my_interfaces(3,ispec_interface,num_interface)
- e2 = my_interfaces(4,ispec_interface,num_interface)
-
- call get_edge(ngnod, n, itype, e1, e2, ixmin, ixmax, izmin, izmax, sens)
-
- do iz = izmin, izmax, sens
- do ix = ixmin, ixmax, sens
- ! global index
- iglob = ibool(ix,iz,ispec)
-
- ! checks to which material this common interface belongs
- if ( elastic(ispec) ) then
- ! elastic element
- if(.not. mask_ibool_elastic(iglob)) then
- mask_ibool_elastic(iglob) = .true.
- npoin_interface_elastic = npoin_interface_elastic + 1
- ibool_interfaces_elastic(npoin_interface_elastic,num_interface) = iglob
- end if
- else if ( poroelastic(ispec) ) then
- ! poroelastic element
- if(.not. mask_ibool_poroelastic(iglob)) then
- mask_ibool_poroelastic(iglob) = .true.
- npoin_interface_poroelastic = npoin_interface_poroelastic + 1
- ibool_interfaces_poroelastic(npoin_interface_poroelastic,num_interface) = iglob
- end if
- else
- ! acoustic element
- if(.not. mask_ibool_acoustic(iglob)) then
- mask_ibool_acoustic(iglob) = .true.
- npoin_interface_acoustic = npoin_interface_acoustic + 1
- ibool_interfaces_acoustic(npoin_interface_acoustic,num_interface) = iglob
- end if
- end if
- end do
- end do
-
- end do
-
- ! stores counters for interface points
- nibool_interfaces_acoustic(num_interface) = npoin_interface_acoustic
- nibool_interfaces_elastic(num_interface) = npoin_interface_elastic
- nibool_interfaces_poroelastic(num_interface) = npoin_interface_poroelastic
-
- ! sets inner/outer element flags
- do ispec = 1, nspec
- do iz = 1, NGLLZ
- do ix = 1, NGLLX
- if ( mask_ibool_acoustic(ibool(ix,iz,ispec)) &
- .or. mask_ibool_elastic(ibool(ix,iz,ispec)) &
- .or. mask_ibool_poroelastic(ibool(ix,iz,ispec)) ) then
- mask_ispec_inner_outer(ispec) = .true.
- endif
-
- enddo
- enddo
- enddo
-
- end do
-
- ! sets number of interfaces for each material domain
- ninterface_acoustic = 0
- ninterface_elastic = 0
- ninterface_poroelastic = 0
-
- ! loops over all MPI interfaces
- do num_interface = 1, ninterface
- ! sets acoustic MPI interface (local) indices in range [1,ninterface_acoustic]
- if ( nibool_interfaces_acoustic(num_interface) > 0 ) then
- ninterface_acoustic = ninterface_acoustic + 1
- inum_interfaces_acoustic(ninterface_acoustic) = num_interface
- end if
- ! elastic
- if ( nibool_interfaces_elastic(num_interface) > 0 ) then
- ninterface_elastic = ninterface_elastic + 1
- inum_interfaces_elastic(ninterface_elastic) = num_interface
- end if
- ! poroelastic
- if ( nibool_interfaces_poroelastic(num_interface) > 0 ) then
- ninterface_poroelastic = ninterface_poroelastic + 1
- inum_interfaces_poroelastic(ninterface_poroelastic) = num_interface
- end if
- end do
-
- end subroutine prepare_assemble_MPI
-
-
-!-----------------------------------------------
-! Get the points (ixmin, ixmax, izmin and izmax) on an node/edge for one element.
-! 'sens' is used to have DO loops with increment equal to 'sens' (-/+1).
-!-----------------------------------------------
- subroutine get_edge ( ngnod, n, itype, e1, e2, ixmin, ixmax, izmin, izmax, sens )
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: ngnod
- integer, dimension(ngnod), intent(in) :: n
- integer, intent(in) :: itype, e1, e2
- integer, intent(out) :: ixmin, ixmax, izmin, izmax
- integer, intent(out) :: sens
-
- if ( itype == 1 ) then
-
- ! common single point
-
- ! checks which corner point is given
- if ( e1 == n(1) ) then
- ixmin = 1
- ixmax = 1
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- if ( e1 == n(4) ) then
- ixmin = 1
- ixmax = 1
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- sens = 1
-
- else if( itype == 2 ) then
-
- ! common edge
-
- ! checks which edge and corner points are given
- if ( e1 == n(1) ) then
- ixmin = 1
- izmin = 1
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- izmax = 1
- sens = 1
- end if
- if ( e2 == n(4) ) then
- ixmax = 1
- izmax = NGLLZ
- sens = 1
- end if
- end if
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- izmin = 1
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- izmax = NGLLZ
- sens = 1
- end if
- if ( e2 == n(1) ) then
- ixmax = 1
- izmax = 1
- sens = -1
- end if
- end if
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- izmin = NGLLZ
- if ( e2 == n(4) ) then
- ixmax = 1
- izmax = NGLLZ
- sens = -1
- end if
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- izmax = 1
- sens = -1
- end if
- end if
- if ( e1 == n(4) ) then
- ixmin = 1
- izmin = NGLLZ
- if ( e2 == n(1) ) then
- ixmax = 1
- izmax = 1
- sens = -1
- end if
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- izmax = NGLLZ
- sens = 1
- end if
- end if
-
- else
-
- call exit_MPI('ERROR get_edge unknown type')
-
- end if
-
- end subroutine get_edge
-
-#endif
Deleted: seismo/2D/SPECFEM2D/trunk/src/prepare_color_image.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/prepare_color_image.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/prepare_color_image.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,436 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine prepare_color_image_init(NX_IMAGE_color,NZ_IMAGE_color, &
- xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image, &
- coord,npoin,npgeo)
-
- implicit none
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: NX_IMAGE_color,NZ_IMAGE_color
-
- integer :: npoin,npgeo
- double precision, dimension(NDIM,npoin) :: coord
-
- double precision :: xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image
-
- ! local parameters
- integer :: npgeo_glob
- double precision :: xmin_color_image_loc, xmax_color_image_loc, &
- zmin_color_image_loc,zmax_color_image_loc
-#ifdef USE_MPI
- integer :: ier
-#endif
-
- ! horizontal size of the image
- xmin_color_image_loc = minval(coord(1,:))
- xmax_color_image_loc = maxval(coord(1,:))
-
- ! vertical size of the image, slightly increase it to go beyond maximum topography
- zmin_color_image_loc = minval(coord(2,:))
- zmax_color_image_loc = maxval(coord(2,:))
-
-! global values
- xmin_color_image = xmin_color_image_loc
- xmax_color_image = xmax_color_image_loc
- zmin_color_image = zmin_color_image_loc
- zmax_color_image = zmax_color_image_loc
- npgeo_glob = npgeo
-
-#ifdef USE_MPI
- call MPI_ALLREDUCE(xmin_color_image_loc, xmin_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE(xmax_color_image_loc, xmax_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE(zmin_color_image_loc, zmin_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE(zmax_color_image_loc, zmax_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE(npgeo, npgeo_glob, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ier)
-#endif
-
- zmax_color_image = zmin_color_image + 1.05d0 * (zmax_color_image - zmin_color_image)
-
- ! compute number of pixels in the horizontal direction based on typical number
- ! of spectral elements in a given direction (may give bad results for very elongated models)
- NX_IMAGE_color = nint(sqrt(dble(npgeo_glob))) * (NGLLX-1) + 1
-
- ! compute number of pixels in the vertical direction based on ratio of sizes
- NZ_IMAGE_color = nint(NX_IMAGE_color * (zmax_color_image - zmin_color_image) &
- / (xmax_color_image - xmin_color_image))
-
- ! convert pixel sizes to even numbers because easier to reduce size,
- ! create MPEG movies in postprocessing
- NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
- NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
-
- ! check that image size is not too big
- if (NX_IMAGE_color > 99999) call exit_MPI('output image too big : NX_IMAGE_color > 99999.')
- if (NZ_IMAGE_color > 99999) call exit_MPI('output image too big : NZ_IMAGE_color > 99999.')
-
- end subroutine prepare_color_image_init
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_color_image_pixels(myrank,NX_IMAGE_color,NZ_IMAGE_color, &
- xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image, &
- coord,npoin,coorg,npgeo,nspec,ngnod,knods,ibool, &
- nb_pixel_loc,iglob_image_color)
-
- implicit none
- include "constants.h"
-
- integer :: myrank
- integer :: NX_IMAGE_color,NZ_IMAGE_color
- double precision :: xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image
-
- integer :: npoin,nspec,npgeo,ngnod
- double precision, dimension(NDIM,npoin) :: coord
- double precision, dimension(NDIM,npgeo) :: coorg
-
- integer, dimension(ngnod,nspec) :: knods
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- integer :: nb_pixel_loc
- integer, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: iglob_image_color
-
- ! local parameters
- double precision :: size_pixel_horizontal,size_pixel_vertical
- double precision, dimension(2,4) :: elmnt_coords
- double precision :: i_coord, j_coord
- double precision :: dist_pixel, dist_min_pixel
- integer :: min_i, min_j, max_i, max_j
- integer :: ispec,i,j,k,l,iglob
- logical :: pixel_is_in
-
- ! create all the pixels
- 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)
- size_pixel_vertical = (zmax_color_image - zmin_color_image) / dble(NZ_IMAGE_color-1)
-
- iglob_image_color(:,:) = -1
-
- ! checking which pixels are inside each elements
-
- nb_pixel_loc = 0
- do ispec = 1, nspec
-
- do k = 1, 4
- elmnt_coords(1,k) = coorg(1,knods(k,ispec))
- elmnt_coords(2,k) = coorg(2,knods(k,ispec))
- enddo
-
- ! avoid working on the whole pixel grid
- min_i = floor(minval((elmnt_coords(1,:) - xmin_color_image))/size_pixel_horizontal) + 1
- max_i = ceiling(maxval((elmnt_coords(1,:) - xmin_color_image))/size_pixel_horizontal) + 1
- min_j = floor(minval((elmnt_coords(2,:) - zmin_color_image))/size_pixel_vertical) + 1
- max_j = ceiling(maxval((elmnt_coords(2,:) - zmin_color_image))/size_pixel_vertical) + 1
-
- ! avoid edge effects
- if(min_i < 1) min_i = 1
- if(min_j < 1) min_j = 1
-
- if(max_i > NX_IMAGE_color) max_i = NX_IMAGE_color
- if(max_j > NZ_IMAGE_color) max_j = NZ_IMAGE_color
-
- do j = min_j, max_j
- do i = min_i, max_i
- i_coord = (i-1)*size_pixel_horizontal + xmin_color_image
- j_coord = (j-1)*size_pixel_vertical + zmin_color_image
-
- ! checking if the pixel is inside the element (must be a convex quadrilateral)
- call is_in_convex_quadrilateral( elmnt_coords, i_coord, j_coord, pixel_is_in)
-
- ! if inside, getting the nearest point inside the element!
- if ( pixel_is_in ) then
- dist_min_pixel = HUGEVAL
- do k = 1, NGLLX
- do l = 1, NGLLZ
- iglob = ibool(k,l,ispec)
- dist_pixel = (coord(1,iglob)-i_coord)**2 + (coord(2,iglob)-j_coord)**2
- if (dist_pixel < dist_min_pixel) then
- dist_min_pixel = dist_pixel
- iglob_image_color(i,j) = iglob
-
- endif
-
- enddo
- enddo
- if ( dist_min_pixel >= HUGEVAL ) then
- call exit_MPI('Error in detecting pixel for color image')
-
- endif
- nb_pixel_loc = nb_pixel_loc + 1
-
- endif
-
- enddo
- enddo
- enddo
-
- end subroutine prepare_color_image_pixels
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine prepare_color_image_vp(npoin,image_color_vp_display,iglob_image_color, &
- NX_IMAGE_color,NZ_IMAGE_color,nb_pixel_loc, &
- num_pixel_loc,nspec,poroelastic,ibool,kmato, &
- numat,density,poroelastcoef,porosity,tortuosity, &
- nproc,myrank,assign_external_model,vpext)
-
-! stores P-velocity model in image_color_vp_display
-
- implicit none
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: npoin,nspec
- integer :: NX_IMAGE_color,NZ_IMAGE_color
- double precision, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: image_color_vp_display
- integer, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: iglob_image_color
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: kmato
-
- logical, dimension(nspec) :: poroelastic
-
- integer :: nb_pixel_loc
- integer, dimension(nb_pixel_loc) :: num_pixel_loc
-
- logical :: assign_external_model
- integer :: nproc,myrank
- integer :: numat
- double precision, dimension(2,numat) :: density
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext
-
- ! local parameters
- double precision, dimension(:), allocatable :: vp_display
- double precision :: rhol,mul_relaxed,lambdal_relaxed
- double precision :: rhol_s,rhol_f,rhol_bar,phil,tortl,mul_s,kappal_s,kappal_f, &
- mul_fr,kappal_fr
- double precision :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,&
- M_biot,B_biot,cpIsquare,cpIIsquare,cssquare
- double precision :: gamma1,gamma2,gamma3,gamma4,ratio
- integer :: i,j,k,ispec
-#ifdef USE_MPI
- double precision, dimension(:), allocatable :: data_pixel_recv
- double precision, dimension(:), allocatable :: data_pixel_send
- integer, dimension(:,:), allocatable :: num_pixel_recv
- integer, dimension(:), allocatable :: nb_pixel_per_proc
- integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
- integer :: ier,iproc
-#else
- integer :: dummy
-#endif
-
- ! to display the P-velocity model in background on color images
- 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))
- !solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4.d0*mul_s/3.d0
- 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.d0*mul_fr/3.d0
- rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
- !Biot coefficients for the input phi
- D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
- + kappal_fr + 4.d0*mul_fr/3.d0
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
- B_biot = H_biot - 4.d0*mul_fr/3.d0
- ! 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.d0*afactor*cfactor))/(2.d0*afactor)
- cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
- cssquare = mul_fr/afactor
-
- ! Approximated ratio r = amplitude "w" field/amplitude "s" field (no viscous dissipation)
- ! used later for wavespeed kernels calculation, which are presently implemented for inviscid case,
- ! contrary to primary and density-normalized kernels, which are consistent with viscous fluid case.
- gamma1 = H_biot - phil/tortl*C_biot
- gamma2 = C_biot - phil/tortl*M_biot
- gamma3 = phil/tortl*( M_biot*(afactor/rhol_f + phil/tortl) - C_biot)
- gamma4 = phil/tortl*( C_biot*(afactor/rhol_f + phil/tortl) - H_biot)
- ratio = HALF*(gamma1 - gamma3)/gamma4 &
- + HALF*sqrt((gamma1-gamma3)**2/gamma4**2 &
- + 4.d0 * gamma2/gamma4)
-
- 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)
- 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
- image_color_vp_display(:,:) = 0.d0
-
- 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
- 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
-
- allocate(nb_pixel_per_proc(nproc))
- nb_pixel_per_proc(:) = 0
- call MPI_GATHER( nb_pixel_loc, 1, MPI_INTEGER, nb_pixel_per_proc(1), &
- 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ier)
-
-
- if ( myrank == 0 ) then
- allocate(num_pixel_recv(maxval(nb_pixel_per_proc(:)),nproc))
- allocate(data_pixel_recv(maxval(nb_pixel_per_proc(:))))
- endif
- allocate(data_pixel_send(nb_pixel_loc))
-
- if (nproc > 1) then
- if (myrank == 0) then
- do iproc = 1, nproc-1
-
- call MPI_RECV(num_pixel_recv(1,iproc+1),nb_pixel_per_proc(iproc+1), MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- 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)
-
- do k = 1, nb_pixel_per_proc(iproc+1)
- 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
-
- ! checks bounds
- if( i < 1 .or. i > NX_IMAGE_color .or. j < 1 .or. j > NZ_IMAGE_color ) then
- print*,'image vp bounds:',myrank,iproc,k, &
- num_pixel_recv(k,iproc+1),nb_pixel_per_proc(iproc+1)
- print*,' i: ',i,NX_IMAGE_color
- print*,' j: ',j,NZ_IMAGE_color
- endif
-
- image_color_vp_display(i,j) = data_pixel_recv(k)
- enddo
- enddo
-
- 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) = vp_display(iglob_image_color(i,j))
- enddo
-
- call MPI_SEND(num_pixel_loc(1),nb_pixel_loc,MPI_INTEGER, &
- 0, 42, MPI_COMM_WORLD, ier)
-
- call MPI_SEND(data_pixel_send(1),nb_pixel_loc,MPI_DOUBLE_PRECISION, &
- 0, 43, MPI_COMM_WORLD, ier)
-
- endif
- endif
-
- deallocate(nb_pixel_per_proc)
- deallocate(data_pixel_send)
- if( myrank == 0 ) then
- deallocate(num_pixel_recv)
- deallocate(data_pixel_recv)
- endif
-#else
- ! to avoid compiler warnings
- dummy = myrank
- dummy = nproc
-#endif
-
- end subroutine prepare_color_image_vp
Deleted: seismo/2D/SPECFEM2D/trunk/src/prepare_initialfield.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/prepare_initialfield.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/prepare_initialfield.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,395 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine prepare_initialfield(myrank,any_acoustic,any_poroelastic,over_critical_angle, &
- NSOURCES,source_type,angleforce,x_source,z_source,f0, &
- npoin,numat,poroelastcoef,density,coord, &
- angleforce_refl,c_inc,c_refl,cploc,csloc,time_offset, &
- A_plane, B_plane, C_plane, &
- accel_elastic,veloc_elastic,displ_elastic)
-
- implicit none
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: myrank
- logical :: any_acoustic,any_poroelastic
-
- integer :: NSOURCES
- integer, dimension(NSOURCES) :: source_type
- double precision, dimension(NSOURCES) :: angleforce,x_source,z_source,f0
-
- integer :: npoin,numat
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(2,numat) :: density
- double precision, dimension(NDIM,npoin) :: coord
-
- double precision :: angleforce_refl,c_inc,c_refl,cploc,csloc
- double precision :: time_offset,x0_source,z0_source
- double precision, dimension(2) :: A_plane, B_plane, C_plane
-
- real(kind=CUSTOM_REAL), dimension(3,npoin) :: accel_elastic,veloc_elastic,displ_elastic
-
- logical :: over_critical_angle
-
- ! local parameters
- integer :: numat_local,i
- double precision :: denst,lambdaplus2mu,mu,p
- double precision :: PP,PS,SP,SS
- double precision :: xmax, xmin, zmax, zmin,x,z,t
-#ifdef USE_MPI
- double precision :: xmax_glob, xmin_glob, zmax_glob, zmin_glob
- integer :: ier
-#endif
- double precision, external :: ricker_Bielak_displ,ricker_Bielak_veloc,ricker_Bielak_accel
-
- ! user output
- 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')
-
- !=======================================================================
- !
- ! Calculation of the initial field for a plane wave
- !
- !=======================================================================
-
- 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/SOURCE'
- 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(NSOURCES > 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
- numat_local = numat
- if (numat /= 1) then
- if (myrank == 0) write(IOUT,*) 'not possible to have several materials with a plane wave, using the first material'
- numat_local = 1
- endif
-
- mu = poroelastcoef(2,1,numat_local)
- lambdaplus2mu = poroelastcoef(3,1,numat_local)
- denst = density(1,numat_local)
-
- cploc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
-
- ! P wave case
- if (source_type(1) == 1) then
-
- p=sin(angleforce(1))/cploc
- c_inc = cploc
- c_refl = 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) / &
- ( cos(2.d0*angleforce_refl)**2/csloc**3 &
- + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc)
-
- PS = 4.d0*p*cos(angleforce(1))*cos(2.d0*angleforce_refl) / &
- (csloc**2*(cos(2.d0*angleforce_refl)**2/csloc**3 &
- +4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc))
-
- 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)
-
- ! SV wave case
- 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*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(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))
-
- 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
- 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)
-
- ! 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
-
- ! get minimum and maximum values of mesh coordinates
- xmin = minval(coord(1,:))
- zmin = minval(coord(2,:))
- xmax = maxval(coord(1,:))
- zmax = maxval(coord(2,:))
-
-#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
- x0_source=x_source(1)
- z0_source=z_source(1)
-
- 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
-
- if (.not. over_critical_angle) then
-
- do i = 1,npoin
-
- x = coord(1,i)
- z = coord(2,i)
-
- ! z is from bottom to top therefore we take -z to make parallel with Aki & Richards
- z = z0_source - z
- x = x - x0_source
-
- t = 0.d0 + time_offset
-
- ! 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(3,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))
-
- ! 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(3,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(3,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
-
- endif
-
- end subroutine prepare_initialfield
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_initialfield_paco(myrank,nelemabs,left_bound,right_bound,bot_bound, &
- numabs,codeabs,ibool,nspec, &
- source_type,NSOURCES,c_inc,c_refl, &
- count_bottom,count_left,count_right)
-
- implicit none
- include "constants.h"
-
- integer :: myrank
-
- integer :: nelemabs
- integer :: left_bound(nelemabs*NGLLX)
- integer :: right_bound(nelemabs*NGLLX)
- integer :: bot_bound(nelemabs*NGLLZ)
- integer,dimension(nelemabs) :: numabs
- logical, dimension(4,nelemabs) :: codeabs
-
- integer :: nspec
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- integer :: NSOURCES
- integer :: source_type(NSOURCES)
-
- double precision :: c_inc,c_refl
-
- integer :: count_bottom,count_left,count_right
-
- ! local parameters
- integer :: ispecabs,ispec,i,j,iglob,ibegin,iend
-
- 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
-
- count_bottom=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_bottom=count_bottom+1
- iglob = ibool(i,j,ispec)
- bot_bound(count_bottom)=iglob
- enddo
- endif
- enddo
-
- end subroutine prepare_initialfield_paco
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/prepare_source_time_function.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/prepare_source_time_function.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/prepare_source_time_function.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,160 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine prepare_source_time_function(myrank,NSTEP,NSOURCES,source_time_function, &
- time_function_type,f0,tshift_src,factor,aval, &
- t0,nb_proc_source,deltat)
-
-! prepares source_time_function array
-
- implicit none
- include "constants.h"
-
- integer :: myrank,NSTEP
-
- integer :: NSOURCES
- integer, dimension(NSOURCES) :: time_function_type
- double precision, dimension(NSOURCES) :: f0,tshift_src,factor
- double precision, dimension(NSOURCES) :: aval
- double precision :: t0
- integer,dimension(NSOURCES) :: nb_proc_source
- double precision :: deltat
-
- real(kind=CUSTOM_REAL),dimension(NSOURCES,NSTEP) :: source_time_function
-
- ! local parameters
- double precision :: stf_used,time
- double precision, dimension(NSOURCES) :: hdur,hdur_gauss
- double precision, external :: netlib_specfun_erf
- integer :: it,i_source
-
-
- ! user output
- if (myrank == 0) then
- write(IOUT,*)
- write(IOUT,*) 'Saving the source time function in a text file...'
- write(IOUT,*)
- open(unit=55,file='OUTPUT_FILES/source.txt',status='unknown')
- endif
-
- ! ! loop on all the sources
- ! do i_source=1,NSOURCES
-
- ! loop on all the time steps
- do it = 1,NSTEP
-
- ! note: t0 is the simulation start time, tshift_src is the time shift of the source
- ! relative to this start time
-
- ! compute current time
- time = (it-1)*deltat
-
- stf_used = 0.d0
-
- ! loop on all the sources
- do i_source=1,NSOURCES
-
- if( time_function_type(i_source) == 1 ) then
-
- ! Ricker (second derivative of a Gaussian) source time function
- source_time_function(i_source,it) = - factor(i_source) * &
- (ONE-TWO*aval(i_source)*(time-t0-tshift_src(i_source))**2) * &
- exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
-
- ! source_time_function(i_source,it) = - factor(i_source) * &
- ! TWO*aval(i_source)*sqrt(aval(i_source))*&
- ! (time-t0-tshift_src(i_source))/pi * exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
-
- else if( time_function_type(i_source) == 2 ) then
-
- ! first derivative of a Gaussian source time function
- source_time_function(i_source,it) = - factor(i_source) * &
- TWO*aval(i_source)*(time-t0-tshift_src(i_source)) * &
- exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
-
- else if(time_function_type(i_source) == 3 .or. time_function_type(i_source) == 4) then
-
- ! Gaussian or Dirac (we use a very thin Gaussian instead) source time function
- source_time_function(i_source,it) = factor(i_source) * &
- exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
-
- else if(time_function_type(i_source) == 5) then
-
- ! Heaviside source time function (we use a very thin error function instead)
- 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-tshift_src(i_source))/hdur_gauss(i_source)))
-
- else
- call exit_MPI('unknown source time function')
- endif
-
- stf_used = stf_used + source_time_function(i_source,it)
-
- enddo
-
- ! output relative time in third column, in case user wants to check it as well
- ! if (myrank == 0 .and. i_source==1 ) write(55,*) sngl(time-t0-tshift_src(1)),real(source_time_function(1,it),4),sngl(time)
- if (myrank == 0) then
- ! note: earliest start time of the simulation is: (it-1)*deltat - t0
- write(55,*) sngl(time-t0),sngl(stf_used),sngl(time)
- endif
-
- !enddo
- enddo
-
- 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,NSOURCES
- source_time_function(i_source,:) = source_time_function(i_source,:) / nb_proc_source(i_source)
- enddo
-
- end subroutine prepare_source_time_function
Deleted: seismo/2D/SPECFEM2D/trunk/src/read_databases.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_databases.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/read_databases.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,836 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine read_databases_init(myrank,ipass, &
- simulation_title,SIMULATION_TYPE,SAVE_FORWARD,npgeo, &
- gnuplot,interpol,NTSTEP_BETWEEN_OUTPUT_INFO, &
- output_postscript_snapshot,output_color_image,colors,numbers, &
- meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows, &
- anglerec,initialfield,add_Bielak_conditions, &
- seismotype,imagetype,assign_external_model,READ_EXTERNAL_SEP_FILE, &
- outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON, &
- TURN_VISCATTENUATION_ON,Q0,freq0,p_sv, &
- NSTEP,deltat,NTSTEP_BETWEEN_OUTPUT_SEISMO,NSOURCES)
-
-! starts reading in parameters from input Database file
-
- implicit none
- include "constants.h"
-
- integer :: myrank,ipass
- character(len=60) simulation_title
- integer :: SIMULATION_TYPE,npgeo
- integer :: colors,numbers,subsamp,seismotype,imagetype
- logical :: SAVE_FORWARD,gnuplot,interpol,output_postscript_snapshot, &
- output_color_image
- logical :: meshvect,modelvect,boundvect,initialfield,add_Bielak_conditions, &
- assign_external_model,READ_EXTERNAL_SEP_FILE, &
- outputgrid,OUTPUT_ENERGY,p_sv
- logical :: TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON
-
- double precision :: cutsnaps,sizemax_arrows,anglerec
- double precision :: Q0,freq0
- double precision :: deltat
-
- integer :: NSTEP,NSOURCES
- integer :: NTSTEP_BETWEEN_OUTPUT_INFO,NTSTEP_BETWEEN_OUTPUT_SEISMO
-
- ! local parameters
- integer :: ier
- character(len=80) :: datlin
- character(len=256) :: prname
-
- ! opens Database file
- write(prname,230) myrank
- open(unit=IIN,file=prname,status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_MPI('error opening file OUTPUT/Database***')
-
- !--- read job title and skip remaining titles of the input file
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a50)") simulation_title
-
- !---- print the date, time and start-up banner
- if (myrank == 0 .and. ipass == 1) call datim(simulation_title)
-
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*)
- write(IOUT,*) '*********************'
- write(IOUT,*) '**** ****'
- write(IOUT,*) '**** SPECFEM2D ****'
- write(IOUT,*) '**** ****'
- write(IOUT,*) '*********************'
- endif
-
- !---- read parameters from input file
- read(IIN,"(a80)") datlin
- read(IIN,*) SIMULATION_TYPE, SAVE_FORWARD
-
- read(IIN,"(a80)") datlin
- read(IIN,*) npgeo
-
- read(IIN,"(a80)") datlin
- read(IIN,*) gnuplot,interpol
-
- read(IIN,"(a80)") datlin
- read(IIN,*) NTSTEP_BETWEEN_OUTPUT_INFO
-
- read(IIN,"(a80)") datlin
- read(IIN,*) output_postscript_snapshot,output_color_image,colors,numbers
-
- read(IIN,"(a80)") datlin
- read(IIN,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
- cutsnaps = cutsnaps / 100.d0
-
- read(IIN,"(a80)") datlin
- read(IIN,*) anglerec
-
- read(IIN,"(a80)") datlin
- read(IIN,*) initialfield,add_Bielak_conditions
- if(add_Bielak_conditions .and. .not. initialfield) &
- stop 'need to have an initial field to add Bielak plane wave conditions'
-
- read(IIN,"(a80)") datlin
- read(IIN,*) seismotype,imagetype
- if(seismotype < 1 .or. seismotype > 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 /= 6)) then
- print*, '***** WARNING *****'
- print*, 'seismotype =',seismotype
- 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
-
- read(IIN,"(a80)") datlin
- read(IIN,*) assign_external_model,READ_EXTERNAL_SEP_FILE
-
- read(IIN,"(a80)") datlin
- read(IIN,*) outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON
-
- read(IIN,"(a80)") datlin
- read(IIN,*) TURN_VISCATTENUATION_ON,Q0,freq0
-
- read(IIN,"(a80)") datlin
- read(IIN,*) p_sv
-
- !---- check parameters read
- 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,&
- READ_EXTERNAL_SEP_FILE,TURN_ATTENUATION_ON, &
- outputgrid,OUTPUT_ENERGY
- write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
- endif
-
- !---- read time step
- read(IIN,"(a80)") datlin
- read(IIN,*) NSTEP,deltat
- if (myrank == 0 .and. ipass == 1) write(IOUT,703) NSTEP,deltat,NSTEP*deltat
-
- if( SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. &
- (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)
-
- !---- read source information
- read(IIN,"(a80)") datlin
- read(IIN,*) NSOURCES
-
- ! output formats
-230 format('./OUTPUT_FILES/Database',i5.5)
-
-200 format(//1x,'C o n t r o l',/1x,13('='),//5x,&
- 'Number of spectral element control nodes. . .(npgeo) =',i8/5x, &
- 'Number of space dimensions. . . . . . . . . . (NDIM) =',i8)
-
-600 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Display frequency . . . (NTSTEP_BETWEEN_OUTPUT_INFO) = ',i6/ 5x, &
- 'Color display . . . . . . . . . . . . . . . (colors) = ',i6/ 5x, &
- ' == 0 black and white display ', / 5x, &
- ' == 1 color display ', /5x, &
- 'Numbered mesh . . . . . . . . . . . . . . .(numbers) = ',i6/ 5x, &
- ' == 0 do not number the mesh ', /5x, &
- ' == 1 number the mesh ')
-
-700 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Seismograms recording type . . . . . . .(seismotype) = ',i6/5x, &
- 'Angle for first line of receivers. . . . .(anglerec) = ',f6.2)
-
-750 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Read external initial field. . . . . .(initialfield) = ',l6/5x, &
- 'Add Bielak conditions . . . .(add_Bielak_conditions) = ',l6/5x, &
- 'Assign external model . . . .(assign_external_model) = ',l6/5x, &
- 'Read external SEP file . . .(READ_EXTERNAL_SEP_FILE) = ',l6/5x, &
- 'Turn attenuation on or off. . .(TURN_ATTENUATION_ON) = ',l6/5x, &
- 'Save grid in external file or not. . . .(outputgrid) = ',l6/5x, &
- 'Save a file with total energy or not.(OUTPUT_ENERGY) = ',l6)
-
-800 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Vector display type . . . . . . . . . . .(imagetype) = ',i6/5x, &
- 'Percentage of cut for vector plots . . . .(cutsnaps) = ',f6.2/5x, &
- 'Subsampling for velocity model display. . .(subsamp) = ',i6)
-
-703 format(//' I t e r a t i o n s '/1x,19('='),//5x, &
- 'Number of time iterations . . . . .(NSTEP) =',i8,/5x, &
- 'Time step increment. . . . . . . .(deltat) =',1pe15.6,/5x, &
- 'Total simulation duration . . . . . (ttot) =',1pe15.6)
-
- end subroutine read_databases_init
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_sources(NSOURCES,source_type,time_function_type, &
- x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce)
-
-! reads source parameters
-
- implicit none
- include "constants.h"
-
- integer :: NSOURCES
- integer, dimension(NSOURCES) :: source_type,time_function_type
- double precision, dimension(NSOURCES) :: x_source,z_source, &
- Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
-
- ! local parameters
- integer :: i_source
- character(len=80) :: datlin
-
- ! initializes
- source_type(:) = 0
- time_function_type(:) = 0
- x_source(:) = 0.d0
- z_source(:) = 0.d0
- Mxx(:) = 0.d0
- Mzz(:) = 0.d0
- Mxz(:) = 0.d0
- f0(:) = 0.d0
- tshift_src(:) = 0.d0
- factor(:) = 0.d0
- angleforce(:) = 0.d0
-
- ! reads in source info from Database file
- do i_source=1,NSOURCES
- read(IIN,"(a80)") datlin
- read(IIN,*) source_type(i_source),time_function_type(i_source), &
- x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
- factor(i_source),angleforce(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
- enddo
-
- end subroutine read_databases_sources
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_atten(N_SLS,f0_attenuation)
-
-! reads attenuation information
-
- implicit none
- include "constants.h"
-
- integer :: N_SLS
- double precision :: f0_attenuation
-
- ! local parameters
- character(len=80) :: datlin
-
- read(IIN,"(a80)") datlin
- read(IIN,*) N_SLS, f0_attenuation
-
- end subroutine read_databases_atten
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_coorg_elem(myrank,ipass,npgeo,coorg,numat,ngnod,nspec, &
- pointsdisp,plot_lowerleft_corner_only, &
- nelemabs,nelem_acoustic_surface, &
- num_fluid_solid_edges,num_fluid_poro_edges, &
- num_solid_poro_edges,nnodes_tangential_curve)
-
-! reads the spectral macrobloc nodal coordinates
-
- implicit none
- include "constants.h"
-
- integer :: myrank,ipass,npgeo
- double precision, dimension(NDIM,npgeo) :: coorg
-
- integer :: numat,ngnod,nspec
- integer :: pointsdisp
- logical :: plot_lowerleft_corner_only
- integer :: nelemabs,nelem_acoustic_surface, &
- num_fluid_solid_edges,num_fluid_poro_edges, &
- num_solid_poro_edges,nnodes_tangential_curve
-
- ! local parameters
- integer :: ipoin,ip,id
- double precision, dimension(:), allocatable :: coorgread
- character(len=80) :: datlin
-
- ! initializes
- coorg(:,:) = 0.d0
-
- ! reads the spectral macrobloc nodal coordinates
- read(IIN,"(a80)") datlin
-
- ! reads in values
- ipoin = 0
- allocate(coorgread(NDIM))
- do ip = 1,npgeo
- ! reads coordinates
- read(IIN,*) ipoin,(coorgread(id),id =1,NDIM)
-
- if(ipoin<1 .or. ipoin>npgeo) call exit_MPI('Wrong control point number')
-
- ! saves coordinate array
- coorg(:,ipoin) = coorgread
-
- enddo
- deallocate(coorgread)
-
- !---- read the basic properties of the spectral elements
- read(IIN,"(a80)") datlin
- read(IIN,*) numat,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
-
- read(IIN,"(a80)") datlin
- 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
-
- !---- print element group main parameters
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,107)
- write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
- endif
-
- ! output formats
-107 format(/5x,'--> Isoparametric Spectral Elements <--',//)
-
-207 format(5x,'Number of spectral elements . . . . . (nspec) =',i7,/5x, &
- 'Number of control nodes per element . (ngnod) =',i7,/5x, &
- 'Number of points in X-direction . . . (NGLLX) =',i7,/5x, &
- 'Number of points in Y-direction . . . (NGLLZ) =',i7,/5x, &
- 'Number of points per element. . .(NGLLX*NGLLZ) =',i7,/5x, &
- 'Number of points for display . . .(pointsdisp) =',i7,/5x, &
- 'Number of element material sets . . . (numat) =',i7,/5x, &
- 'Number of absorbing elements . . . .(nelemabs) =',i7)
-
- end subroutine read_databases_coorg_elem
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_mato(ipass,nspec,ngnod,kmato,knods, &
- perm,antecedent_list)
-
-! reads spectral macrobloc data
-
- implicit none
- include "constants.h"
-
- integer :: ipass,ngnod,nspec
- integer, dimension(nspec) :: kmato
- integer, dimension(ngnod,nspec) :: knods
-
- integer, dimension(nspec) :: perm,antecedent_list
-
- ! local parameters
- integer :: n,k,ispec,kmato_read
- integer, dimension(:), allocatable :: knods_read
- character(len=80) :: datlin
-
- ! initializes
- kmato(:) = 0
- knods(:,:) = 0
-
- ! reads spectral macrobloc data
- read(IIN,"(a80)") datlin
-
- ! reads in values
- allocate(knods_read(ngnod))
- n = 0
- do ispec = 1,nspec
- ! format: #element_id #material_id #node_id1 #node_id2 #...
- read(IIN,*) n,kmato_read,(knods_read(k), k=1,ngnod)
- if(ipass == 1) then
- ! material association
- kmato(n) = kmato_read
- ! element control node indices
- knods(:,n)= knods_read(:)
- else if(ipass == 2) then
- kmato(perm(antecedent_list(n))) = kmato_read
- knods(:,perm(antecedent_list(n)))= knods_read(:)
- else
- call exit_MPI('error: maximum is 2 passes')
- endif
- enddo
- deallocate(knods_read)
-
-
- end subroutine read_databases_mato
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_ninterface(ninterface,max_interface_size)
-
-! reads in interface dimensions
-
- implicit none
- include "constants.h"
-
- integer :: ninterface,max_interface_size
-
- ! local parameters
- character(len=80) :: datlin
-
- read(IIN,"(a80)") datlin
- read(IIN,*) ninterface, max_interface_size
-
- end subroutine read_databases_ninterface
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_interfaces(ipass,ninterface,nspec,max_interface_size, &
- my_neighbours,my_nelmnts_neighbours,my_interfaces, &
- perm,antecedent_list)
-
-! reads in interfaces
-
- implicit none
- include "constants.h"
-
- integer :: ipass,nspec
- integer :: ninterface,max_interface_size
- integer, dimension(ninterface) :: my_neighbours,my_nelmnts_neighbours
- integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
-
- integer, dimension(nspec) :: perm,antecedent_list
-
- ! local parameters
- integer :: num_interface,ie,my_interfaces_read
-
- ! initializes
- my_neighbours(:) = -1
- my_nelmnts_neighbours(:) = 0
- my_interfaces(:,:,:) = -1
-
- ! reads in interfaces
- do num_interface = 1, ninterface
- ! format: #process_interface_id #number_of_elements_on_interface
- ! where
- ! process_interface_id = rank of (neighbor) process to share MPI interface with
- ! number_of_elements_on_interface = number of interface elements
- read(IIN,*) my_neighbours(num_interface), my_nelmnts_neighbours(num_interface)
-
- ! loops over interface elements
- do ie = 1, my_nelmnts_neighbours(num_interface)
- ! format: #(1)spectral_element_id #(2)interface_type #(3)node_id1 #(4)node_id2
- !
- ! interface types:
- ! 1 - corner point only
- ! 2 - element edge
- read(IIN,*) my_interfaces_read, my_interfaces(2,ie,num_interface), &
- my_interfaces(3,ie,num_interface), my_interfaces(4,ie,num_interface)
-
- 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
- call exit_MPI('error: maximum number of passes is 2')
- endif
-
- enddo
- enddo
-
- end subroutine read_databases_interfaces
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_absorbing(myrank,ipass,nelemabs,nspec,anyabs, &
- ibegin_bottom,iend_bottom,jbegin_right,jend_right, &
- ibegin_top,iend_top,jbegin_left,jend_left, &
- numabs,codeabs,perm,antecedent_list, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- ib_right,ib_left,ib_bottom,ib_top)
-
-! reads in absorbing edges
-
- implicit none
- include "constants.h"
-
- integer :: myrank,ipass,nspec
- integer :: nelemabs
- integer, dimension(nelemabs) :: numabs,ibegin_bottom,iend_bottom, &
- ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
- logical, dimension(4,nelemabs) :: codeabs
- logical :: anyabs
- integer, dimension(nspec) :: perm,antecedent_list
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
-
- integer, dimension(nelemabs) :: ib_right,ib_left,ib_bottom,ib_top
-
- ! local parameters
- integer :: inum,numabsread
- logical :: codeabsread(4)
- character(len=80) :: datlin
-
- ! initializes
- codeabs(:,:) = .false.
-
- ibegin_bottom(:) = 0
- iend_bottom(:) = 0
- ibegin_top(:) = 0
- iend_top(:) = 0
-
- jbegin_left(:) = 0
- jend_left(:) = 0
- jbegin_right(:) = 0
- jend_right(:) = 0
-
- nspec_xmin = 0
- nspec_xmax = 0
- nspec_zmin = 0
- nspec_zmax = 0
-
- ib_right(:) = 0
- ib_left(:) = 0
- ib_bottom(:) = 0
- ib_top(:) = 0
-
- ! reads in absorbing edges
- read(IIN,"(a80)") datlin
-
- ! reads in values
- if( anyabs ) then
- ! reads absorbing boundaries
- do inum = 1,nelemabs
- read(IIN,*) numabsread,codeabsread(1),codeabsread(2),codeabsread(3),&
- codeabsread(4), ibegin_bottom(inum), iend_bottom(inum), &
- jbegin_right(inum), jend_right(inum), ibegin_top(inum), &
- iend_top(inum), jbegin_left(inum), jend_left(inum)
-
- if(numabsread < 1 .or. numabsread > nspec) &
- call exit_MPI('Wrong absorbing element number')
-
- 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
-
- ! boundary element numbering
- do inum = 1,nelemabs
- if (codeabs(IBOTTOM,inum)) then
- nspec_zmin = nspec_zmin + 1
- ib_bottom(inum) = nspec_zmin
- endif
- if (codeabs(IRIGHT,inum)) then
- nspec_xmax = nspec_xmax + 1
- ib_right(inum) = nspec_xmax
- endif
- if (codeabs(ITOP,inum)) then
- nspec_zmax = nspec_zmax + 1
- ib_top(inum) = nspec_zmax
- endif
- if (codeabs(ILEFT,inum)) then
- nspec_xmin = nspec_xmin + 1
- ib_left(inum) = nspec_xmin
- endif
- enddo
-
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Number of absorbing elements: ',nelemabs
- write(IOUT,*) ' nspec_xmin = ',nspec_xmin
- write(IOUT,*) ' nspec_xmax = ',nspec_xmax
- write(IOUT,*) ' nspec_zmin = ',nspec_zmin
- write(IOUT,*) ' nspec_zmax = ',nspec_zmax
- write(IOUT,*)
- endif
-
- endif
-
- end subroutine read_databases_absorbing
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_free_surf(ipass,nelem_acoustic_surface,nspec, &
- acoustic_edges,perm,antecedent_list,any_acoustic_edges)
-
-! reads acoustic free surface data
-
- implicit none
- include "constants.h"
-
- integer :: ipass,nspec
- integer :: nelem_acoustic_surface
- integer, dimension(4,nelem_acoustic_surface) :: acoustic_edges
- logical :: any_acoustic_edges
-
- integer, dimension(nspec) :: perm,antecedent_list
-
- ! local parameters
- integer :: inum,acoustic_edges_read
- character(len=80) :: datlin
-
- ! initializes
- acoustic_edges(:,:) = 0
-
- ! reads in any possible free surface edges
- read(IIN,"(a80)") datlin
-
- if( any_acoustic_edges ) then
- do inum = 1,nelem_acoustic_surface
- read(IIN,*) acoustic_edges_read, acoustic_edges(2,inum), acoustic_edges(3,inum), &
- acoustic_edges(4,inum)
-
- 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
-
- endif
-
- end subroutine read_databases_free_surf
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_coupled(ipass,nspec,num_fluid_solid_edges,any_fluid_solid_edges, &
- fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec, &
- num_fluid_poro_edges,any_fluid_poro_edges, &
- fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec, &
- num_solid_poro_edges,any_solid_poro_edges, &
- solid_poro_elastic_ispec,solid_poro_poroelastic_ispec, &
- perm,antecedent_list)
-
-! reads acoustic elastic coupled edges
-! reads acoustic poroelastic coupled edges
-! reads poroelastic elastic coupled edges
-
- implicit none
- include "constants.h"
-
- integer :: ipass,nspec
-
- integer :: num_fluid_solid_edges
- logical :: any_fluid_solid_edges
- integer, dimension(num_fluid_solid_edges) :: fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec
-
- integer :: num_fluid_poro_edges
- logical :: any_fluid_poro_edges
- integer, dimension(num_fluid_poro_edges) :: fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec
-
- integer :: num_solid_poro_edges
- logical :: any_solid_poro_edges
- integer, dimension(num_solid_poro_edges) :: solid_poro_elastic_ispec,solid_poro_poroelastic_ispec
-
- integer, dimension(nspec) :: perm,antecedent_list
-
- ! local parameters
- integer :: inum
- integer :: fluid_solid_acoustic_ispec_read,fluid_solid_elastic_ispec_read, &
- fluid_poro_acoustic_ispec_read,fluid_poro_poro_ispec_read, &
- solid_poro_poro_ispec_read,solid_poro_elastic_ispec_read
- character(len=80) :: datlin
-
- ! initializes
- fluid_solid_acoustic_ispec(:) = 0
- fluid_solid_elastic_ispec(:) = 0
- fluid_poro_acoustic_ispec(:) = 0
- fluid_poro_poroelastic_ispec(:) = 0
- solid_poro_elastic_ispec(:) = 0
- solid_poro_poroelastic_ispec(:) = 0
-
- ! reads acoustic elastic coupled edges
- read(IIN,"(a80)") datlin
-
- if ( any_fluid_solid_edges ) then
- do inum = 1, num_fluid_solid_edges
- 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
- endif
-
- ! reads acoustic poroelastic coupled edges
- read(IIN,"(a80)") datlin
-
- if ( any_fluid_poro_edges ) then
- do inum = 1, num_fluid_poro_edges
- read(IIN,*) fluid_poro_acoustic_ispec_read,fluid_poro_poro_ispec_read
-
- if(ipass == 1) then
- fluid_poro_acoustic_ispec(inum) = fluid_poro_acoustic_ispec_read
- fluid_poro_poroelastic_ispec(inum) = fluid_poro_poro_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_poro_ispec_read))
- else
- call exit_MPI('error: maximum number of passes is 2')
- endif
- enddo
- endif
-
- ! reads poroelastic elastic coupled edges
- read(IIN,"(a80)") datlin
-
- if ( any_solid_poro_edges ) then
- do inum = 1, num_solid_poro_edges
- read(IIN,*) solid_poro_poro_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_poro_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_poro_ispec_read))
- else
- call exit_MPI('error: maximum number of passes is 2')
- endif
- enddo
- endif
-
- end subroutine read_databases_coupled
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_final(nnodes_tangential_curve,nodes_tangential_curve, &
- force_normal_to_surface,rec_normal_to_surface, &
- any_tangential_curve )
-
-! reads tangential detection curve
-! and closes Database file
-
- implicit none
- include "constants.h"
-
- integer :: nnodes_tangential_curve
- logical :: any_tangential_curve
- double precision, dimension(2,nnodes_tangential_curve) :: nodes_tangential_curve
-
- logical :: force_normal_to_surface,rec_normal_to_surface
-
- ! local parameters
- integer :: i
- character(len=80) :: datlin
-
- ! initializes
- nodes_tangential_curve(:,:) = 0.d0
-
- ! reads tangential detection curve
- read(IIN,"(a80)") datlin
- read(IIN,*) force_normal_to_surface,rec_normal_to_surface
-
- if( any_tangential_curve ) then
- 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.
- endif
-
- ! closes input Database file
- close(IIN)
-
- end subroutine read_databases_final
-
-
\ No newline at end of file
Deleted: seismo/2D/SPECFEM2D/trunk/src/read_external_model.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_external_model.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/read_external_model.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,188 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine read_external_model(any_acoustic,any_elastic,any_poroelastic, &
- elastic,poroelastic,anisotropic,nspec,npoin,N_SLS,ibool, &
- f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
- inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent, &
- inv_tau_sigma_nu1,inv_tau_sigma_nu2,phi_nu1,phi_nu2,Mu_nu1,Mu_nu2,&
- coord,kmato,myrank,rhoext,vpext,vsext, &
- Qp_attenuationext,Qs_attenuationext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,READ_EXTERNAL_SEP_FILE)
-
- implicit none
- include "constants.h"
-
- integer :: nspec,myrank,npoin
- double precision :: f0_attenuation
-
- ! Mesh
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- double precision, dimension(NDIM,npoin) :: coord
-
- ! Material properties
- logical :: any_acoustic,any_elastic,any_poroelastic,READ_EXTERNAL_SEP_FILE
- integer, dimension(nspec) :: kmato
- logical, dimension(nspec) :: elastic,poroelastic
- double precision, dimension(NGLLX,NGLLZ,nspec) :: rhoext,vpext,vsext
-
- ! for attenuation
- integer :: N_SLS
- double precision :: Mu_nu1_sent,Mu_nu2_sent
- double precision, dimension(N_SLS) :: inv_tau_sigma_nu1_sent,phi_nu1_sent, &
- inv_tau_sigma_nu2_sent,phi_nu2_sent
- 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
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Qp_attenuationext,Qs_attenuationext
-
- ! for anisotropy
- logical, dimension(nspec) :: anisotropic
- double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c13ext,c15ext,c33ext,c35ext,c55ext
-
- ! Local variables
- integer :: i,j,ispec,iglob
- double precision :: previous_vsext
- double precision :: tmp1, tmp2,tmp3
-
- if(READ_EXTERNAL_SEP_FILE) then
- write(IOUT,*)
- write(IOUT,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
- write(IOUT,*) 'Assigning external velocity and density model (elastic (no attenuation) and/or acoustic)...'
- write(IOUT,*) 'Read outside SEG model...'
- write(IOUT,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
-
- open(unit=1001,file='DATA/model_velocity.dat_input',status='unknown')
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- read(1001,*) tmp1,tmp2,tmp3,rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec)
- ! vsext(i,j,ispec)=0.0
- ! Qp, Qs : dummy values. If attenuation needed than the "read" line and model_velocity.dat_input
- ! need to be modified to provide Qp & Qs values
- Qp_attenuationext(i,j,ispec) = 10.d0
- Qs_attenuationext(i,j,ispec) = 10.d0
- end do
- end do
- end do
- close(1001)
-
- else
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
- call define_external_model(coord(1,iglob),coord(2,iglob),kmato(ispec),myrank,&
- rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec), &
- Qp_attenuationext(i,j,ispec),Qs_attenuationext(i,j,ispec),&
- c11ext(i,j,ispec),c13ext(i,j,ispec),c15ext(i,j,ispec), &
- c33ext(i,j,ispec),c35ext(i,j,ispec),c55ext(i,j,ispec))
-
- if((c11ext(i,j,ispec) /= 0) .or. (c13ext(i,j,ispec) /= 0) .or. (c15ext(i,j,ispec) /= 0) .or. &
- (c33ext(i,j,ispec) /= 0) .or. (c35ext(i,j,ispec) /= 0) .or. (c55ext(i,j,ispec) /= 0)) then
- ! vp, vs : dummy values, trick to avoid floating point errors
- vpext(i,j,ispec) = 20.d0
- vsext(i,j,ispec) = 10.d0
- end if
- end do
- end do
- end do
- end if
-
- ! initializes
- any_acoustic = .false.
- any_elastic = .false.
- any_poroelastic = .false.
-
- anisotropic(:) = .false.
- elastic(:) = .false.
- poroelastic(:) = .false.
-
- do ispec = 1,nspec
- previous_vsext = -1.d0
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- if(.not. (i == 1 .and. j == 1) .and. &
- ((vsext(i,j,ispec) >= TINYVAL .and. previous_vsext < TINYVAL) .or. &
- (vsext(i,j,ispec) < TINYVAL .and. previous_vsext >= TINYVAL))) &
- call exit_MPI('external velocity model cannot be both fluid and solid inside the same spectral element')
-
- if((c11ext(i,j,ispec) /= 0) .or. (c13ext(i,j,ispec) /= 0) .or. (c15ext(i,j,ispec) /= 0) .or. &
- (c33ext(i,j,ispec) /= 0) .or. (c35ext(i,j,ispec) /= 0) .or. (c55ext(i,j,ispec) /= 0)) then
- anisotropic(ispec) = .true.
- poroelastic(ispec) = .false.
- elastic(ispec) = .true.
- any_elastic = .true.
- Qp_attenuationext(i,j,ispec) = 10.d0
- Qs_attenuationext(i,j,ispec) = 10.d0
- elseif(vsext(i,j,ispec) < TINYVAL) then
- elastic(ispec) = .false.
- poroelastic(ispec) = .false.
- any_acoustic = .true.
- else
- poroelastic(ispec) = .false.
- elastic(ispec) = .true.
- any_elastic = .true.
- endif
-
- call attenuation_model(N_SLS,Qp_attenuationext(i,j,ispec),Qs_attenuationext(i,j,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)
- 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
- previous_vsext = vsext(i,j,ispec)
- enddo
- enddo
- enddo
-
- end subroutine read_external_model
Deleted: seismo/2D/SPECFEM2D/trunk/src/read_interfaces_file.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_interfaces_file.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/read_interfaces_file.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,179 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-module interfaces_file
-
- ! note: we use this module definition only to be able to allocate
- ! arrays for receiverlines and materials in this subroutine rather than in the main
- ! routine in meshfem2D.F90
-
- ! note 2: the filename ending is .F90 to have pre-compilation with pragmas
- ! (like #ifndef USE_MPI) working properly
-
- implicit none
-
-contains
-
- subroutine read_interfaces_file(interfacesfile,max_npoints_interface, &
- number_of_interfaces,npoints_interface_bottom, &
- number_of_layers,nz_layer,nx,nz,nxread,nzread,ngnod, &
- nelmnts,elmnts)
- implicit none
- include "constants.h"
-
- character(len=100) :: interfacesfile
-
- integer :: max_npoints_interface,number_of_interfaces,npoints_interface_bottom
- integer :: number_of_layers,nx,nz,nxread,nzread,ngnod
- integer :: nelmnts
- integer, dimension(:), pointer :: nz_layer
- integer, dimension(:), pointer :: elmnts
-
- ! local parameters
- integer :: ios,interface_current,ipoint_current,ilayer,i,j,num_elmnt
- double precision :: xinterface_dummy,zinterface_dummy,xinterface_dummy_previous
-
- ! get interface data from external file to count the spectral elements along Z
- print *,'Reading interface data from file DATA/',interfacesfile(1:len_trim(interfacesfile)),' to count the spectral elements'
- open(unit=IIN_INTERFACES,file='DATA/'//interfacesfile,status='old',iostat=ios)
- if( ios /= 0 ) then
- print*,'error opening file: ',trim('DATA/'//interfacesfile)
- stop 'error read interface file in meshfem2D'
- endif
-
- max_npoints_interface = -1
-
- ! read number of interfaces
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,number_of_interfaces)
- if(number_of_interfaces < 2) stop 'not enough interfaces (minimum is 2)'
-
- ! loop on all the interfaces
- do interface_current = 1,number_of_interfaces
-
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_bottom)
- if(npoints_interface_bottom < 2) stop 'not enough interface points (minimum is 2)'
- max_npoints_interface = max(npoints_interface_bottom,max_npoints_interface)
- print *,'Reading ',npoints_interface_bottom,' points for interface ',interface_current
-
- ! loop on all the points describing this interface
- xinterface_dummy_previous = -HUGEVAL
- do ipoint_current = 1,npoints_interface_bottom
- call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK,xinterface_dummy,zinterface_dummy)
- if(ipoint_current > 1 .and. xinterface_dummy <= xinterface_dummy_previous) &
- stop 'interface points must be sorted in increasing X'
- xinterface_dummy_previous = xinterface_dummy
- enddo
- enddo
-
- ! define number of layers
- number_of_layers = number_of_interfaces - 1
-
- allocate(nz_layer(number_of_layers))
-
- ! loop on all the layers
- do ilayer = 1,number_of_layers
-
- ! read number of spectral elements in vertical direction in this layer
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,nz_layer(ilayer))
- if(nz_layer(ilayer) < 1) stop 'not enough spectral elements along Z in layer (minimum is 1)'
- print *,'There are ',nz_layer(ilayer),' spectral elements along Z in layer ',ilayer
-
- enddo
-
- close(IIN_INTERFACES)
-
- ! compute total number of spectral elements in vertical direction
- nz = sum(nz_layer)
-
- print *
- print *,'Total number of spectral elements along Z = ',nz
- print *
-
- nxread = nx
- nzread = nz
-
- ! multiply by 2 if elements have 9 nodes
- if(ngnod == 9) then
- nx = nx * 2
- nz = nz * 2
- nz_layer(:) = nz_layer(:) * 2
- endif
-
- nelmnts = nxread * nzread
- allocate(elmnts(0:ngnod*nelmnts-1))
-
- if ( ngnod == 4 ) then
- num_elmnt = 0
- do j = 1, nzread
- do i = 1, nxread
- elmnts(num_elmnt*ngnod) = (j-1)*(nxread+1) + (i-1)
- elmnts(num_elmnt*ngnod+1) = (j-1)*(nxread+1) + (i-1) + 1
- 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
- enddo
- enddo
- else
- num_elmnt = 0
- do j = 1, nzread
- do i = 1, nxread
- elmnts(num_elmnt*ngnod) = (j-1)*(nxread+1) + (i-1)
- elmnts(num_elmnt*ngnod+1) = (j-1)*(nxread+1) + (i-1) + 1
- elmnts(num_elmnt*ngnod+2) = j*(nxread+1) + (i-1) + 1
- elmnts(num_elmnt*ngnod+3) = j*(nxread+1) + (i-1)
- elmnts(num_elmnt*ngnod+4) = (nxread+1)*(nzread+1) + (j-1)*nxread + (i-1)
- elmnts(num_elmnt*ngnod+5) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2 + 2
- elmnts(num_elmnt*ngnod+6) = (nxread+1)*(nzread+1) + j*nxread + (i-1)
- 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
- enddo
- enddo
-
- endif
-
-
- end subroutine read_interfaces_file
-
-end module interfaces_file
Deleted: seismo/2D/SPECFEM2D/trunk/src/read_materials.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_materials.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/read_materials.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,199 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine read_materials(nb_materials,icodemat,cp,cs, &
- aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
- Qp,Qs,rho_s,rho_f,phi,tortuosity, &
- permxx,permxz,permzz,kappa_s,kappa_f,kappa_fr, &
- eta_f,mu_fr)
-
-! reads in material definitions in DATA/Par_file
-
- implicit none
- include "constants.h"
-
- integer :: nb_materials
-
- integer, dimension(nb_materials) :: icodemat
-
- double precision, dimension(nb_materials) :: rho_s,cp,cs, &
- aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
- double precision, dimension(nb_materials) :: rho_f,phi,tortuosity,permxx,permxz,&
- permzz,kappa_s,kappa_f,kappa_fr,eta_f,mu_fr
-
- ! local parameters
- integer :: imaterial,i,icodematread
- double precision :: val0read,val1read,val2read,val3read,val4read, &
- val5read,val6read,val7read,val8read,val9read,val10read,val11read,val12read
-
- ! initializes material properties
- icodemat(:) = 0
- cp(:) = 0.d0
- cs(:) = 0.d0
- aniso3(:) = 0.d0
- aniso4(:) = 0.d0
- aniso5(:) = 0.d0
- aniso6(:) = 0.d0
- aniso7(:) = 0.d0
- aniso8(:) = 0.d0
- Qp(:) = 0.d0
- Qs(:) = 0.d0
- rho_s(:) = 0.d0
- rho_f(:) = 0.d0
- phi(:) = 0.d0
- tortuosity(:) = 0.d0
- permxx(:) = 0.d0
- permxz(:) = 0.d0
- permzz(:) = 0.d0
- kappa_s(:) = 0.d0
- kappa_f(:) = 0.d0
- kappa_fr(:) = 0.d0
- eta_f(:) = 0.d0
- mu_fr(:) = 0.d0
-
- ! reads in material parameters
- do imaterial=1,nb_materials
- call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread, &
- val0read,val1read,val2read,val3read, &
- val4read,val5read,val6read,val7read, &
- val8read,val9read,val10read,val11read,val12read)
-
- ! checks material id
- if(i < 1 .or. i > nb_materials) stop 'Wrong material number!'
- icodemat(i) = icodematread
-
-
- ! sets material properties
- if(icodemat(i) == ISOTROPIC_MATERIAL) then
-
- ! isotropic materials
-
- 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
- elseif (icodemat(i) == ANISOTROPIC_MATERIAL) then
-
- ! anisotropic materials
-
- rho_s(i) = val0read
- cp(i) = val1read
- cs(i) = val2read
- aniso3(i) = val3read
- aniso4(i) = val4read
- aniso5(i) = val5read
- aniso6(i) = val6read
- aniso7(i) = val7read
- aniso8(i) = val8read
- Qp(i) = val9read
- Qs(i) = val10read
- else
-
- ! poroelastic materials
-
- 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) then
- stop 'negative value of modulus'
- end if
- if(Qs(i) <= 0.d0) stop 'negative value of Qs'
- endif
- enddo
-
- ! user output
- print *
- print *, 'Nb of solid, fluid or porous materials = ',nb_materials
- print *
- do i=1,nb_materials
- if(icodemat(i) /= ANISOTROPIC_MATERIAL .and. icodemat(i) /= POROELASTIC_MATERIAL) then
- print *,'Material #',i,' isotropic'
- print *,'rho,cp,cs = ',rho_s(i),cp(i),cs(i),Qp(i),Qs(i)
- if(cs(i) < TINYVAL) then
- print *,'Material is fluid'
- else
- print *,'Material is solid'
- 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 *,'rho,cp,cs = ',rho_s(i),cp(i),cs(i)
- print*,'c11,c13,c15,c33,c35,c55 = ',aniso3(i),aniso4(i),aniso5(i),aniso6(i),aniso7(i),aniso8(i)
- print *,'Qp,Qs = ',Qp(i),Qs(i)
- endif
- print *
- enddo
-
- end subroutine read_materials
Deleted: seismo/2D/SPECFEM2D/trunk/src/read_parameter_file.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_parameter_file.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/read_parameter_file.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,327 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-module parameter_file
-
- ! note: we use this module definition only to be able to allocate
- ! arrays for receiverlines and materials in this subroutine rather than in the main
- ! routine in meshfem2D.F90
-
- ! note 2: the filename ending is .F90 to have pre-compilation with pragmas
- ! (like #ifndef USE_MPI) working properly
-
- implicit none
- character(len=100) :: interfacesfile,title
-
- integer :: SIMULATION_TYPE
- logical :: SAVE_FORWARD,read_external_mesh
-
- character(len=256) :: mesh_file, nodes_coords_file, materials_file, &
- free_surface_file, absorbing_surface_file
- character(len=256) :: tangential_detection_curve_file
-
- ! variables used for partitioning
- integer :: nproc,partitioning_method
-
- double precision :: xmin,xmax
- integer :: nx,ngnod
-
- logical :: initialfield,add_Bielak_conditions,assign_external_model, &
- READ_EXTERNAL_SEP_FILE,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON
-
- double precision :: Q0,freq0
-
- logical :: p_sv
- logical :: any_abs,absbottom,absright,abstop,absleft
-
- integer :: nt
- double precision :: deltat
-
- integer :: NSOURCES
- logical :: force_normal_to_surface
-
- ! variables used for attenuation
- integer :: N_SLS
- double precision :: f0_attenuation
-
- integer :: seismotype
- logical :: generate_STATIONS
-
- integer :: nreceiverlines
- double precision :: anglerec
- logical :: rec_normal_to_surface
-
- integer, dimension(:), pointer :: nrec
- double precision, dimension(:), pointer :: xdeb,zdeb,xfin,zfin
- logical, dimension(:), pointer :: enreg_surf_same_vertical
-
- integer :: NTSTEP_BETWEEN_OUTPUT_INFO
- logical :: output_postscript_snapshot,output_color_image
- integer :: imagetype
- double precision :: cutsnaps
- logical :: meshvect,modelvect,boundvect,interpol
- integer :: pointsdisp,subsamp
- double precision :: sizemax_arrows
- logical :: gnuplot,outputgrid,OUTPUT_ENERGY
- logical :: plot_lowerleft_corner_only
-
- ! to store density and velocity model
- integer :: nb_materials
- integer, dimension(:),pointer :: icodemat
- double precision, dimension(:),pointer :: rho_s,cp,cs, &
- aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
- double precision, dimension(:),pointer :: rho_f,phi,tortuosity,permxx,permxz,&
- permzz,kappa_s,kappa_f,kappa_fr,eta_f,mu_fr
-
-contains
-
- subroutine read_parameter_file()
-
-! reads in DATA/Par_file
-
- implicit none
- include "constants.h"
-
- ! local parameters
- integer :: ios,ireceiverlines
-
- ! read file names and path for output
- call read_value_string(IIN,IGNORE_JUNK,title)
- call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
-
- write(*,*) 'Title of the simulation'
- write(*,*) title
- print *
-
- ! read type of simulation
- call read_value_integer(IIN,IGNORE_JUNK,SIMULATION_TYPE)
- call read_value_logical(IIN,IGNORE_JUNK,SAVE_FORWARD)
-
- ! read info about external mesh
- call read_value_logical(IIN,IGNORE_JUNK,read_external_mesh)
- call read_value_string(IIN,IGNORE_JUNK,mesh_file)
- call read_value_string(IIN,IGNORE_JUNK,nodes_coords_file)
- 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,tangential_detection_curve_file)
-
- ! read info about partitioning
- call read_value_integer(IIN,IGNORE_JUNK,nproc)
- call read_value_integer(IIN,IGNORE_JUNK,partitioning_method)
-
- ! read grid parameters
- call read_value_double_precision(IIN,IGNORE_JUNK,xmin)
- call read_value_double_precision(IIN,IGNORE_JUNK,xmax)
- call read_value_integer(IIN,IGNORE_JUNK,nx)
- call read_value_integer(IIN,IGNORE_JUNK,ngnod)
- call read_value_logical(IIN,IGNORE_JUNK,initialfield)
- call read_value_logical(IIN,IGNORE_JUNK,add_Bielak_conditions)
- call read_value_logical(IIN,IGNORE_JUNK,assign_external_model)
- call read_value_logical(IIN,IGNORE_JUNK,READ_EXTERNAL_SEP_FILE)
- call read_value_logical(IIN,IGNORE_JUNK,TURN_ATTENUATION_ON)
- ! read viscous attenuation parameters (poroelastic media)
- call read_value_logical(IIN,IGNORE_JUNK,TURN_VISCATTENUATION_ON)
- call read_value_double_precision(IIN,IGNORE_JUNK,Q0)
- call read_value_double_precision(IIN,IGNORE_JUNK,freq0)
- ! determine if body or surface (membrane) waves calculation
- call read_value_logical(IIN,IGNORE_JUNK,p_sv)
-
- ! read absorbing boundaries parameters
- call read_value_logical(IIN,IGNORE_JUNK,any_abs)
- call read_value_logical(IIN,IGNORE_JUNK,absbottom)
- call read_value_logical(IIN,IGNORE_JUNK,absright)
- call read_value_logical(IIN,IGNORE_JUNK,abstop)
- call read_value_logical(IIN,IGNORE_JUNK,absleft)
-
- ! read time step parameters
- call read_value_integer(IIN,IGNORE_JUNK,nt)
- call read_value_double_precision(IIN,IGNORE_JUNK,deltat)
-
- ! read source infos
- call read_value_integer(IIN,IGNORE_JUNK,NSOURCES)
- 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,f0_attenuation)
-
- ! read receiver line parameters
- call read_value_integer(IIN,IGNORE_JUNK,seismotype)
- 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'
-
- ! allocate receiver line arrays
- allocate(nrec(nreceiverlines))
- allocate(xdeb(nreceiverlines))
- allocate(zdeb(nreceiverlines))
- allocate(xfin(nreceiverlines))
- allocate(zfin(nreceiverlines))
- allocate(enreg_surf_same_vertical(nreceiverlines),stat=ios)
- if( ios /= 0 ) stop 'error allocating receiver lines'
-
- ! loop on all the receiver lines
- do ireceiverlines = 1,nreceiverlines
- call read_value_integer(IIN,IGNORE_JUNK,nrec(ireceiverlines))
- call read_value_double_precision(IIN,IGNORE_JUNK,xdeb(ireceiverlines))
- call read_value_double_precision(IIN,IGNORE_JUNK,zdeb(ireceiverlines))
- 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_same_vertical(ireceiverlines))
- if (read_external_mesh .and. enreg_surf_same_vertical(ireceiverlines)) then
- stop 'Cannot use enreg_surf_same_vertical with external meshes!'
- endif
- enddo
-
- ! read display parameters
- call read_value_integer(IIN,IGNORE_JUNK,NTSTEP_BETWEEN_OUTPUT_INFO)
- call read_value_logical(IIN,IGNORE_JUNK,output_postscript_snapshot)
- call read_value_logical(IIN,IGNORE_JUNK,output_color_image)
- call read_value_integer(IIN,IGNORE_JUNK,imagetype)
- call read_value_double_precision(IIN,IGNORE_JUNK,cutsnaps)
- call read_value_logical(IIN,IGNORE_JUNK,meshvect)
- call read_value_logical(IIN,IGNORE_JUNK,modelvect)
- call read_value_logical(IIN,IGNORE_JUNK,boundvect)
- call read_value_logical(IIN,IGNORE_JUNK,interpol)
- call read_value_integer(IIN,IGNORE_JUNK,pointsdisp)
- call read_value_integer(IIN,IGNORE_JUNK,subsamp)
- call read_value_double_precision(IIN,IGNORE_JUNK,sizemax_arrows)
- call read_value_logical(IIN,IGNORE_JUNK,gnuplot)
- call read_value_logical(IIN,IGNORE_JUNK,outputgrid)
- call read_value_logical(IIN,IGNORE_JUNK,OUTPUT_ENERGY)
-
-
- ! read the different material materials
- call read_value_integer(IIN,IGNORE_JUNK,nb_materials)
- 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(aniso5(nb_materials))
- allocate(aniso6(nb_materials))
- allocate(aniso7(nb_materials))
- allocate(aniso8(nb_materials))
- allocate(Qp(nb_materials))
- allocate(Qs(nb_materials))
- allocate(rho_s(nb_materials))
- allocate(rho_f(nb_materials))
- allocate(phi(nb_materials))
- allocate(tortuosity(nb_materials))
- allocate(permxx(nb_materials))
- allocate(permxz(nb_materials))
- allocate(permzz(nb_materials))
- allocate(kappa_s(nb_materials))
- allocate(kappa_f(nb_materials))
- allocate(kappa_fr(nb_materials))
- allocate(eta_f(nb_materials))
- allocate(mu_fr(nb_materials))
-
- call read_materials(nb_materials,icodemat,cp,cs, &
- aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
- Qp,Qs,rho_s,rho_f,phi,tortuosity, &
- permxx,permxz,permzz,kappa_s,kappa_f,kappa_fr, &
- eta_f,mu_fr)
-
-
- ! checks input parameters
- call check_parameters()
-
- end subroutine read_parameter_file
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine check_parameters()
-
- implicit none
-
- ! checks partitioning
- if ( nproc <= 0 ) then
- print *, 'Number of processes (nproc) must be greater than or equal to one.'
- stop
- endif
-
-#ifndef USE_MPI
- if ( nproc > 1 ) then
- print *, 'Number of processes (nproc) must be equal to one when not using MPI.'
- print *, 'Please recompile with -DUSE_MPI in order to enable use of MPI.'
- stop
- endif
-#endif
-
- if(partitioning_method /= 1 .and. partitioning_method /= 3) then
- print *, 'Invalid partitioning method number.'
- print *, 'Partitioning method ',partitioning_method,' was requested, but is not available.'
- print *, 'Support for the METIS graph partitioner has been discontinued, please use SCOTCH (option 3) instead.'
- stop
- endif
-
- ! checks absorbing boundaries
- if ( .not. any_abs ) then
- absbottom = .false.
- absright = .false.
- abstop = .false.
- absleft = .false.
- endif
-
- ! can use only one point to display lower-left corner only for interpolated snapshot
- if(pointsdisp < 3) then
- pointsdisp = 3
- plot_lowerleft_corner_only = .true.
- else
- plot_lowerleft_corner_only = .false.
- endif
-
- end subroutine check_parameters
-
-end module parameter_file
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/read_regions.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_regions.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/read_regions.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,145 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine read_regions(nbregion,nb_materials,icodemat,cp,cs, &
- rho_s,Qp,Qs,aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
- nelmnts,num_material,nxread,nzread)
-
-! reads in material definitions in DATA/Par_file
-
- implicit none
- include "constants.h"
-
- integer :: nbregion,nb_materials
- integer, dimension(nb_materials) :: icodemat
- double precision, dimension(nb_materials) :: rho_s,cp,cs, &
- aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
-
- integer :: nelmnts
- integer,dimension(nelmnts) :: num_material
- integer :: nxread,nzread
-
- ! local parameters
- integer :: iregion,ixdebregion,ixfinregion,izdebregion,izfinregion,imaterial_number
- integer :: i,j
- double precision :: vpregion,vsregion,poisson_ratio
-
- ! read the material numbers for each region
- call read_value_integer(IIN,IGNORE_JUNK,nbregion)
-
- if(nbregion <= 0) stop 'Negative number of regions not allowed!'
-
- print *
- print *, 'Nb of regions in the mesh = ',nbregion
- print *
-
- do iregion = 1,nbregion
-
- call read_region_coordinates(IIN,DONT_IGNORE_JUNK,ixdebregion,ixfinregion, &
- izdebregion,izfinregion,imaterial_number)
-
- if(imaterial_number < 1) stop 'Negative material number not allowed!'
- if(ixdebregion < 1) stop 'Left coordinate of region negative!'
- if(ixfinregion > nxread) stop 'Right coordinate of region too high!'
- if(izdebregion < 1) stop 'Bottom coordinate of region negative!'
- if(izfinregion > nzread) stop 'Top coordinate of region too high!'
-
- print *,'Region ',iregion
- print *,'IX from ',ixdebregion,' to ',ixfinregion
- print *,'IZ from ',izdebregion,' to ',izfinregion
-
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. icodemat(imaterial_number) /= POROELASTIC_MATERIAL) then
-
- ! isotropic material
- 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
-
- ! poroelastic material
- print *,'Material # ',imaterial_number,' isotropic'
- print *,'Material is poroelastic'
- else
-
- ! anisotropic material
- print *,'Material # ',imaterial_number,' anisotropic'
- print *,'cp = ',cp(imaterial_number)
- print *,'cs = ',cs(imaterial_number)
- print *,'c11 = ',aniso3(imaterial_number)
- print *,'c13 = ',aniso4(imaterial_number)
- print *,'c15 = ',aniso5(imaterial_number)
- print *,'c33 = ',aniso6(imaterial_number)
- print *,'c35 = ',aniso7(imaterial_number)
- print *,'c55 = ',aniso8(imaterial_number)
- print *,'rho = ',rho_s(imaterial_number)
- print *,'Qp = ',Qp(imaterial_number)
- print *,'Qs = ',Qs(imaterial_number)
- endif
- print *,' -----'
-
- ! store density and velocity model
- do i = ixdebregion,ixfinregion
- do j = izdebregion,izfinregion
- num_material((j-1)*nxread+i) = imaterial_number
- enddo
- enddo
-
- enddo
-
- if(minval(num_material) <= 0) stop 'Velocity model not entirely set...'
-
- end subroutine read_regions
Deleted: seismo/2D/SPECFEM2D/trunk/src/read_source_file.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_source_file.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/read_source_file.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,144 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-module source_file
-
- implicit none
-
- ! source parameters
- integer, dimension(:),pointer :: source_type,time_function_type
- double precision, dimension(:),pointer :: xs,zs,f0,tshift_src,angleforce, &
- Mxx,Mzz,Mxz,factor
- logical, dimension(:),pointer :: source_surf
-
-contains
-
- subroutine read_source_file(NSOURCES)
-
-! reads in source file DATA/SOURCE
-
- implicit none
- include "constants.h"
-
- integer :: NSOURCES
-
- ! local parameters
- integer :: ios,icounter,i_source,num_sources
- character(len=150) dummystring
- integer, parameter :: IIN_SOURCE = 22
-
- ! allocates memory arrays
- allocate(source_surf(NSOURCES))
- allocate(xs(NSOURCES))
- allocate(zs(NSOURCES))
- allocate(source_type(NSOURCES))
- allocate(time_function_type(NSOURCES))
- allocate(f0(NSOURCES))
- allocate(tshift_src(NSOURCES))
- allocate(angleforce(NSOURCES))
- allocate(Mxx(NSOURCES))
- allocate(Mxz(NSOURCES))
- allocate(Mzz(NSOURCES))
- allocate(factor(NSOURCES))
-
- ! counts lines
- open(unit=IIN_SOURCE,file='DATA/SOURCE',iostat=ios,status='old',action='read')
- if(ios /= 0) stop 'error opening DATA/SOURCE file'
-
- icounter = 0
- do while(ios == 0)
- read(IIN_SOURCE,"(a)",iostat=ios) dummystring
- if(ios == 0) icounter = icounter + 1
- enddo
- close(IIN_SOURCE)
-
- ! checks counter
- if(mod(icounter,NLINES_PER_SOURCE) /= 0) &
- stop 'total number of lines in SOURCE file should be a multiple of NLINES_PER_SOURCE'
-
- ! total number of sources
- num_sources = icounter / NLINES_PER_SOURCE
-
- if(num_sources < 1) stop 'need at least one source in SOURCE file'
- if(num_sources /= NSOURCES) &
- stop 'total number of sources read is different than declared in Par_file'
-
- ! reads in source parameters
- open(unit=IIN_SOURCE,file='DATA/SOURCE',status='old',action='read')
- do i_source=1,NSOURCES
- 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))
- call read_value_integer(IIN_SOURCE,IGNORE_JUNK,source_type(i_source))
- call read_value_integer(IIN_SOURCE,IGNORE_JUNK,time_function_type(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,f0(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,tshift_src(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,angleforce(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mxx(i_source))
- 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))
-
- ! note: we will further process source info in solver,
- ! here we just read in the given specifics and show them
-
- print *
- print *,'Source', i_source
- print *,'Position xs, zs = ',xs(i_source),zs(i_source)
- print *,'Frequency, delay = ',f0(i_source),tshift_src(i_source)
- print *,'Source type (1=force, 2=explosion): ',source_type(i_source)
- print *,'Time function type (1=Ricker, 2=First derivative, 3=Gaussian, 4=Dirac, 5=Heaviside): ',time_function_type(i_source)
- print *,'Angle of the source if force = ',angleforce(i_source)
- print *,'Mxx of the source if moment tensor = ',Mxx(i_source)
- print *,'Mzz of the source if moment tensor = ',Mzz(i_source)
- print *,'Mxz of the source if moment tensor = ',Mxz(i_source)
- print *,'Multiplying factor = ',factor(i_source)
- print *
- enddo ! do i_source=1,NSOURCES
- close(IIN_SOURCE)
-
- end subroutine read_source_file
-
-end module source_file
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/read_value_parameters.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_value_parameters.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/read_value_parameters.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,211 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! read values from parameter file, ignoring white lines and comments
-
- subroutine read_value_integer(iin,ignore_junk,value_to_read)
-
- implicit none
-
- integer iin
- logical ignore_junk
- integer value_to_read
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) value_to_read
-
- end subroutine read_value_integer
-
-!--------------------
-
- subroutine read_value_double_precision(iin,ignore_junk,value_to_read)
-
- implicit none
-
- integer iin
- logical ignore_junk
- double precision value_to_read
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) value_to_read
-
- end subroutine read_value_double_precision
-
-!--------------------
-
- subroutine read_value_logical(iin,ignore_junk,value_to_read)
-
- implicit none
-
- integer iin
- logical ignore_junk
- logical value_to_read
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) value_to_read
-
- end subroutine read_value_logical
-
-!--------------------
-
- subroutine read_value_string(iin,ignore_junk,value_to_read)
-
- implicit none
-
- integer iin
- logical ignore_junk
- character(len=*) value_to_read
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- value_to_read = string_read
-
- end subroutine read_value_string
-
-!--------------------
-
- subroutine read_two_interface_points(iin,ignore_junk,value_to_read_1,value_to_read_2)
-
- implicit none
-
- integer iin
- logical ignore_junk
- double precision value_to_read_1,value_to_read_2
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) value_to_read_1,value_to_read_2
-
- end subroutine read_two_interface_points
-
-!--------------------
-
- subroutine read_region_coordinates(iin,ignore_junk,value_to_read_1,value_to_read_2, &
- value_to_read_3,value_to_read_4,value_to_read_5)
-
- implicit none
-
- integer iin
- logical ignore_junk
- integer value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5
-
- end subroutine read_region_coordinates
-
-!--------------------
-
- 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 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)
- print*,string_read
- read(string_read,*) i,icodematread,val0read,val1read,val2read,val3read,val4read,val5read,&
- val6read,val7read,val8read,val9read,val10read,val11read,val12read
-
-
- end subroutine read_material_parameters
-
-!--------------------
-
- subroutine read_next_line(iin,ignore_junk,string_read)
-
- implicit none
-
- logical ignore_junk
- character(len=100) string_read
-
- integer ios,iin,index_equal_sign
-
- do
- read(unit=iin,fmt="(a100)",iostat=ios) string_read
- if(ios /= 0) stop 'error while reading input file'
-
-! suppress leading white spaces, if any
- string_read = adjustl(string_read)
-
-! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS)
- if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1)
-
-! exit loop when we find the first line that is not a comment or a white line
- if(len_trim(string_read) == 0) cycle
- if(string_read(1:1) /= '#') exit
-
- enddo
-
-! suppress trailing white spaces, if any
- string_read = string_read(1:len_trim(string_read))
-
-! suppress trailing comments, if any
- if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1)
-
-! suppress leading junk (up to the first equal sign, included) if needed
- if(ignore_junk) then
- index_equal_sign = index(string_read,'=')
- if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file'
- string_read = string_read(index_equal_sign + 1:len_trim(string_read))
- endif
-
-! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk
- string_read = adjustl(string_read)
- string_read = string_read(1:len_trim(string_read))
-
- end subroutine read_next_line
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/recompute_jacobian.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/recompute_jacobian.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/recompute_jacobian.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,168 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! recompute 2D jacobian at a given point in a 4-node or 9-node element
-
- subroutine recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian,coorg,knods,ispec,ngnod,nspec,npgeo, &
- stop_if_negative_jacobian)
-
- implicit none
-
- include "constants.h"
-
- integer ispec,ngnod,nspec,npgeo
- double precision x,z,xix,xiz,gammax,gammaz
- double precision xi,gamma,jacobian
-
- integer knods(ngnod,nspec)
- double precision coorg(NDIM,npgeo)
-
-! 2D shape functions and their derivatives at receiver
- double precision shape2D(ngnod)
- double precision dershape2D(NDIM,ngnod)
-
- double precision xxi,zxi,xgamma,zgamma,xelm,zelm
-
- integer ia,nnum
-
- logical stop_if_negative_jacobian
-
-! only one problematic element is output to OpenDX for now in case of elements with a negative Jacobian
- integer, parameter :: ntotspecAVS_DX = 1
-
-! recompute jacobian for any (xi,gamma) point, not necessarily a GLL point
-
-! create the 2D shape functions and the Jacobian
- call define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)
-
-! compute coordinates and jacobian matrix
- x = ZERO
- z = ZERO
-
- xxi = ZERO
- zxi = ZERO
- xgamma = ZERO
- zgamma = ZERO
-
- do ia=1,ngnod
-
- nnum = knods(ia,ispec)
-
- xelm = coorg(1,nnum)
- zelm = coorg(2,nnum)
-
- x = x + shape2D(ia)*xelm
- z = z + shape2D(ia)*zelm
-
- xxi = xxi + dershape2D(1,ia)*xelm
- zxi = zxi + dershape2D(1,ia)*zelm
- xgamma = xgamma + dershape2D(2,ia)*xelm
- zgamma = zgamma + dershape2D(2,ia)*zelm
-
- enddo
-
- jacobian = xxi*zgamma - xgamma*zxi
-
-! the Jacobian is negative, so far this means that there is an error in the mesh
-! therefore print the coordinates of the mesh points of this element
-! and also create an OpenDX file to visualize it
- if(jacobian <= ZERO .and. stop_if_negative_jacobian) then
-
-! print the coordinates of the mesh points of this element
- print *, 'ispec = ', ispec
- print *, 'ngnod = ', ngnod
- do ia=1,ngnod
- nnum = knods(ia,ispec)
- xelm = coorg(1,nnum)
- zelm = coorg(2,nnum)
- print *,'node ', ia,' x,y = ',xelm,zelm
- enddo
-
-! create an OpenDX file to visualize this element
- open(unit=11,file='DX_first_element_with_negative_jacobian.dx',status='unknown')
-
-! output the points (the mesh is flat therefore the third coordinate is zero)
- write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ngnod,' data follows'
- do ia=1,ngnod
- nnum = knods(ia,ispec)
- xelm = coorg(1,nnum)
- zelm = coorg(2,nnum)
- write(11,*) xelm,zelm,' 0'
- enddo
-
-! output the element (use its four corners only for now)
- write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows'
-! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
- write(11,*) '0 3 1 2'
-
-! output element data
- write(11,*) 'attribute "element type" string "quads"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
-
-! output dummy data value
- write(11,*) '1'
-
-! define OpenDX field
- write(11,*) 'attribute "dep" string "connections"'
- write(11,*) 'object "irregular positions irregular connections" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
-
-! close OpenDX file
- close(11)
-
- call exit_MPI('negative 2D Jacobian, element saved in DX_first_element_with_negative_jacobian.dx')
- endif
-
-! invert the relation
- xix = zgamma / jacobian
- gammax = - zxi / jacobian
- xiz = - xgamma / jacobian
- gammaz = xxi / jacobian
-
- end subroutine recompute_jacobian
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/save_databases.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/save_databases.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/save_databases.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,263 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine save_databases(nspec,num_material, &
- my_interfaces,my_nb_interfaces, &
- nnodes_tangential_curve,nodes_tangential_curve )
-
-
-! generates the databases for the solver
-
- use part_unstruct
- use parameter_file
- use source_file
- implicit none
- include "constants.h"
-
- integer :: nspec
- integer, dimension(nelmnts) :: num_material
-
- integer, dimension(0:ninterfaces-1) :: my_interfaces
- integer, dimension(0:ninterfaces-1) :: my_nb_interfaces
-
- integer :: nnodes_tangential_curve
- double precision, dimension(2,nnodes_tangential_curve) :: nodes_tangential_curve
-
- ! local parameters
- integer :: iproc,i_source,i,ios
- integer :: npgeo
- integer :: my_ninterface
- integer :: nedges_coupled_loc
- integer :: nedges_acporo_coupled_loc
- integer :: nedges_elporo_coupled_loc
-
- character(len=256) :: prname
-
-
- do iproc = 0, nproc-1
-
- ! opens Database file
- write(prname, "('./OUTPUT_FILES/Database',i5.5)") iproc
- open(unit=15,file=trim(prname),status='unknown',iostat=ios)
- if( ios /= 0 ) stop 'error saving databases'
-
- write(15,*) '#'
- write(15,*) '# Database for SPECFEM2D'
- write(15,*) '# Dimitri Komatitsch, (c) University of Pau, France'
- write(15,*) '#'
-
- write(15,*) 'Title of the simulation'
- write(15,"(a100)") title
-
- write(15,*) 'Type of simulation'
- write(15,*) SIMULATION_TYPE, SAVE_FORWARD
-
- call write_glob2loc_nodes_database(15, iproc, npgeo, 1)
-
-
- call write_partition_database(15, iproc, nspec, num_material, ngnod, 1)
-
-
- write(15,*) 'npgeo'
- write(15,*) npgeo
-
- write(15,*) 'gnuplot interpol'
- write(15,*) gnuplot,interpol
-
- write(15,*) 'NTSTEP_BETWEEN_OUTPUT_INFO'
- write(15,*) NTSTEP_BETWEEN_OUTPUT_INFO
-
- write(15,*) 'output_postscript_snapshot output_color_image colors numbers'
- write(15,*) output_postscript_snapshot,output_color_image,' 1 0'
-
- write(15,*) 'meshvect modelvect boundvect cutsnaps subsamp sizemax_arrows'
- write(15,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
-
- write(15,*) 'anglerec'
- write(15,*) anglerec
-
- write(15,*) 'initialfield add_Bielak_conditions'
- write(15,*) initialfield,add_Bielak_conditions
-
- write(15,*) 'seismotype imagetype'
- write(15,*) seismotype,imagetype
-
- write(15,*) 'assign_external_model READ_EXTERNAL_SEP_FILE'
- write(15,*) assign_external_model,READ_EXTERNAL_SEP_FILE
-
- write(15,*) 'outputgrid OUTPUT_ENERGY TURN_ATTENUATION_ON'
- write(15,*) outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON
-
- write(15,*) 'TURN_VISCATTENUATION_ON Q0 freq0'
- write(15,*) TURN_VISCATTENUATION_ON,Q0,freq0
-
- write(15,*) 'p_sv'
- write(15,*) p_sv
-
- write(15,*) 'nt deltat'
- write(15,*) nt,deltat
- write(15,*) 'NSOURCES'
- write(15,*) NSOURCES
-
- do i_source=1,NSOURCES
- write(15,*) 'source', i_source
- write(15,*) source_type(i_source),time_function_type(i_source), &
- xs(i_source),zs(i_source),f0(i_source),tshift_src(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, f0_attenuation
-
- write(15,*) 'Coordinates of macrobloc mesh (coorg):'
-
- call write_glob2loc_nodes_database(15, iproc, npgeo, 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
- call write_abs_merge_database(15, iproc, 1)
- else
- nelemabs_loc = 0
- endif
-
- call write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
- iproc, 1)
-
- call write_fluidsolid_edges_database(15,nedges_coupled, nedges_coupled_loc, &
- edges_coupled, iproc, 1)
- call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
- edges_acporo_coupled, iproc, 1)
- call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
- edges_elporo_coupled, iproc, 1)
-
- if (.not. ( force_normal_to_surface .or. rec_normal_to_surface ) ) then
- nnodes_tangential_curve = 0
- endif
-
- 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 (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
- if (icodemat(i) == ISOTROPIC_MATERIAL) then
- write(15,*) i,icodemat(i),rho_s(i),cp(i),cs(i),0,0,Qp(i),Qs(i),0,0,0,0,0,0
- elseif(icodemat(i) == POROELASTIC_MATERIAL) then
- 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)
- else
- write(15,*) i,icodemat(i),rho_s(i),cp(i),cs(i), &
- aniso3(i),aniso4(i),aniso5(i),aniso6(i),&
- aniso7(i),aniso8(i),Qp(i),Qs(i),0,0
- endif
- enddo
-
- write(15,*) 'Arrays kmato and knods for each bloc:'
-
- call write_partition_database(15, iproc, nspec, num_material, ngnod, 2)
-
- if ( nproc /= 1 ) then
- call write_interfaces_database(15, nproc, iproc, &
- my_ninterface, my_interfaces, my_nb_interfaces, 1)
-
- write(15,*) 'Interfaces:'
- write(15,*) my_ninterface, maxval(my_nb_interfaces)
-
- call write_interfaces_database(15, nproc, iproc, &
- my_ninterface, my_interfaces, my_nb_interfaces, 2)
-
- else
- write(15,*) 'Interfaces:'
- write(15,*) 0, 0
- endif
-
-
- write(15,*) 'List of absorbing elements (bottom right top left):'
- if ( any_abs ) then
- call write_abs_merge_database(15, iproc, 2)
- endif
-
- write(15,*) 'List of acoustic free-surface elements:'
- call write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
- iproc, 2)
-
-
- write(15,*) 'List of acoustic elastic coupled edges:'
- call write_fluidsolid_edges_database(15, nedges_coupled, nedges_coupled_loc, &
- edges_coupled, iproc, 2)
-
- write(15,*) 'List of acoustic poroelastic coupled edges:'
- call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
- edges_acporo_coupled, iproc, 2)
-
- write(15,*) 'List of poroelastic elastic coupled edges:'
- call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
- edges_elporo_coupled, iproc, 2)
-
- write(15,*) 'List of tangential detection curve nodes:'
- !write(15,*) nnodes_tangential_curve
- write(15,*) force_normal_to_surface,rec_normal_to_surface
-
- if (force_normal_to_surface .or. rec_normal_to_surface) then
- do i = 1, nnodes_tangential_curve
- write(15,*) nodes_tangential_curve(1,i),nodes_tangential_curve(2,i)
- enddo
- endif
-
- ! closes Database file
- close(15)
-
- enddo
-
- end subroutine save_databases
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/save_gnuplot_file.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/save_gnuplot_file.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/save_gnuplot_file.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,118 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine save_gnuplot_file(ngnod,nx,nz,x,z)
-
-! creates a Gnuplot file that displays the grid
-
- implicit none
-
- integer :: ngnod,nx,nz
- double precision, dimension(0:nx,0:nz) :: x,z
-
- ! local parameters
- integer :: ios,istepx,istepz,ili,icol
-
- print *
- print *,'Saving the grid in Gnuplot format...'
-
- open(unit=20,file='OUTPUT_FILES/gridfile.gnu',status='unknown',iostat=ios)
- if( ios /= 0 ) stop 'error saving gnuplot file'
-
- ! draw horizontal lines of the grid
- print *,'drawing horizontal lines of the grid'
- istepx = 1
- if(ngnod == 4) then
- istepz = 1
- else
- istepz = 2
- endif
- do ili=0,nz,istepz
- do icol=0,nx-istepx,istepx
- write(20,*) sngl(x(icol,ili)),sngl(z(icol,ili))
- write(20,*) sngl(x(icol+istepx,ili)),sngl(z(icol+istepx,ili))
- write(20,10)
- enddo
- enddo
-
- ! draw vertical lines of the grid
- print *,'drawing vertical lines of the grid'
- if(ngnod == 4) then
- istepx = 1
- else
- istepx = 2
- endif
- istepz = 1
- do icol=0,nx,istepx
- do ili=0,nz-istepz,istepz
- write(20,*) sngl(x(icol,ili)),sngl(z(icol,ili))
- write(20,*) sngl(x(icol,ili+istepz)),sngl(z(icol,ili+istepz))
- write(20,10)
- enddo
- enddo
-
-10 format('')
-
- close(20)
-
- ! create a Gnuplot script to display the grid
- open(unit=20,file='OUTPUT_FILES/plotgnu',status='unknown',iostat=ios)
- if( ios /= 0 ) stop 'error saving plotgnu file'
-
- write(20,*) '#set term X11'
- write(20,*) 'set term postscript landscape monochrome solid "Helvetica" 22'
- write(20,*) 'set output "grid.ps"'
- write(20,*) '#set xrange [',sngl(minval(x)),':',sngl(maxval(x)),']'
- write(20,*) '#set yrange [',sngl(minval(z)),':',sngl(maxval(z)),']'
- ! use same unit length on both X and Y axes
- write(20,*) 'set size ratio -1'
- write(20,*) 'plot "gridfile.gnu" title "Macrobloc mesh" w l'
- write(20,*) 'pause -1 "Hit any key..."'
- close(20)
-
- print *,'Grid saved in Gnuplot format...'
- print *
-
- end subroutine save_gnuplot_file
Deleted: seismo/2D/SPECFEM2D/trunk/src/save_openDX_jacobian.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/save_openDX_jacobian.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/save_openDX_jacobian.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,155 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine save_openDX_jacobian(nspec,npgeo,ngnod,knods,coorg,xigll,zigll)
-
- implicit none
- include "constants.h"
-
- integer :: nspec,npgeo,ngnod
- double precision, dimension(NDIM,npgeo) :: coorg
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLZ) :: zigll
-
- integer, dimension(ngnod,nspec) :: knods
-
- ! local parameters
- integer, dimension(:), allocatable :: ibool_OpenDX
- logical, dimension(:), allocatable :: mask_point
- double precision :: xelm,zelm
- double precision :: xi,gamma,x,z
- double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
-
- integer :: ia,nnum,ipoint_number,total_of_negative_elements
- integer :: ispec,i,j
- logical :: found_a_problem_in_this_element
-
- ! create an OpenDX file to visualize this element
- open(unit=11,file='DX_all_elements_with_negative_jacobian_in_red.dx',status='unknown')
-
- ! output all the points (i.e. all the control points of the mesh)
- ! the mesh is flat therefore the third coordinate is zero
- write(11,*) 'object 1 class array type float rank 1 shape 3 items ',npgeo,' data follows'
- ipoint_number = 0
- allocate(mask_point(npgeo))
- allocate(ibool_OpenDX(npgeo))
- mask_point(:) = .false.
- do ispec = 1,nspec
- do ia=1,ngnod
- nnum = knods(ia,ispec)
- xelm = coorg(1,nnum)
- zelm = coorg(2,nnum)
- if(.not. mask_point(knods(ia,ispec))) then
- mask_point(knods(ia,ispec)) = .true.
- ibool_OpenDX(knods(ia,ispec)) = ipoint_number
- write(11,*) xelm,zelm,' 0'
- ipoint_number = ipoint_number + 1
- endif
- enddo
- enddo
- deallocate(mask_point)
-
- ! output all the elements of the mesh (use their four corners only in OpenDX
- write(11,*) 'object 2 class array type int rank 1 shape 4 items ',nspec,' data follows'
- ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
- do ispec = 1,nspec
- write(11,*) ibool_OpenDX(knods(1,ispec)),ibool_OpenDX(knods(4,ispec)), &
- ibool_OpenDX(knods(2,ispec)),ibool_OpenDX(knods(3,ispec))
- enddo
- deallocate(ibool_OpenDX)
-
- ! output element data
- write(11,*) 'attribute "element type" string "quads"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items ',nspec,' data follows'
-
- ! output all the element data (value = 1 if positive Jacobian, = 2 if negative Jacobian)
- total_of_negative_elements = 0
- do ispec = 1,nspec
-
- ! check if this element has a negative Jacobian at any of its points
- found_a_problem_in_this_element = .false.
- do j = 1,NGLLZ
- do i = 1,NGLLX
- xi = xigll(i)
- gamma = zigll(j)
-
- call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
- jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
- .false.)
-
- if(jacobianl <= ZERO) found_a_problem_in_this_element = .true.
- enddo
- enddo
-
- ! output data value
- if(found_a_problem_in_this_element) then
- write(11,*) '2'
- print *,'element ',ispec,' has a negative Jacobian'
- total_of_negative_elements = total_of_negative_elements + 1
- else
- write(11,*) '1'
- endif
-
- enddo
-
- ! define OpenDX field
- write(11,*) 'attribute "dep" string "connections"'
- write(11,*) 'object "irregular positions irregular connections" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
-
- ! close OpenDX file
- close(11)
-
- print *
- print *,total_of_negative_elements,' elements have a negative Jacobian, out of ',nspec
- print *,'i.e., ',sngl(100.d0 * dble(total_of_negative_elements)/dble(nspec)),'%'
- print *
-
- end subroutine save_openDX_jacobian
\ No newline at end of file
Deleted: seismo/2D/SPECFEM2D/trunk/src/save_stations_file.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/save_stations_file.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/save_stations_file.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,122 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine save_stations_file(nreceiverlines,nrec,xdeb,zdeb,xfin,zfin,enreg_surf_same_vertical, &
- xinterface_top,zinterface_top,coefs_interface_top, &
- npoints_interface_top,max_npoints_interface)
-
- implicit none
-
- integer :: nreceiverlines
- integer, dimension(nreceiverlines) :: nrec
- double precision, dimension(nreceiverlines) :: xdeb,zdeb,xfin,zfin
- logical, dimension(nreceiverlines) :: enreg_surf_same_vertical
-
- integer :: max_npoints_interface
- double precision, dimension(max_npoints_interface) :: xinterface_top, &
- zinterface_top,coefs_interface_top
- integer :: npoints_interface_top
-
- !local parameters
- integer :: ireceiverlines,irec,irec_global_number,ios
- integer :: nrec_total
- double precision :: xrec,zrec
- double precision, external :: value_spline
-
- print *
- print *,'writing the DATA/STATIONS_target file'
- print *
-
- ! total number of receivers in all the receiver lines
- nrec_total = sum(nrec)
-
- print *
- print *,'There are ',nrec_total,' receivers'
-
- print *
- print *,'Position (x,z) of the ',nrec_total,' receivers'
- print *
-
- open(unit=15,file='DATA/STATIONS_target',status='unknown',iostat=ios)
- if( ios /= 0 ) stop 'error saving STATIONS file'
-
- irec_global_number = 0
-
- ! loop on all the receiver lines
- do ireceiverlines = 1,nreceiverlines
-
- ! loop on all the receivers of this receiver line
- do irec = 1,nrec(ireceiverlines)
-
- ! compute global receiver number
- irec_global_number = irec_global_number + 1
-
- ! compute coordinates of the receiver
- if(nrec(ireceiverlines) > 1) then
- xrec = xdeb(ireceiverlines) + dble(irec-1)*(xfin(ireceiverlines) &
- -xdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
- zrec = zdeb(ireceiverlines) + dble(irec-1)*(zfin(ireceiverlines) &
- -zdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
- else
- xrec = xdeb(ireceiverlines)
- zrec = zdeb(ireceiverlines)
- endif
-
- ! modify position of receiver if we must record exactly at the surface
- if(enreg_surf_same_vertical(ireceiverlines)) &
- zrec = value_spline(xrec,xinterface_top,zinterface_top, &
- coefs_interface_top,npoints_interface_top)
-
- ! display position of the receiver
- print *,'Receiver ',irec_global_number,' = ',xrec,zrec
-
- write(15,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") irec_global_number,xrec,zrec
-
- enddo
- enddo
-
- close(15)
-
- end subroutine save_stations_file
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/set_sources.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/set_sources.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/set_sources.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,252 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine set_sources(myrank,NSOURCES,source_type,time_function_type, &
- x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce,aval, &
- t0,initialfield,ipass,deltat)
-
-! gets source parameters
-
- implicit none
- include "constants.h"
-
- integer :: myrank
- integer :: NSOURCES
- integer, dimension(NSOURCES) :: source_type,time_function_type
- double precision, dimension(NSOURCES) :: x_source,z_source, &
- Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
- double precision, dimension(NSOURCES) :: aval
- double precision :: t0
- double precision :: deltat
- integer :: ipass
- logical :: initialfield
-
- ! local parameters
- integer :: i_source
- double precision, dimension(NSOURCES) :: t0_source,hdur
- double precision :: min_tshift_src_original
-
- ! checks the input
- do i_source=1,NSOURCES
-
- ! checks source type
- if(.not. initialfield) then
- if (source_type(i_source) == 1) then
- if ( myrank == 0 .and. ipass == 1 ) then
- ! user output
- write(IOUT,212) x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
- factor(i_source),angleforce(i_source)
- endif
- else if(source_type(i_source) == 2) then
- if ( myrank == 0 .and. ipass == 1 ) then
- ! user output
- write(IOUT,222) x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
- factor(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
- endif
- else
- 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
- if(time_function_type(i_source) == 4 .or. time_function_type(i_source) == 5) &
- f0(i_source) = 1.d0 / (10.d0 * deltat)
-
- ! checks source frequency
- if( abs(f0(i_source)) < TINYVAL ) then
- call exit_MPI('Error source frequency is zero')
- endif
-
- ! half-duration of source
- hdur(i_source) = 1.d0 / f0(i_source)
-
- ! sets source start times, shifted by the given (non-zero) time-shift
- if(time_function_type(i_source)== 5) then
- t0_source(i_source) = 2.0d0 * hdur(i_source) + tshift_src(i_source)
- else
- t0_source(i_source) = 1.20d0 * hdur(i_source) + tshift_src(i_source)
- 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 ! do i_source=1,NSOURCES
-
- ! initializes simulation start time
- if( NSOURCES == 1 ) then
- ! simulation start time
- t0 = t0_source(1)
- ! sets source time shift relative to simulation start time
- min_tshift_src_original = tshift_src(1)
- tshift_src(1) = 0.d0
- else
- ! starts with earliest start time
- t0 = minval( t0_source(:) )
- ! sets source time shifts relative to simulation start time
- min_tshift_src_original = minval( tshift_src(:) )
- tshift_src(:) = t0_source(:) - t0
- endif
-
- ! checks if user set USER_T0 to fix simulation start time
- ! note: USER_T0 has to be positive
- if( USER_T0 > 0.d0 ) then
- ! user cares about origin time and time shifts of the CMTSOLUTION
- ! and wants to fix simulation start time to a constant start time
- ! time 0 on time axis will correspond to given origin time
-
- ! notifies user
- if( myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) ' using USER_T0 . . . . . . . . . = ',USER_T0
- write(IOUT,*) ' original t0 . . . . . . . . . = ',t0
- write(IOUT,*) ' min_tshift_src_original . . . = ',min_tshift_src_original
- write(IOUT,*)
- endif
-
- ! checks if automatically set t0 is too small
- ! note: times in seismograms are shifted by t0(1)
- if( t0 <= USER_T0 + min_tshift_src_original ) then
-
- ! sets new simulation start time such that
- ! simulation starts at t = - t0 = - USER_T0
- t0 = USER_T0
-
- ! notifies user
- if( myrank == 0 .and. ipass == 1) then
- write(IOUT,*) ' fix new simulation start time . = ', - t0
- endif
-
- ! loops over all sources
- do i_source=1,NSOURCES
- ! sets the given, initial time shifts
- if( time_function_type(i_source) == 5 ) then
- tshift_src(i_source) = t0_source(i_source) - 2.0d0 * hdur(i_source)
- else
- tshift_src(i_source) = t0_source(i_source) - 1.20d0 * hdur(i_source)
- endif
- ! user output
- if( myrank == 0 .and. ipass == 1) then
- write(IOUT,*) ' source ',i_source,'uses tshift = ',tshift_src(i_source)
- endif
- enddo
- ! user output
- if( myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- endif
-
- else
- ! start time needs to be at least t0 for numerical stability
- ! notifies user
- if( myrank == 0 .and. ipass == 1) then
- write(IOUT,*) 'error: USER_T0 is too small'
- write(IOUT,*) ' must make one of three adjustements:'
- write(IOUT,*) ' - increase USER_T0 to be at least: ',t0
- write(IOUT,*) ' - decrease time shift tshift_src in SOURCE file'
- write(IOUT,*) ' - increase frequency f0 in SOURCE file'
- endif
- call exit_MPI('error USER_T0 is set but too small')
- endif
- else if( USER_T0 < 0.d0 ) then
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) 'error: USER_T0 is negative, must be set zero or positive!'
- endif
- call exit_MPI('error negative USER_T0 parameter in constants.h')
- endif
-
- ! checks onset times
- if(.not. initialfield) then
-
- ! loops over sources
- do i_source = 1,NSOURCES
-
- ! excludes Dirac and Heaviside sources
- if(time_function_type(i_source) /= 4 .and. time_function_type(i_source) /= 5) then
-
- ! user output
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) ' Onset time. . . . . . = ',t0+tshift_src(i_source)
- write(IOUT,*) ' Fundamental period. . = ',1.d0/f0(i_source)
- write(IOUT,*) ' Fundamental frequency = ',f0(i_source)
- endif
-
- ! checks source onset time
- if( t0+tshift_src(i_source) <= 1.d0/f0(i_source)) then
- call exit_MPI('Onset time too small')
- else
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) ' --> onset time ok'
- endif
- endif
- endif
- enddo
-
- endif
-
-
- ! output formats
-212 format(//,5x,'Source Type. . . . . . . . . . . . . . = Collocated Force',/5x, &
- 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
- 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
- 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
- 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
- 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x, &
- 'Angle from vertical direction (deg). . =',1pe20.10,/5x)
-
-222 format(//,5x,'Source Type. . . . . . . . . . . . . . = Moment-tensor',/5x, &
- 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
- 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
- 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
- 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
- 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x, &
- 'Mxx. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
- 'Mzz. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
- 'Mxz. . . . . . . . . . . . . . . . . . =',1pe20.10)
-
- end subroutine set_sources
Deleted: seismo/2D/SPECFEM2D/trunk/src/setup_sources_receivers.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/setup_sources_receivers.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/setup_sources_receivers.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,170 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine setup_sources_receivers(NSOURCES,initialfield,source_type,&
- coord,ibool,npoin,nspec,nelem_acoustic_surface,acoustic_surface,elastic,poroelastic, &
- x_source,z_source,ispec_selected_source,ispec_selected_rec, &
- is_proc_source,nb_proc_source,ipass,&
- sourcearray,Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,npgeo,&
- nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod, &
- nrec,nrecloc,recloc,which_proc_receiver,st_xval,st_zval, &
- xi_receiver,gamma_receiver,station_name,network_name,x_final_receiver,z_final_receiver,iglob_source)
-
- implicit none
-
- include "constants.h"
-
- logical :: initialfield
- integer :: NSOURCES
- integer :: npgeo,ngnod,myrank,ipass,nproc
- integer :: npoin,nspec,nelem_acoustic_surface
-
- ! Gauss-Lobatto-Legendre points
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLZ) :: zigll
-
- ! for receivers
- integer :: nrec,nrecloc
- integer, dimension(nrec) :: recloc, which_proc_receiver
- integer, dimension(nrec) :: ispec_selected_rec
- double precision, dimension(nrec) :: xi_receiver,gamma_receiver,st_xval,st_zval
- double precision, dimension(nrec) :: x_final_receiver, z_final_receiver
-
- ! timing information for the stations
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- ! for sources
- integer, dimension(NSOURCES) :: source_type
- integer, dimension(NSOURCES) :: ispec_selected_source,is_proc_source,nb_proc_source,iglob_source
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
- double precision, dimension(NSOURCES) :: x_source,z_source,xi_source,gamma_source,Mxx,Mzz,Mxz
-
- logical, dimension(nspec) :: elastic,poroelastic
- integer, dimension(ngnod,nspec) :: knods
- integer, dimension(5,nelem_acoustic_surface) :: acoustic_surface
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
- double precision, dimension(NDIM,npgeo) :: coorg
- double precision, dimension(NDIM,npoin) :: coord
-
- integer :: ixmin, ixmax, izmin, izmax
-
- ! Local variables
- integer i_source,ispec,ispec_acoustic_surface
-
- do i_source=1,NSOURCES
-
- if(source_type(i_source) == 1) then
-
- ! collocated force source
- call locate_source_force(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,ipass,&
- iglob_source(i_source))
-
- ! check that acoustic source is not exactly on the free surface because pressure is zero there
- if(is_proc_source(i_source) == 1) then
- do ispec_acoustic_surface = 1,nelem_acoustic_surface
- ispec = acoustic_surface(1,ispec_acoustic_surface)
- ixmin = acoustic_surface(2,ispec_acoustic_surface)
- ixmax = acoustic_surface(3,ispec_acoustic_surface)
- izmin = acoustic_surface(4,ispec_acoustic_surface)
- izmax = acoustic_surface(5,ispec_acoustic_surface)
- if( .not. elastic(ispec) .and. .not. poroelastic(ispec) .and. &
- ispec == ispec_selected_source(i_source) ) then
- if ( (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==NGLLX .and. &
- gamma_source(i_source) < -0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==NGLLX .and. &
- gamma_source(i_source) > 0.99d0) .or.&
- (izmin==1 .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
- xi_source(i_source) < -0.99d0) .or.&
- (izmin==1 .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- xi_source(i_source) > 0.99d0) .or.&
- (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==1 .and. &
- gamma_source(i_source) < -0.99d0 .and. xi_source(i_source) < -0.99d0) .or.&
- (izmin==1 .and. izmax==1 .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- gamma_source(i_source) < -0.99d0 .and. xi_source(i_source) > 0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
- gamma_source(i_source) > 0.99d0 .and. xi_source(i_source) < -0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- gamma_source(i_source) > 0.99d0 .and. xi_source(i_source) > 0.99d0) ) then
- call exit_MPI('an acoustic source cannot be located exactly '// &
- 'on the free surface because pressure is zero there')
- endif
- endif
- enddo
- endif
-
- 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,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)
-
- else if(.not.initialfield) then
-
- call exit_MPI('incorrect source type')
-
- endif
-
- enddo ! do i_source=1,NSOURCES
-
- ! 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(1),z_source(1), &
- coorg,knods,ngnod,npgeo,ipass, &
- x_final_receiver,z_final_receiver)
-
- end subroutine setup_sources_receivers
-
Copied: seismo/2D/SPECFEM2D/trunk/src/shared/adj_seismogram.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/adj_seismogram.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/shared/adj_seismogram.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/shared/adj_seismogram.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,176 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ program adj_seismogram
+
+! This program cuts a certain portion of the seismograms and convert it
+! into the adjoint source for generating banana-dougnut kernels
+
+ implicit none
+!
+!!!! user edit
+ integer, parameter :: NSTEP = 3000
+ integer, parameter :: nrec = 1
+ double precision, parameter :: t0 = 12
+ double precision, parameter :: deltat = 6d-2
+ double precision, parameter :: EPS = 1.d-40
+!!!!
+ integer :: itime,icomp,istart,iend,nlen,irec,NDIM,NDIMr,adj_comp
+ double precision :: time,tstart(nrec),tend(nrec)
+ character(len=150), dimension(nrec) :: station_name
+ double precision, dimension(NSTEP) :: time_window
+ double precision :: seism(NSTEP,3),Nnorm,seism_win(NSTEP)
+ double precision :: seism_veloc(NSTEP),seism_accel(NSTEP),ft_bar(NSTEP)
+ character(len=3) :: compr(2),comp(3)
+ character(len=150) :: filename,filename2
+
+ NDIM=3
+ comp = (/"BHX","BHY","BHZ"/)
+
+!!!! user edit
+! which calculation: P-SV (use (1)) or SH (membrane) (use (2)) waves
+ NDIMr=2 !(1)
+! NDIMr=1 !(2)
+! list of stations
+ station_name(1) = 'S0001'
+ tstart(1) = 100d0 + t0
+ tend(1) = 120d0 + t0
+! which calculation: P-SV (use (1)) or SH (membrane) (use (2)) waves
+ compr = (/"BHX","BHZ"/) !(1)
+! compr = (/"BHY","dummy"/) !(2)
+! chose the component for the adjoint source (adj_comp = 1: X, 2:Y, 3:Z)
+ adj_comp = 1
+!!!!
+
+ do irec =1,nrec
+
+ do icomp = 1, NDIMr
+
+ filename = 'OUTPUT_FILES/'//trim(station_name(irec))//'.AA.'// compr(icomp) // '.semd'
+ open(unit = 10, file = trim(filename))
+
+ do itime = 1,NSTEP
+ read(10,*) time , seism(itime,icomp)
+ enddo
+
+ enddo
+
+ if(NDIMr==2)then
+ seism(:,3) = seism(:,2)
+ seism(:,2) = 0.d0
+ else
+ seism(:,2) = seism(:,1)
+ seism(:,1) = 0.d0
+ seism(:,3) = 0.d0
+ endif
+
+ close(10)
+
+
+ istart = max(floor(tstart(irec)/deltat),1)
+ iend = min(floor(tend(irec)/deltat),NSTEP)
+ print*,'istart =',istart, 'iend =', iend
+ print*,'tstart =',istart*deltat, 'tend =', iend*deltat
+ if(istart >= iend) stop 'check istart,iend'
+ nlen = iend - istart +1
+
+ do icomp = 1, NDIM
+
+ print*,comp(icomp)
+
+ filename = 'OUTPUT_FILES/'//trim(station_name(irec))//'.AA.'// comp(icomp) // '.adj'
+ open(unit = 11, file = trim(filename))
+
+ time_window(:) = 0.d0
+ seism_win(:) = seism(:,icomp)
+ seism_veloc(:) = 0.d0
+ seism_accel(:) = 0.d0
+
+ do itime =istart,iend
+! time_window(itime) = 1.d0 - cos(pi*(itime-1)/NSTEP+1)**10 ! cosine window
+ time_window(itime) = 1.d0 - (2* (dble(itime) - istart)/(iend-istart) -1.d0)**2 ! Welch window
+ enddo
+
+ do itime = 2,NSTEP-1
+ seism_veloc(itime) = (seism_win(itime+1) - seism_win(itime-1))/(2*deltat)
+ enddo
+ seism_veloc(1) = (seism_win(2) - seism_win(1))/deltat
+ seism_veloc(NSTEP) = (seism_win(NSTEP) - seism_win(NSTEP-1))/deltat
+
+ do itime = 2,NSTEP-1
+ seism_accel(itime) = (seism_veloc(itime+1) - seism_veloc(itime-1))/(2*deltat)
+ enddo
+ seism_accel(1) = (seism_veloc(2) - seism_veloc(1))/deltat
+ seism_accel(NSTEP) = (seism_veloc(NSTEP) - seism_veloc(NSTEP-1))/deltat
+
+ Nnorm = deltat * sum(time_window(:) * seism_win(:) * seism_accel(:))
+! Nnorm = deltat * sum(time_window(:) * seism_veloc(:) * seism_veloc(:))
+! cross-correlation traveltime adjoint source
+ if(abs(Nnorm) > EPS) then
+! ft_bar(:) = - seism_veloc(:) * time_window(:) / Nnorm
+ ft_bar(:) = seism_veloc(:) * time_window(:) / Nnorm
+ print*,'Norm =', Nnorm
+ else
+ print *, 'norm < EPS for file '
+ print*,'Norm =', Nnorm
+ ft_bar(:) = 0.d0
+ endif
+
+ do itime =1,NSTEP
+ if(icomp == adj_comp) then
+ write(11,*) (itime-1)*deltat - t0, ft_bar(itime)
+ else
+ write(11,*) (itime-1)*deltat - t0, 0.d0
+ endif
+ enddo
+
+ enddo
+ close(11)
+
+ enddo
+ print*,'*************************'
+ print*,'The input files (S****.AA.BHX/BHY/BHZ.adj) needed to run the adjoint simulation are in OUTPUT_FILES'
+ print*,'*************************'
+
+ end program adj_seismogram
Copied: seismo/2D/SPECFEM2D/trunk/src/shared/check_quality_external_mesh.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/check_quality_external_mesh.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/shared/check_quality_external_mesh.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/shared/check_quality_external_mesh.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,689 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! read an external 2D mesh file and display statistics about mesh quality;
+! and create an OpenDX file showing a given range of elements or a single element
+
+! Dimitri Komatitsch, University of Toulouse, France, January 2011.
+! (adapted from the version that is available in our 3D code, SPECFEM3D)
+
+!! DK DK
+!! DK DK this routine could be improved by computing the mean in addition to min and max of ratios
+!! DK DK
+
+ program check_quality_external_mesh
+
+ implicit none
+
+ include "constants.h"
+
+ integer, parameter :: NGNOD = 4 ! quadrangles
+
+ integer :: NPOIN ! number of nodes
+ integer :: NSPEC ! number of elements
+
+ double precision, dimension(:), allocatable :: x,y,z
+
+ integer, dimension(:,:), allocatable :: ibool
+
+ integer :: i,ispec,iformat,ispec_min_edge_length,ispec_max_edge_length, &
+ ispec_begin,ispec_end,ispec_to_output,ispec_equiangle_skewness_max
+
+! for quality of mesh
+ double precision :: equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio
+ double precision :: equiangle_skewness_min,edge_aspect_ratio_min,diagonal_aspect_ratio_min
+ double precision :: equiangle_skewness_max,edge_aspect_ratio_max,diagonal_aspect_ratio_max
+ double precision :: skewness_AVS_DX_min,skewness_AVS_DX_max,distance_min,distance_max
+ double precision :: distmin,distmax
+
+! for histogram
+ integer, parameter :: NCLASS = 20
+ integer classes_skewness(0:NCLASS-1)
+ integer :: iclass
+ double precision :: current_percent,total_percent
+
+! to export elements that have a certain skewness range to OpenDX
+ integer :: ntotspecAVS_DX
+ logical :: USE_OPENDX
+
+ character(len=100) interfacesfile,title
+
+ ! flag to save the last frame for kernels calculation purpose and type of simulation
+ logical :: SAVE_FORWARD
+ integer :: SIMULATION_TYPE
+
+ ! parameters for external mesh
+ logical :: read_external_mesh
+ character(len=256) :: mesh_file, nodes_coords_file
+
+ ! ignore variable name field (junk) at the beginning of each input line
+ !logical, parameter :: IGNORE_JUNK = .true.
+
+ integer :: NPOIN_unique_needed
+ integer, dimension(:), allocatable :: ibool_reduced
+ logical, dimension(:), allocatable :: mask_ibool
+
+ if(NGNOD /= 4) stop 'NGNOD must be 4'
+
+ ! ***
+ ! *** read the parameter file
+ ! ***
+
+ print *,'Reading the parameter file ... '
+ print *
+
+ open(unit=IIN,file='DATA/Par_file',status='old')
+
+ ! read and ignore file names and path for output
+ call read_value_string(IIN,IGNORE_JUNK,title)
+ call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
+
+ ! read and ignore type of simulation
+ call read_value_integer(IIN,IGNORE_JUNK,SIMULATION_TYPE)
+ call read_value_logical(IIN,IGNORE_JUNK,SAVE_FORWARD)
+
+ ! read info about external mesh
+ call read_value_logical(IIN,IGNORE_JUNK,read_external_mesh)
+ if(.not. read_external_mesh) stop 'this program is designed for read_external_mesh = .true.'
+ call read_value_string(IIN,IGNORE_JUNK,mesh_file)
+ call read_value_string(IIN,IGNORE_JUNK,nodes_coords_file)
+
+ print *
+ print *,'1 = output elements above a certain skewness threshold in OpenDX format'
+ print *,'2 = output a given element in OpenDX format'
+ print *,'3 = do not output any OpenDX file'
+ print *
+ print *,'enter value:'
+ read(5,*) iformat
+
+ if(iformat < 1 .or. iformat > 3) stop 'exiting...'
+
+ if(iformat == 1 .or. iformat == 2) then
+ USE_OPENDX = .true.
+ else
+ USE_OPENDX = .false.
+ endif
+
+! read the nodes
+ print *
+ print *,'start reading the external node file: ',nodes_coords_file(1:len_trim(nodes_coords_file))
+ open(unit=10,file=nodes_coords_file,status='unknown',action='read')
+
+! read the header
+ read(10,*) NPOIN
+
+! read the mesh
+ print *,'start reading the external mesh file: ',mesh_file(1:len_trim(mesh_file))
+ open(unit=11,file=mesh_file,status='unknown',action='read')
+
+! read the header
+ read(11,*) NSPEC
+
+ allocate(x(NPOIN))
+ allocate(y(NPOIN))
+ allocate(z(NPOIN))
+
+ allocate(ibool(NGNOD,NSPEC))
+
+ if(USE_OPENDX) then
+
+ if(iformat == 1) then
+
+! read range of skewness used for elements
+ print *
+ print *,'enter minimum skewness for OpenDX (between 0. and 0.99):'
+ read(5,*) skewness_AVS_DX_min
+ if(skewness_AVS_DX_min < 0.d0) skewness_AVS_DX_min = 0.d0
+ if(skewness_AVS_DX_min > 0.99999d0) skewness_AVS_DX_min = 0.99999d0
+
+!!!!!!!! print *,'enter maximum skewness for OpenDX (between 0. and 1.):'
+!!!!!!!!!!!!! read(5,*) skewness_AVS_DX_max
+ skewness_AVS_DX_max = 0.99999d0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if(skewness_AVS_DX_max < 0.d0) skewness_AVS_DX_max = 0.d0
+ if(skewness_AVS_DX_max > 0.99999d0) skewness_AVS_DX_max = 0.99999d0
+
+ if(skewness_AVS_DX_min > skewness_AVS_DX_max) stop 'incorrect skewness range'
+
+ else
+ print *,'enter the element number to output in OpenDX format between 1 and ',NSPEC
+ read(5,*) ispec_to_output
+ if(ispec_to_output < 1 .or. ispec_to_output > NSPEC) stop 'incorrect element number to output'
+ endif
+
+ endif
+
+! read the points
+ print *,'NPOIN = ',NPOIN
+ do i = 1,NPOIN
+ read(10,*) x(i),y(i)
+! the 2D mesh is flat, therefore the third coordinate is zero
+ z(i) = 0
+ enddo
+ close(10)
+
+! read the elements
+ print *,'NSPEC = ',NSPEC
+ do i = 1,NSPEC
+ read(11,*) ibool(1,i),ibool(2,i),ibool(3,i),ibool(4,i)
+ enddo
+ close(11)
+
+ print *,'done reading the external files'
+ print *
+
+ print *,'start computing the minimum and maximum edge size'
+
+! ************* compute min and max of skewness and ratios ******************
+
+! erase minimum and maximum of quality numbers
+ equiangle_skewness_min = + HUGEVAL
+ edge_aspect_ratio_min = + HUGEVAL
+ diagonal_aspect_ratio_min = + HUGEVAL
+ distance_min = + HUGEVAL
+
+ equiangle_skewness_max = - HUGEVAL
+ edge_aspect_ratio_max = - HUGEVAL
+ diagonal_aspect_ratio_max = - HUGEVAL
+ distance_max = - HUGEVAL
+
+ ispec_min_edge_length = -1
+ ispec_max_edge_length = -1
+
+! loop on all the elements
+ do ispec = 1,NSPEC
+
+ if(mod(ispec,100000) == 0) print *,'processed ',ispec,' elements out of ',NSPEC
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! store element number in which the edge of minimum or maximum length is located
+ if(distmin < distance_min) ispec_min_edge_length = ispec
+ if(distmax > distance_max) ispec_max_edge_length = ispec
+
+! compute minimum and maximum of quality numbers
+ equiangle_skewness_min = min(equiangle_skewness_min,equiangle_skewness)
+ edge_aspect_ratio_min = min(edge_aspect_ratio_min,edge_aspect_ratio)
+ diagonal_aspect_ratio_min = min(diagonal_aspect_ratio_min,diagonal_aspect_ratio)
+ distance_min = min(distance_min,distmin)
+
+ if(equiangle_skewness > equiangle_skewness_max) ispec_equiangle_skewness_max = ispec
+ equiangle_skewness_max = max(equiangle_skewness_max,equiangle_skewness)
+ edge_aspect_ratio_max = max(edge_aspect_ratio_max,edge_aspect_ratio)
+ diagonal_aspect_ratio_max = max(diagonal_aspect_ratio_max,diagonal_aspect_ratio)
+ distance_max = max(distance_max,distmax)
+
+ enddo
+ print *,'done processing ',NSPEC,' elements out of ',NSPEC
+
+ print *
+ print *,'------------'
+ print *,'mesh quality parameter definitions:'
+ print *
+ print *,'equiangle skewness: 0. perfect, 1. bad'
+ print *,'skewness max deviation angle: 0. perfect, 90. bad'
+ print *,'edge aspect ratio: 1. perfect, above 1. gives stretching factor'
+ print *,'diagonal aspect ratio: 1. perfect, above 1. gives stretching factor'
+ print *,'------------'
+
+ print *
+ print *,'minimum length of an edge in the whole mesh (m) = ',distance_min,' in element ',ispec_min_edge_length
+ print *
+ print *,'maximum length of an edge in the whole mesh (m) = ',distance_max,' in element ',ispec_max_edge_length
+ print *
+ print *,'max equiangle skewness = ',equiangle_skewness_max
+ print *,'in element ',ispec_equiangle_skewness_max
+! print *,'min equiangle skewness = ',equiangle_skewness_min
+ print *
+ print *,'max deviation angle from a right angle (90 degrees) is therefore = ',90.*equiangle_skewness_max
+ print *
+ print *,'worst angle in the mesh is therefore either ',90.*(1. - equiangle_skewness_max)
+ print *,'or ',180. - 90.*(1. - equiangle_skewness_max),' degrees'
+ print *
+ print *,'max edge aspect ratio = ',edge_aspect_ratio_max
+! print *,'min edge aspect ratio = ',edge_aspect_ratio_min
+ print *
+ print *,'max diagonal aspect ratio = ',diagonal_aspect_ratio_max
+! print *,'min diagonal aspect ratio = ',diagonal_aspect_ratio_min
+ print *
+
+! create statistics about mesh quality
+ print *,'creating histogram and statistics of mesh quality'
+
+! erase histogram of skewness
+ classes_skewness(:) = 0
+
+! loop on all the elements
+ do ispec = 1,NSPEC
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! store skewness in histogram
+ iclass = int(equiangle_skewness * dble(NCLASS))
+ if(iclass < 0) iclass = 0
+ if(iclass > NCLASS-1) iclass = NCLASS-1
+ classes_skewness(iclass) = classes_skewness(iclass) + 1
+
+ enddo
+
+! create histogram of skewness and save in Gnuplot file
+ print *
+ print *,'histogram of skewness (0. good - 1. bad):'
+ print *
+ total_percent = 0.
+ open(unit=14,file='mesh_quality_histogram.txt',status='unknown')
+ do iclass = 0,NCLASS-1
+ current_percent = 100.*dble(classes_skewness(iclass))/dble(NSPEC)
+ total_percent = total_percent + current_percent
+ print *,real(iclass/dble(NCLASS)),' - ',real((iclass+1)/dble(NCLASS)),classes_skewness(iclass),' ',sngl(current_percent),' %'
+ write(14,*) 0.5*(real(iclass/dble(NCLASS)) + real((iclass+1)/dble(NCLASS))),' ',sngl(current_percent)
+ enddo
+ close(14)
+
+! create script for Gnuplot histogram file
+ open(unit=14,file='plot_mesh_quality_histogram.gnu',status='unknown')
+ write(14,*) 'set term x11'
+ write(14,*) '#set term gif'
+ write(14,*) '#set output "mesh_quality_histogram.gif"'
+ write(14,*)
+ write(14,*) 'set xrange [0:1]'
+ write(14,*) 'set xtics 0,0.1,1'
+ write(14,*) 'set boxwidth ',1./real(NCLASS)
+ write(14,*) 'set xlabel "Skewness range"'
+ write(14,*) 'set ylabel "Percentage of elements (%)"'
+ write(14,*) 'plot "mesh_quality_histogram.txt" with boxes'
+ write(14,*) 'pause -1 "hit any key..."'
+ close(14)
+
+ print *
+ print *,'total number of elements = ',NSPEC
+ print *
+
+! display warning if maximum skewness is too high
+ if(equiangle_skewness_max >= 0.75d0) then
+ print *
+ print *,'*********************************************'
+ print *,'*********************************************'
+ print *,' WARNING, mesh is bad (max skewness >= 0.75)'
+ print *,'*********************************************'
+ print *,'*********************************************'
+ print *
+ endif
+
+ if(total_percent < 99.9d0 .or. total_percent > 100.1d0) then
+ print *,'total percentage = ',total_percent,' %'
+ stop 'total percentage should be 100%'
+ endif
+
+! ************* create OpenDX file with elements in a certain range of skewness
+
+ if(USE_OPENDX) then
+
+ print *
+ if(iformat == 1) then
+ print *,'creating OpenDX file with subset of elements in skewness range'
+ print *,'between ',skewness_AVS_DX_min,' and ',skewness_AVS_DX_max
+ else
+ print *,'creating OpenDX file with element #',ispec_to_output
+ endif
+ print *
+
+! ************* count number of elements in skewness range *************
+
+! erase number of elements belonging to skewness range for AVS_DX
+ ntotspecAVS_DX = 0
+
+! loop on all the elements
+ if(iformat == 1) then
+
+ do ispec = 1,NSPEC
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! check if element belongs to requested skewness range
+ if(equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max) &
+ ntotspecAVS_DX = ntotspecAVS_DX + 1
+
+ enddo
+
+ else
+! outputing a single element
+ ntotspecAVS_DX = 1
+ endif
+
+ if(ntotspecAVS_DX == 0) then
+ stop 'no elements in skewness range, no file created'
+ else if(iformat == 1) then
+ print *
+ print *,'there are ',ntotspecAVS_DX,' elements in AVS or DX skewness range ',skewness_AVS_DX_min,skewness_AVS_DX_max
+ print *
+ endif
+
+ open(unit=11,file='DX_mesh_quality.dx',status='unknown')
+
+! generate the subset of points that are needed
+
+! count the number of unique points
+ NPOIN_unique_needed = 0
+ allocate(mask_ibool(NPOIN))
+ mask_ibool(:) = .false.
+
+! loop on all the elements
+ if(iformat == 1) then
+ ispec_begin = 1
+ ispec_end = NSPEC
+ else
+ ispec_begin = ispec_to_output
+ ispec_end = ispec_to_output
+ endif
+
+ do ispec = ispec_begin,ispec_end
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! check if element needs to be output
+ if(iformat == 2 .or. (iformat == 1 .and. &
+ equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
+! create point for first corner of the element
+ if(.not. mask_ibool(ibool(1,ispec))) then
+ mask_ibool(ibool(1,ispec)) = .true.
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for second corner of the element
+ if(.not. mask_ibool(ibool(2,ispec))) then
+ mask_ibool(ibool(2,ispec)) = .true.
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for third corner of the element
+ if(.not. mask_ibool(ibool(3,ispec))) then
+ mask_ibool(ibool(3,ispec)) = .true.
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for fourth corner of the element
+ if(.not. mask_ibool(ibool(4,ispec))) then
+ mask_ibool(ibool(4,ispec)) = .true.
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+ endif
+
+ enddo
+
+
+! ************* generate points ******************
+
+! write OpenDX header
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',NPOIN_unique_needed,' data follows'
+
+ allocate(ibool_reduced(NPOIN))
+
+! count the number of unique points
+ NPOIN_unique_needed = 0
+ mask_ibool(:) = .false.
+
+! loop on all the elements
+ if(iformat == 1) then
+ ispec_begin = 1
+ ispec_end = NSPEC
+ else
+ ispec_begin = ispec_to_output
+ ispec_end = ispec_to_output
+ endif
+
+ do ispec = ispec_begin,ispec_end
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! check if element needs to be output
+ if(iformat == 2 .or. (iformat == 1 .and. &
+ equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
+! create point for first corner of the element
+ if(.not. mask_ibool(ibool(1,ispec))) then
+ mask_ibool(ibool(1,ispec)) = .true.
+ ibool_reduced(ibool(1,ispec)) = NPOIN_unique_needed
+ write(11,*) sngl(x(ibool(1,ispec))),sngl(y(ibool(1,ispec))),sngl(z(ibool(1,ispec)))
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for second corner of the element
+ if(.not. mask_ibool(ibool(2,ispec))) then
+ mask_ibool(ibool(2,ispec)) = .true.
+ ibool_reduced(ibool(2,ispec)) = NPOIN_unique_needed
+ write(11,*) sngl(x(ibool(2,ispec))),sngl(y(ibool(2,ispec))),sngl(z(ibool(2,ispec)))
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for third corner of the element
+ if(.not. mask_ibool(ibool(3,ispec))) then
+ mask_ibool(ibool(3,ispec)) = .true.
+ ibool_reduced(ibool(3,ispec)) = NPOIN_unique_needed
+ write(11,*) sngl(x(ibool(3,ispec))),sngl(y(ibool(3,ispec))),sngl(z(ibool(3,ispec)))
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for fourth corner of the element
+ if(.not. mask_ibool(ibool(4,ispec))) then
+ mask_ibool(ibool(4,ispec)) = .true.
+ ibool_reduced(ibool(4,ispec)) = NPOIN_unique_needed
+ write(11,*) sngl(x(ibool(4,ispec))),sngl(y(ibool(4,ispec))),sngl(z(ibool(4,ispec)))
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+ endif
+
+ enddo
+
+ deallocate(mask_ibool)
+
+! ************* generate elements ******************
+
+ write(11,*) 'object 2 class array type int rank 1 shape ',NGNOD,' items ',ntotspecAVS_DX,' data follows'
+
+! loop on all the elements
+ if(iformat == 1) then
+ ispec_begin = 1
+ ispec_end = NSPEC
+ else
+ ispec_begin = ispec_to_output
+ ispec_end = ispec_to_output
+ endif
+
+ do ispec = ispec_begin,ispec_end
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! check if element needs to be output
+ if(iformat == 2 .or. (iformat == 1 .and. &
+ equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
+! point order in OpenDX in 2D is 1,4,2,3 *not* 1,2,3,4 as in AVS
+! point order in OpenDX in 3D is 4,1,8,5,3,2,7,6, *not* 1,2,3,4,5,6,7,8 as in AVS
+! in the case of OpenDX, node numbers start at zero
+ write(11,"(i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9)") &
+ ibool_reduced(ibool(1,ispec)), ibool_reduced(ibool(4,ispec)), &
+ ibool_reduced(ibool(2,ispec)), ibool_reduced(ibool(3,ispec))
+ if(iformat == 1) print *,'element ',ispec,' belongs to the range and has skewness = ',sngl(equiangle_skewness)
+ endif
+
+ enddo
+
+! ************* generate element data values ******************
+
+! output OpenDX header for data
+ write(11,*) 'attribute "element type" string "quads"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
+
+! loop on all the elements
+ do ispec = ispec_begin,ispec_end
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! check if element needs to be output
+ if(iformat == 2 .or. (iformat == 1 .and. &
+ equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) &
+ write(11,*) sngl(equiangle_skewness)
+
+ enddo
+
+! define OpenDX field
+ write(11,*) 'attribute "dep" string "connections"'
+ write(11,*) 'object "irregular positions irregular connections" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+
+! close OpenDX file
+ close(11)
+
+ endif
+
+ end program check_quality_external_mesh
+
+!
+!=====================================================================
+!
+
+! create mesh quality data for a given 2D spectral element
+
+ subroutine create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: icorner,ispec,NSPEC,NPOIN,NGNOD,i
+
+ double precision, dimension(NPOIN) :: x,y,z
+
+ integer, dimension(NGNOD,NSPEC) :: ibool
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm
+
+ double precision vectorA_x,vectorA_y,vectorA_z
+ double precision vectorB_x,vectorB_y,vectorB_z
+ double precision norm_A,norm_B,angle_vectors
+ double precision distmin,distmax,dist,dist1,dist2
+ double precision equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio
+
+! topology of faces of cube for skewness
+! only one face in 2D
+ integer faces_topo(6)
+
+! store the corners of this element for the skewness routine
+ do i = 1,NGNOD
+ xelm(i) = x(ibool(i,ispec))
+ yelm(i) = y(ibool(i,ispec))
+ zelm(i) = z(ibool(i,ispec))
+ enddo
+
+! define topology of faces of cube for skewness
+
+! only one face in 2D
+ faces_topo(1) = 1
+ faces_topo(2) = 2
+ faces_topo(3) = 3
+ faces_topo(4) = 4
+
+! define wraparound for angles for skewness calculation
+ faces_topo(5) = faces_topo(1)
+ faces_topo(6) = faces_topo(2)
+
+! compute equiangle skewness (as defined in Fluent/Gambit manual)
+! and compute edge aspect ratio using the corners of the element
+ distmin = + HUGEVAL
+ distmax = - HUGEVAL
+ equiangle_skewness = - HUGEVAL
+
+ do icorner = 1,4
+
+! first vector of angle
+ vectorA_x = xelm(faces_topo(icorner)) - xelm(faces_topo(icorner+1))
+ vectorA_y = yelm(faces_topo(icorner)) - yelm(faces_topo(icorner+1))
+ vectorA_z = zelm(faces_topo(icorner)) - zelm(faces_topo(icorner+1))
+
+! second vector of angle
+ vectorB_x = xelm(faces_topo(icorner+2)) - xelm(faces_topo(icorner+1))
+ vectorB_y = yelm(faces_topo(icorner+2)) - yelm(faces_topo(icorner+1))
+ vectorB_z = zelm(faces_topo(icorner+2)) - zelm(faces_topo(icorner+1))
+
+! norm of vectors A and B
+ norm_A = sqrt(vectorA_x**2 + vectorA_y**2 + vectorA_z**2)
+ norm_B = sqrt(vectorB_x**2 + vectorB_y**2 + vectorB_z**2)
+
+! angle formed by the two vectors
+ angle_vectors = dacos((vectorA_x*vectorB_x + vectorA_y*vectorB_y + vectorA_z*vectorB_z) / (norm_A * norm_B))
+
+! compute equiangle skewness
+ equiangle_skewness = max(equiangle_skewness,dabs(2.d0 * angle_vectors - PI) / PI)
+
+! compute min and max size of an edge
+ dist = sqrt(vectorA_x**2 + vectorA_y**2 + vectorA_z**2)
+
+ distmin = min(distmin,dist)
+ distmax = max(distmax,dist)
+
+ enddo
+
+! compute edge aspect ratio
+ edge_aspect_ratio = distmax / distmin
+
+! compute diagonal aspect ratio
+ dist1 = sqrt((xelm(1) - xelm(3))**2 + (yelm(1) - yelm(3))**2 + (zelm(1) - zelm(3))**2)
+ dist2 = sqrt((xelm(2) - xelm(4))**2 + (yelm(2) - yelm(4))**2 + (zelm(2) - zelm(4))**2)
+ diagonal_aspect_ratio = max(dist1,dist2) / min(dist1,dist2)
+
+ end subroutine create_mesh_quality_data_2D
+
Copied: seismo/2D/SPECFEM2D/trunk/src/shared/convolve_source_timefunction.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/convolve_source_timefunction.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/shared/convolve_source_timefunction.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/shared/convolve_source_timefunction.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,152 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ program convolve_source_time_function
+
+!
+! convolve seismograms computed for a Heaviside with given source time function
+!
+
+! we mimic a triangle of half duration equal to half_duration_triangle
+! using a Gaussian having a very close shape, as explained in Figure 4.2
+! of the manual
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: i,j,N_j,number_remove,nlines
+
+ double precision :: alpha,dt,tau_j,source,exponent,t1,t2,displ1,displ2,gamma,height,half_duration_triangle
+
+ logical :: triangle
+
+ double precision, dimension(:), allocatable :: time,sem,sem_fil
+
+! read file with number of lines in input
+ open(unit=33,file='input_convolve_code.txt',status='old',action='read')
+ read(33,*) nlines
+ read(33,*) half_duration_triangle
+ read(33,*) triangle
+ close(33)
+
+! allocate arrays
+ allocate(time(nlines),sem(nlines),sem_fil(nlines))
+
+! read the input seismogram
+ do i = 1,nlines
+ read(5,*) time(i),sem(i)
+ enddo
+
+! define a Gaussian with the right exponent to mimic a triangle of equivalent half duration
+ alpha = SOURCE_DECAY_MIMIC_TRIANGLE/half_duration_triangle
+
+! compute the time step
+ dt = time(2) - time(1)
+
+! number of integers for which the source wavelet is different from zero
+ if(triangle) then
+ N_j = ceiling(half_duration_triangle/dt)
+ else
+ N_j = ceiling(1.5d0*half_duration_triangle/dt)
+ endif
+
+ do i = 1,nlines
+
+ sem_fil(i) = 0.d0
+
+ do j = -N_j,N_j
+
+ if(i > j .and. i-j <= nlines) then
+
+ tau_j = dble(j)*dt
+
+! convolve with a triangle
+ if(triangle) then
+ height = 1.d0 / half_duration_triangle
+ if(abs(tau_j) > half_duration_triangle) then
+ source = 0.d0
+ else if (tau_j < 0.d0) then
+ t1 = - N_j * dt
+ displ1 = 0.d0
+ t2 = 0.d0
+ displ2 = height
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1.d0 - gamma) * displ1 + gamma * displ2
+ else
+ t1 = 0.d0
+ displ1 = height
+ t2 = + N_j * dt
+ displ2 = 0.d0
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1.d0 - gamma) * displ1 + gamma * displ2
+ endif
+
+ else
+
+! convolve with a Gaussian
+ exponent = alpha**2 * tau_j**2
+ if(exponent < 50.d0) then
+ source = alpha*exp(-exponent)/sqrt(PI)
+ else
+ source = 0.d0
+ endif
+
+ endif
+
+ sem_fil(i) = sem_fil(i) + sem(i-j)*source*dt
+
+ endif
+
+ enddo
+ enddo
+
+! compute number of samples to remove from end of seismograms
+ number_remove = N_j + 1
+ do i=1,nlines - number_remove
+ write(*,*) sngl(time(i)),' ',sngl(sem_fil(i))
+ enddo
+
+ end program convolve_source_time_function
+
Copied: seismo/2D/SPECFEM2D/trunk/src/shared/read_value_parameters.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/read_value_parameters.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/shared/read_value_parameters.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/shared/read_value_parameters.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,211 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! read values from parameter file, ignoring white lines and comments
+
+ subroutine read_value_integer(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ integer value_to_read
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_integer
+
+!--------------------
+
+ subroutine read_value_double_precision(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ double precision value_to_read
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_double_precision
+
+!--------------------
+
+ subroutine read_value_logical(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ logical value_to_read
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_logical
+
+!--------------------
+
+ subroutine read_value_string(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ character(len=*) value_to_read
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ value_to_read = string_read
+
+ end subroutine read_value_string
+
+!--------------------
+
+ subroutine read_two_interface_points(iin,ignore_junk,value_to_read_1,value_to_read_2)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ double precision value_to_read_1,value_to_read_2
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ read(string_read,*) value_to_read_1,value_to_read_2
+
+ end subroutine read_two_interface_points
+
+!--------------------
+
+ subroutine read_region_coordinates(iin,ignore_junk,value_to_read_1,value_to_read_2, &
+ value_to_read_3,value_to_read_4,value_to_read_5)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ integer value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ read(string_read,*) value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5
+
+ end subroutine read_region_coordinates
+
+!--------------------
+
+ 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 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)
+ print*,string_read
+ read(string_read,*) i,icodematread,val0read,val1read,val2read,val3read,val4read,val5read,&
+ val6read,val7read,val8read,val9read,val10read,val11read,val12read
+
+
+ end subroutine read_material_parameters
+
+!--------------------
+
+ subroutine read_next_line(iin,ignore_junk,string_read)
+
+ implicit none
+
+ logical ignore_junk
+ character(len=100) string_read
+
+ integer ios,iin,index_equal_sign
+
+ do
+ read(unit=iin,fmt="(a100)",iostat=ios) string_read
+ if(ios /= 0) stop 'error while reading input file'
+
+! suppress leading white spaces, if any
+ string_read = adjustl(string_read)
+
+! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS)
+ if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1)
+
+! exit loop when we find the first line that is not a comment or a white line
+ if(len_trim(string_read) == 0) cycle
+ if(string_read(1:1) /= '#') exit
+
+ enddo
+
+! suppress trailing white spaces, if any
+ string_read = string_read(1:len_trim(string_read))
+
+! suppress trailing comments, if any
+ if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1)
+
+! suppress leading junk (up to the first equal sign, included) if needed
+ if(ignore_junk) then
+ index_equal_sign = index(string_read,'=')
+ if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file'
+ string_read = string_read(index_equal_sign + 1:len_trim(string_read))
+ endif
+
+! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk
+ string_read = adjustl(string_read)
+ string_read = string_read(1:len_trim(string_read))
+
+ end subroutine read_next_line
+
Deleted: seismo/2D/SPECFEM2D/trunk/src/sort_array_coordinates.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/sort_array_coordinates.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/sort_array_coordinates.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,241 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
-#ifdef USE_MPI
-
-! subroutines to sort MPI buffers to assemble between chunks
-
- subroutine sort_array_coordinates(npointot,x,z,ibool,iglob,loc,ifseg, &
- nglob,ind,ninseg,iwork,work)
-
-! this routine MUST be in double precision to avoid sensitivity
-! to roundoff errors in the coordinates of the points
-!
-! returns: sorted indexing array (ibool), reordering array (iglob) & number of global points (nglob)
-
- implicit none
-
- include "constants.h"
-
- integer,intent(in) :: npointot
- integer,intent(out) :: nglob
-
- integer,intent(inout) :: ibool(npointot)
-
- integer iglob(npointot),loc(npointot)
- integer ind(npointot),ninseg(npointot)
- logical ifseg(npointot)
- double precision,intent(in) :: x(npointot),z(npointot)
- integer iwork(npointot)
- double precision work(npointot)
-
- ! local parameters
- integer ipoin,i,j
- integer nseg,ioff,iseg,ig
- ! define a tolerance, normalized radius is 1., so let's use a small value
- double precision,parameter :: xtol = SMALLVALTOL
-
- ! establish initial pointers
- do ipoin=1,npointot
- loc(ipoin)=ipoin
- enddo
-
- ifseg(:)=.false.
-
- nseg=1
- ifseg(1)=.true.
- ninseg(1)=npointot
-
- do j=1,NDIM
-
- ! sort within each segment
- ioff=1
- do iseg=1,nseg
-
- if(j == 1) then
- call rank_buffers(x(ioff),ind,ninseg(iseg))
- else if(j == 2) then
- call rank_buffers(z(ioff),ind,ninseg(iseg))
- endif
-
- call swap_all_buffers(ibool(ioff),loc(ioff), &
- x(ioff),z(ioff),iwork,work,ind,ninseg(iseg))
-
- ioff=ioff+ninseg(iseg)
- enddo
-
- ! check for jumps in current coordinate
- if(j == 1) then
- do i=2,npointot
- if(dabs(x(i)-x(i-1)) > xtol) ifseg(i)=.true.
- enddo
- else if(j == 2) then
- do i=2,npointot
- if(dabs(z(i)-z(i-1)) > xtol) ifseg(i)=.true.
- enddo
- endif
-
- ! count up number of different segments
- nseg=0
- do i=1,npointot
- if(ifseg(i)) then
- nseg=nseg+1
- ninseg(nseg)=1
- else
- ninseg(nseg)=ninseg(nseg)+1
- endif
- enddo
- enddo
-
- ! assign global node numbers (now sorted lexicographically)
- ig=0
- do i=1,npointot
- if(ifseg(i)) ig=ig+1
- iglob(loc(i))=ig
- enddo
-
- nglob=ig
-
- end subroutine sort_array_coordinates
-
-! -------------------- library for sorting routine ------------------
-
-! sorting routines put here in same file to allow for inlining
-
- subroutine rank_buffers(A,IND,N)
-!
-! Use Heap Sort (Numerical Recipes)
-!
- implicit none
-
- integer n
- double precision A(n)
- integer IND(n)
-
- integer i,j,l,ir,indx
- double precision q
-
- do j=1,n
- IND(j)=j
- enddo
-
- if(n == 1) return
-
- L=n/2+1
- ir=n
- 100 CONTINUE
- IF(l>1) THEN
- l=l-1
- indx=ind(l)
- q=a(indx)
- ELSE
- indx=ind(ir)
- q=a(indx)
- ind(ir)=ind(1)
- ir=ir-1
- if (ir == 1) then
- ind(1)=indx
- return
- endif
- ENDIF
- i=l
- j=l+l
- 200 CONTINUE
- IF(J <= IR) THEN
- IF(J < IR) THEN
- IF(A(IND(j)) < A(IND(j+1))) j=j+1
- ENDIF
- IF (q < A(IND(j))) THEN
- IND(I)=IND(J)
- I=J
- J=J+J
- ELSE
- J=IR+1
- ENDIF
- goto 200
- ENDIF
- IND(I)=INDX
- goto 100
- end subroutine rank_buffers
-
-! -------------------------------------------------------------------
-
- subroutine swap_all_buffers(IA,IB,A,B,IW,W,ind,n)
-!
-! swap arrays IA, IB, A and B according to addressing in array IND
-!
- implicit none
-
- integer n
-
- integer IND(n)
- integer IA(n),IB(n),IW(n)
- double precision A(n),B(n),W(n)
-
- integer i
-
- do i=1,n
- W(i)=A(i)
- IW(i)=IA(i)
- enddo
-
- do i=1,n
- A(i)=W(ind(i))
- IA(i)=IW(ind(i))
- enddo
-
- do i=1,n
- W(i)=B(i)
- IW(i)=IB(i)
- enddo
-
- do i=1,n
- B(i)=W(ind(i))
- IB(i)=IW(ind(i))
- enddo
-
- end subroutine swap_all_buffers
-
-#endif
Added: seismo/2D/SPECFEM2D/trunk/src/specfem2D/Makefile.in
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/Makefile.in (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/Makefile.in 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,430 @@
+
+#========================================================================
+#
+# S P E C F E M 2 D Version 6.1
+# ------------------------------
+#
+# Copyright Universite de Pau, CNRS and INRIA, France,
+# and Princeton University / California Institute of Technology, USA.
+# 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 princeton DOT edu
+#
+# This software is a computer program whose purpose is to solve
+# the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+# using a spectral-element method (SEM).
+#
+# This software is governed by the CeCILL license under French law and
+# abiding by the rules of distribution of free software. You can use,
+# modify and/or redistribute the software under the terms of the CeCILL
+# license as circulated by CEA, CNRS and INRIA at the following URL
+# "http://www.cecill.info".
+#
+# As a counterpart to the access to the source code and rights to copy,
+# modify and redistribute granted by the license, users are provided only
+# with a limited warranty and the software's author, the holder of the
+# economic rights, and the successive licensors have only limited
+# liability.
+#
+# In this respect, the user's attention is drawn to the risks associated
+# with loading, using, modifying and/or developing or reproducing the
+# software by the user in light of its specific status of free software,
+# that may mean that it is complicated to manipulate, and that also
+# therefore means that it is reserved for developers and experienced
+# professionals having in-depth computer knowledge. Users are therefore
+# encouraged to load and test the software's suitability as regards their
+# requirements in conditions enabling the security of their systems and/or
+# data to be ensured and, more generally, to use and operate it in the
+# same conditions as regards security.
+#
+# The full text of the license is available in file "LICENSE".
+#
+#========================================================================
+
+# 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
+
+# @configure_input@
+
+FC = @FC@
+FCFLAGS = #@FCFLAGS@
+
+MPIFC = @MPIFC@
+MPILIBS = @MPILIBS@
+
+FLAGS_CHECK = @FLAGS_CHECK@ -I../../setup
+FLAGS_NO_CHECK = @FLAGS_NO_CHECK@ -I../../setup
+
+CC = @CC@
+CPPFLAGS = @CPPFLAGS@ $(COND_MPI_CPPFLAGS)
+CFLAGS = @CFLAGS@ $(CPPFLAGS) -I../../setup
+
+## serial or parallel
+ at COND_MPI_TRUE@F90 = $(MPIFC) $(FCFLAGS) -DUSE_MPI -DUSE_SCOTCH -I"@SCOTCH_INCLUDEDIR@" $(MPILIBS)
+ at COND_MPI_FALSE@F90 = $(FC) $(FCFLAGS)
+
+
+LINK = $(F90)
+
+## compilation directories
+# E : executables directory
+E = ../../bin
+# O : objects directory
+O = ../../obj
+# SHARED : shared directoy
+SHARED = ../shared
+# S : source file directory
+S = .
+## setup file directory
+SETUP = ../../setup
+
+
+##.PHONY: clean default all backup bak generate_databases specfem3D meshfem3D
+
+####
+#### targets
+####
+
+# default targets for the pure Fortran version
+ at COND_PYRE_FALSE@DEFAULT = \
+ at COND_PYRE_FALSE@ specfem2D \
+ at COND_PYRE_FALSE@ convolve_source_timefunction \
+ at COND_PYRE_FALSE@ $(EMPTY_MACRO)
+
+
+OBJS_SPECFEM2D = \
+ $O/assemble_MPI.o \
+ $O/attenuation_model.o \
+ $O/attenuation_compute_param.o \
+ $O/calendar.o \
+ $O/checkgrid.o \
+ $O/check_stability.o \
+ $O/compute_arrays_source.o \
+ $O/compute_Bielak_conditions.o \
+ $O/compute_curl_one_element.o \
+ $O/compute_energy.o \
+ $O/compute_forces_acoustic.o \
+ $O/compute_forces_viscoelastic.o \
+ $O/compute_forces_poro_solid.o \
+ $O/compute_forces_poro_fluid.o \
+ $O/compute_gradient_attenuation.o \
+ $O/compute_normal_vector.o \
+ $O/compute_pressure.o \
+ $O/compute_vector_field.o \
+ $O/construct_acoustic_surface.o \
+ $O/convert_time.o \
+ $O/create_color_image.o \
+ $O/createnum_fast.o \
+ $O/createnum_slow.o \
+ $O/datim.o \
+ $O/define_derivation_matrices.o \
+ $O/define_external_model.o \
+ $O/define_shape_functions.o \
+ $O/enforce_acoustic_free_surface.o \
+ $O/exit_mpi.o \
+ $O/get_MPI.o \
+ $O/get_perm_cuthill_mckee.o \
+ $O/get_poroelastic_velocities.o \
+ $O/gll_library.o \
+ $O/gmat01.o \
+ $O/initialize_simulation.o \
+ $O/invert_mass_matrix.o \
+ $O/is_in_convex_quadrilateral.o \
+ $O/lagrange_poly.o \
+ $O/locate_receivers.o \
+ $O/locate_source_force.o \
+ $O/locate_source_moment_tensor.o \
+ $O/netlib_specfun_erf.o \
+ $O/paco_beyond_critical.o \
+ $O/paco_convolve_fft.o \
+ $O/plotgll.o \
+ $O/plotpost.o \
+ $O/prepare_absorb.o \
+ $O/prepare_assemble_MPI.o \
+ $O/prepare_color_image.o \
+ $O/prepare_initialfield.o \
+ $O/prepare_source_time_function.o \
+ $O/read_databases.o \
+ $O/read_external_model.o \
+ $O/recompute_jacobian.o \
+ $O/save_openDX_jacobian.o \
+ $O/set_sources.o \
+ $O/setup_sources_receivers.o \
+ $O/sort_array_coordinates.o \
+ $O/write_seismograms.o \
+ $O/specfem2D.o
+
+
+
+default: $(DEFAULT)
+
+all: default
+
+spec : specfem2D
+specfem2D: xspecfem2D
+convolve_source_timefunction: xconvolve_source_timefunction
+
+
+clean:
+ (rm -rf $O/*.o $E/xspecfem2D $E/xspecfem2D.trace \
+ $O/*.o $O/*.il *.mod core \
+ $E/xconvolve_source_timefunction \
+ *.oo *.ipo)
+
+
+help:
+ @echo "usage: make [executable]"
+ @echo ""
+ @echo "supported executables:"
+ @echo " xspecfem3D"
+ @echo " xconvolve_source_timefunction"
+ @echo " xadj_seismogram"
+ @echo ""
+
+
+##
+## solver
+##
+### use optimized compilation option for solver only
+xspecfem2D: $(OBJS_SPECFEM2D)
+ $(LINK) $(FLAGS_NO_CHECK) -o ${E}/xspecfem2D $(OBJS_SPECFEM2D)
+
+##
+## convolve_source_timefunction
+##
+xconvolve_source_timefunction: $O/convolve_source_timefunction.o
+ ${F90} $(FLAGS_CHECK) -o ${E}/xconvolve_source_timefunction $O/convolve_source_timefunction.o
+
+##
+## adj_seismogram
+##
+xadj_seismogram: $O/adj_seismogram.o
+ ${F90} $(FLAGS_CHECK) -o ${E}/xadj_seismogram $O/adj_seismogram.o
+
+
+##
+## object files
+##
+
+##
+## convolve_source_timefunction
+##
+$O/convolve_source_timefunction.o: ${SHARED}/convolve_source_timefunction.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/convolve_source_timefunction.o ${SHARED}/convolve_source_timefunction.f90
+
+##
+## adj_seismogram
+##
+$O/adj_seismogram.o: ${SHARED}/adj_seismogram.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/adj_seismogram.o ${SHARED}/adj_seismogram.f90
+
+##
+## specfem2D
+##
+$O/assemble_MPI.o: ${S}/assemble_MPI.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/assemble_MPI.o ${S}/assemble_MPI.F90
+
+$O/attenuation_compute_param.o: ${S}/attenuation_compute_param.c
+ ${CC} $(CFLAGS) -c -o $O/attenuation_compute_param.o ${S}/attenuation_compute_param.c
+
+$O/attenuation_model.o: ${S}/attenuation_model.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/attenuation_model.o ${S}/attenuation_model.f90
+
+$O/calendar.o: ${S}/calendar.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/calendar.o ${S}/calendar.f90
+
+$O/checkgrid.o: ${S}/checkgrid.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/checkgrid.o ${S}/checkgrid.F90
+
+$O/compute_arrays_source.o: ${S}/compute_arrays_source.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/compute_arrays_source.o ${S}/compute_arrays_source.f90
+
+$O/compute_Bielak_conditions.o: ${S}/compute_Bielak_conditions.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/compute_Bielak_conditions.o ${S}/compute_Bielak_conditions.f90
+
+$O/compute_curl_one_element.o: ${S}/compute_curl_one_element.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/compute_curl_one_element.o ${S}/compute_curl_one_element.f90
+
+$O/compute_vector_field.o: ${S}/compute_vector_field.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/compute_vector_field.o ${S}/compute_vector_field.f90
+
+$O/compute_pressure.o: ${S}/compute_pressure.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/compute_pressure.o ${S}/compute_pressure.f90
+
+$O/construct_acoustic_surface.o: ${S}/construct_acoustic_surface.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/construct_acoustic_surface.o ${S}/construct_acoustic_surface.f90
+
+$O/convert_time.o: ${S}/convert_time.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/convert_time.o ${S}/convert_time.f90
+
+$O/create_color_image.o: ${S}/create_color_image.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/create_color_image.o ${S}/create_color_image.f90
+
+$O/createnum_fast.o: ${S}/createnum_fast.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/createnum_fast.o ${S}/createnum_fast.f90
+
+$O/createnum_slow.o: ${S}/createnum_slow.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/createnum_slow.o ${S}/createnum_slow.f90
+
+$O/datim.o: ${S}/datim.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/datim.o ${S}/datim.f90
+
+$O/define_derivation_matrices.o: ${S}/define_derivation_matrices.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/define_derivation_matrices.o ${S}/define_derivation_matrices.f90
+
+$O/define_external_model.o: ${S}/define_external_model.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/define_external_model.o ${S}/define_external_model.f90
+
+$O/define_shape_functions.o: ${S}/define_shape_functions.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/define_shape_functions.o ${S}/define_shape_functions.f90
+
+$O/exit_mpi.o: ${S}/exit_mpi.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/exit_mpi.o ${S}/exit_mpi.F90
+
+$O/get_MPI.o: ${S}/get_MPI.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/get_MPI.o ${S}/get_MPI.F90
+
+$O/get_perm_cuthill_mckee.o: ${S}/get_perm_cuthill_mckee.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/get_perm_cuthill_mckee.o ${S}/get_perm_cuthill_mckee.f90
+
+$O/get_poroelastic_velocities.o: ${S}/get_poroelastic_velocities.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/get_poroelastic_velocities.o ${S}/get_poroelastic_velocities.f90
+
+$O/gll_library.o: ${S}/gll_library.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/gll_library.o ${S}/gll_library.f90
+
+$O/gmat01.o: ${S}/gmat01.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/gmat01.o ${S}/gmat01.f90
+
+$O/invert_mass_matrix.o: ${S}/invert_mass_matrix.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/invert_mass_matrix.o ${S}/invert_mass_matrix.f90
+
+$O/initialize_simulation.o: ${S}/initialize_simulation.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/initialize_simulation.o ${S}/initialize_simulation.F90
+
+$O/is_in_convex_quadrilateral.o: ${S}/is_in_convex_quadrilateral.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/is_in_convex_quadrilateral.o ${S}/is_in_convex_quadrilateral.f90
+
+$O/lagrange_poly.o: ${S}/lagrange_poly.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/lagrange_poly.o ${S}/lagrange_poly.f90
+
+$O/locate_receivers.o: ${S}/locate_receivers.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/locate_receivers.o ${S}/locate_receivers.F90
+
+$O/locate_source_force.o: ${S}/locate_source_force.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/locate_source_force.o ${S}/locate_source_force.F90
+
+$O/locate_source_moment_tensor.o: ${S}/locate_source_moment_tensor.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/locate_source_moment_tensor.o ${S}/locate_source_moment_tensor.F90
+
+$O/netlib_specfun_erf.o: ${S}/netlib_specfun_erf.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/netlib_specfun_erf.o ${S}/netlib_specfun_erf.f90
+
+$O/paco_beyond_critical.o: ${S}/paco_beyond_critical.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/paco_beyond_critical.o ${S}/paco_beyond_critical.f90
+
+$O/paco_convolve_fft.o: ${S}/paco_convolve_fft.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/paco_convolve_fft.o ${S}/paco_convolve_fft.f90
+
+$O/plotgll.o: ${S}/plotgll.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/plotgll.o ${S}/plotgll.f90
+
+$O/plotpost.o: ${S}/plotpost.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/plotpost.o ${S}/plotpost.F90
+
+$O/prepare_absorb.o: ${S}/prepare_absorb.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/prepare_absorb.o ${S}/prepare_absorb.f90
+
+$O/prepare_assemble_MPI.o: ${S}/prepare_assemble_MPI.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/prepare_assemble_MPI.o ${S}/prepare_assemble_MPI.F90
+
+$O/prepare_color_image.o: ${S}/prepare_color_image.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/prepare_color_image.o ${S}/prepare_color_image.F90
+
+$O/prepare_initialfield.o: ${S}/prepare_initialfield.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/prepare_initialfield.o ${S}/prepare_initialfield.F90
+
+$O/prepare_source_time_function.o: ${S}/prepare_source_time_function.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/prepare_source_time_function.o ${S}/prepare_source_time_function.f90
+
+$O/read_databases.o: ${S}/read_databases.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/read_databases.o ${S}/read_databases.f90
+
+$O/read_external_model.o: ${S}/read_external_model.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/read_external_model.o ${S}/read_external_model.f90
+
+$O/recompute_jacobian.o: ${S}/recompute_jacobian.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/recompute_jacobian.o ${S}/recompute_jacobian.f90
+
+$O/save_databases.o: ${S}/save_databases.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/save_databases.o ${S}/save_databases.f90
+
+$O/save_gnuplot_file.o: ${S}/save_gnuplot_file.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/save_gnuplot_file.o ${S}/save_gnuplot_file.f90
+
+$O/save_openDX_jacobian.o: ${S}/save_openDX_jacobian.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/save_openDX_jacobian.o ${S}/save_openDX_jacobian.f90
+
+$O/save_stations_file.o: ${S}/save_stations_file.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/save_stations_file.o ${S}/save_stations_file.f90
+
+$O/set_sources.o: ${S}/set_sources.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/set_sources.o ${S}/set_sources.f90
+
+$O/setup_sources_receivers.o: ${S}/setup_sources_receivers.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/setup_sources_receivers.o ${S}/setup_sources_receivers.f90
+
+$O/spline_routines.o: ${S}/spline_routines.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/spline_routines.o ${S}/spline_routines.f90
+
+$O/sort_array_coordinates.o: ${S}/sort_array_coordinates.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/sort_array_coordinates.o ${S}/sort_array_coordinates.F90
+
+$O/write_seismograms.o: ${S}/write_seismograms.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/write_seismograms.o ${S}/write_seismograms.F90
+
+##
+## use optimized compilation option for solver only
+##
+$O/check_stability.o: ${S}/check_stability.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_NO_CHECK) -c -o $O/check_stability.o ${S}/check_stability.F90
+
+$O/compute_energy.o: ${S}/compute_energy.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_energy.o ${S}/compute_energy.f90
+
+$O/compute_forces_acoustic.o: ${S}/compute_forces_acoustic.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_forces_acoustic.o ${S}/compute_forces_acoustic.f90
+
+$O/compute_forces_poro_fluid.o: ${S}/compute_forces_poro_fluid.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_forces_poro_fluid.o ${S}/compute_forces_poro_fluid.f90
+
+$O/compute_forces_poro_solid.o: ${S}/compute_forces_poro_solid.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_forces_poro_solid.o ${S}/compute_forces_poro_solid.f90
+
+$O/compute_forces_viscoelastic.o: ${S}/compute_forces_viscoelastic.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_forces_viscoelastic.o ${S}/compute_forces_viscoelastic.f90
+
+$O/compute_gradient_attenuation.o: ${S}/compute_gradient_attenuation.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_gradient_attenuation.o ${S}/compute_gradient_attenuation.f90
+
+$O/compute_normal_vector.o: ${S}/compute_normal_vector.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_NO_CHECK) -c -o $O/compute_normal_vector.o ${S}/compute_normal_vector.f90
+
+$O/enforce_acoustic_free_surface.o: ${S}/enforce_acoustic_free_surface.f90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_NO_CHECK) -c -o $O/enforce_acoustic_free_surface.o ${S}/enforce_acoustic_free_surface.f90
+
+$O/specfem2D.o: ${S}/specfem2D.F90 ${SETUP}/constants.h
+ ${F90} $(FLAGS_NO_CHECK) -c -o $O/specfem2D.o ${S}/specfem2D.F90
+
+
+##
+## shared
+##
+$O/read_value_parameters.o: ${SHARED}/read_value_parameters.f90
+ ${F90} $(FLAGS_CHECK) -c -o $O/read_value_parameters.o ${SHARED}/read_value_parameters.f90
+
+
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/assemble_MPI.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/assemble_MPI.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/assemble_MPI.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/assemble_MPI.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,563 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!
+! 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.
+!
+
+
+#ifdef USE_MPI
+
+!-----------------------------------------------
+! Assembling the mass matrix.
+!-----------------------------------------------
+ subroutine assemble_MPI_scalar(array_val1,npoin_val1, &
+ array_val2,npoin_val2, &
+ array_val3,array_val4,npoin_val3, &
+ 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
+
+ include 'constants.h'
+ include 'mpif.h'
+
+ 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, 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) :: my_neighbours
+ ! array to assemble
+ ! acoustic
+ integer :: npoin_val1
+ real(kind=CUSTOM_REAL), dimension(npoin_val1), intent(inout) :: array_val1
+ ! elastic
+ integer :: npoin_val2
+ real(kind=CUSTOM_REAL), dimension(npoin_val2), intent(inout) :: array_val2
+ ! poroelastic
+ integer :: npoin_val3
+ real(kind=CUSTOM_REAL), dimension(npoin_val3), intent(inout) :: array_val3,array_val4
+
+ integer :: ipoin, num_interface
+ integer :: ier
+ integer :: i
+ double precision, dimension(max_ibool_interfaces_size_ac+max_ibool_interfaces_size_el+&
+ 2*max_ibool_interfaces_size_po, ninterface) :: &
+ buffer_send_faces_scalar, &
+ buffer_recv_faces_scalar
+ integer, dimension(MPI_STATUS_SIZE) :: msg_status
+ integer, dimension(ninterface) :: msg_requests
+
+ buffer_send_faces_scalar(:,:) = 0.d0
+ buffer_recv_faces_scalar(:,:) = 0.d0
+
+ do num_interface = 1, ninterface
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_acoustic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val1(ibool_interfaces_acoustic(i,num_interface))
+ end do
+
+ do i = 1, nibool_interfaces_elastic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val2(ibool_interfaces_elastic(i,num_interface))
+ end do
+
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val3(ibool_interfaces_poroelastic(i,num_interface))
+ end do
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val4(ibool_interfaces_poroelastic(i,num_interface))
+ end do
+
+ ! non-blocking synchronous send request
+ 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)
+
+ end do
+
+ do num_interface = 1, ninterface
+
+ ! starts a blocking receive
+ call MPI_recv ( buffer_recv_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_status(1), ier)
+
+ 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_scalar(ipoin,num_interface)
+ end do
+
+ do i = 1, nibool_interfaces_elastic(num_interface)
+ ipoin = ipoin + 1
+ array_val2(ibool_interfaces_elastic(i,num_interface)) = &
+ array_val2(ibool_interfaces_elastic(i,num_interface)) &
+ + buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ array_val3(ibool_interfaces_poroelastic(i,num_interface)) = &
+ array_val3(ibool_interfaces_poroelastic(i,num_interface)) &
+ + buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ array_val4(ibool_interfaces_poroelastic(i,num_interface)) = &
+ array_val4(ibool_interfaces_poroelastic(i,num_interface)) &
+ + buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+
+ end do
+
+ ! synchronizes MPI processes
+ call MPI_BARRIER(mpi_comm_world,ier)
+
+ end subroutine assemble_MPI_scalar
+
+
+!-----------------------------------------------
+! Assembling potential_dot_dot for acoustic 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_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_recv_faces_vector_ac, &
+ my_neighbours )
+
+ implicit none
+
+ include 'constants.h'
+ include 'mpif.h'
+ include 'precision_mpi.h'
+
+ 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_send_faces_vector_ac
+ real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(inout) :: &
+ buffer_recv_faces_vector_ac
+ ! array to assemble
+ real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1
+ integer, dimension(ninterface), intent(in) :: my_neighbours
+
+ ! local parameters
+ integer :: ipoin, num_interface,iinterface,ier,iglob
+ integer, dimension(MPI_STATUS_SIZE) :: status_acoustic
+
+ ! initializes buffers
+ buffer_send_faces_vector_ac(:,:) = 0._CUSTOM_REAL
+ buffer_recv_faces_vector_ac(:,:) = 0._CUSTOM_REAL
+ tab_requests_send_recv_acoustic(:) = 0
+
+ ! loops over acoustic interfaces only
+ do iinterface = 1, ninterface_acoustic
+
+ ! gets interface index in the range of all interfaces [1,ninterface]
+ num_interface = inum_interfaces_acoustic(iinterface)
+
+ ! loops over all interface points
+ do ipoin = 1, nibool_interfaces_acoustic(num_interface)
+ iglob = ibool_interfaces_acoustic(ipoin,num_interface)
+
+ ! copies array values to buffer
+ buffer_send_faces_vector_ac(ipoin,iinterface) = array_val1(iglob)
+ end do
+
+ end do
+
+ do iinterface = 1, ninterface_acoustic
+
+ ! gets global interface index
+ num_interface = inum_interfaces_acoustic(iinterface)
+
+ ! non-blocking synchronous send
+ call MPI_ISSEND( buffer_send_faces_vector_ac(1,iinterface), &
+ nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_acoustic(iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_start')
+ end if
+
+ ! starts a non-blocking receive
+ call MPI_Irecv ( buffer_recv_faces_vector_ac(1,iinterface), &
+ nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_acoustic(ninterface_acoustic+iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector')
+ end if
+
+ end do
+
+
+ ! waits for MPI requests to complete (recv)
+ ! each wait returns once the specified MPI request completed
+ do iinterface = 1, ninterface_acoustic
+ call MPI_Wait (tab_requests_send_recv_acoustic(ninterface_acoustic+iinterface), &
+ status_acoustic, ier)
+ enddo
+
+ ! assembles the array values
+ do iinterface = 1, ninterface_acoustic
+
+ ! gets global interface index
+ num_interface = inum_interfaces_acoustic(iinterface)
+
+ ! loops over all interface points
+ do ipoin = 1, nibool_interfaces_acoustic(num_interface)
+ iglob = ibool_interfaces_acoustic(ipoin,num_interface)
+ ! adds buffer contribution
+ array_val1(iglob) = array_val1(iglob) + buffer_recv_faces_vector_ac(ipoin,iinterface)
+ end do
+
+ end do
+
+
+ ! waits for MPI requests to complete (send)
+ ! just to make sure that all sending is done
+ do iinterface = 1, ninterface_acoustic
+ call MPI_Wait (tab_requests_send_recv_acoustic(iinterface), status_acoustic, ier)
+ enddo
+
+
+ end subroutine assemble_MPI_vector_ac
+
+
+!-----------------------------------------------
+! 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_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_recv_faces_vector_el, &
+ my_neighbours)
+
+ implicit none
+
+ include 'constants.h'
+ include 'mpif.h'
+ include 'precision_mpi.h'
+
+ 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(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
+ ! array to assemble
+ real(kind=CUSTOM_REAL), dimension(3,npoin), intent(inout) :: array_val2
+ integer, dimension(ninterface), intent(in) :: my_neighbours
+
+ integer :: ipoin, num_interface, iinterface, ier, i
+ integer, dimension(MPI_STATUS_SIZE) :: status_elastic
+
+
+ do iinterface = 1, ninterface_elastic
+
+ num_interface = inum_interfaces_elastic(iinterface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_elastic(num_interface)
+ buffer_send_faces_vector_el(ipoin+1:ipoin+3,iinterface) = &
+ array_val2(:,ibool_interfaces_elastic(i,num_interface))
+ ipoin = ipoin + 3
+ end do
+
+ end do
+
+ do iinterface = 1, ninterface_elastic
+
+ num_interface = inum_interfaces_elastic(iinterface)
+
+ call MPI_ISSEND( buffer_send_faces_vector_el(1,iinterface), &
+ 3*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_elastic(iinterface), 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,iinterface), &
+ 3*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_elastic(ninterface_elastic+iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_el')
+ end if
+
+ end do
+
+ do iinterface = 1, ninterface_elastic*2
+
+ call MPI_Wait (tab_requests_send_recv_elastic(iinterface), status_elastic, ier)
+
+ enddo
+
+ do iinterface = 1, ninterface_elastic
+
+ num_interface = inum_interfaces_elastic(iinterface)
+
+ 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+3,iinterface)
+ ipoin = ipoin + 3
+ end do
+
+ end do
+
+ end subroutine assemble_MPI_vector_el
+
+
+!-----------------------------------------------
+! 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(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_poro, &
+ 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'
+
+ 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*4), intent(inout) :: tab_requests_send_recv_poro
+ 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
+ ! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(inout) :: array_val3,array_val4
+ integer, dimension(ninterface), intent(in) :: my_neighbours
+
+ integer :: ipoin, num_interface, iinterface, ier, i
+ integer, dimension(MPI_STATUS_SIZE) :: status_poroelastic
+
+
+ do iinterface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(iinterface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ buffer_send_faces_vector_pos(ipoin+1:ipoin+2,iinterface) = &
+ array_val3(:,ibool_interfaces_poroelastic(i,num_interface))
+ ipoin = ipoin + 2
+ end do
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ buffer_send_faces_vector_pow(ipoin+1:ipoin+2,iinterface) = &
+ array_val4(:,ibool_interfaces_poroelastic(i,num_interface))
+ ipoin = ipoin + 2
+ end do
+
+ end do
+
+ do iinterface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(iinterface)
+
+ call MPI_ISSEND( buffer_send_faces_vector_pos(1,iinterface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poro(iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pos')
+ end if
+
+ call MPI_Irecv ( buffer_recv_faces_vector_pos(1,iinterface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poro(ninterface_poroelastic+iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pos')
+ end if
+
+ call MPI_ISSEND( buffer_send_faces_vector_pow(1,iinterface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poro(ninterface_poroelastic*2+iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pow')
+ end if
+
+ call MPI_Irecv ( buffer_recv_faces_vector_pow(1,iinterface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poro(ninterface_poroelastic*3+iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pow')
+ end if
+
+ end do
+
+ do iinterface = 1, ninterface_poroelastic*4
+
+ call MPI_Wait (tab_requests_send_recv_poro(iinterface), status_poroelastic, ier)
+
+ enddo
+
+ do iinterface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(iinterface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) = &
+ array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_vector_pos(ipoin+1:ipoin+2,iinterface)
+ 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,iinterface)
+ ipoin = ipoin + 2
+ end do
+
+ end do
+
+ end subroutine assemble_MPI_vector_po
+
+#endif
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/attenuation_compute_param.c (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/attenuation_compute_param.c)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/attenuation_compute_param.c (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/attenuation_compute_param.c 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,1176 @@
+
+/* See Liu, Anderson & Kanamori (Geophysical Journal of the Royal Astronomical Society, vol. 47, p. 41-58, 1976) for details */
+
+/* cleaned by Dimitri Komatitsch, University of Pau, France, July 2007 */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <stdio.h>
+#include <math.h>
+#include <sgtty.h>
+#include <signal.h>
+#include <stdlib.h>
+
+/* useful constants */
+
+#define PI 3.14159265358979
+#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".
+*/
+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;
+ double Q_s, target_Qp, target_Qs;
+ double f1, f2, Q, om0, Omega;
+ double a, b;
+ double kappa, mu, kappa0, mu0, kappaR, muR;
+ double *tau_s, *tau_e;
+ double *dvector();
+ void constant_Q2_sub(),plot_modulus();
+ void free_dvector();
+
+
+ /* We get the arguments passed in fortran by adress. */
+ target_Qp = *Qp_in; /* target value of Qp */
+ target_Qs = *Qs_in; /* target value of Qs */
+ n = *nmech_in; /* number of mechanisms */
+ f1 = *f1_in; /* shortest frequency (Hz) */
+ f2 = *f2_in; /* highest frequency (Hz) */
+
+ /*
+ printf("target value of Qp: ");
+ scanf("%lf",&target_Qp);
+ printf("%lf\n",target_Qp);
+
+ printf("target value of Qs: ");
+ scanf("%lf",&target_Qs);
+ printf("%lf\n",target_Qs);
+
+ printf("shortest frequency (Hz): ");
+ scanf("%lf",&f1);
+ printf("%lf\n",f1);
+
+ printf("highest frequency (Hz): ");
+ scanf("%lf",&f2);
+ printf("%lf\n",f2);
+
+ printf("number of mechanisms: ");
+ scanf("%d",&n);
+ printf("%d\n",n);
+ */
+
+/* DK DK printf("1 = use xmgr 0 = do not use xmgr: "); */
+/* scanf("%d",&xmgr); */
+ xmgr = 0;
+
+ if (f2 < f1) {
+ printf("T2 > T1\n");
+ exit; }
+
+ if (target_Qp <= 0.0001) {
+ printf("Qp cannot be negative or null\n");
+ exit; }
+
+ if (target_Qs <= 0.0001) {
+ printf("Qs cannot be negative or null\n");
+ exit; }
+
+ if (n < 1) {
+ printf("n < 1\n");
+ exit; }
+
+ om0 = PI2 * pow(10.0, 0.5 * (log10(f1) + log10(f2)));
+
+ /*
+ printf("\n! put this in file constants.h\n\n");
+
+ printf("! number of standard linear solids for attenuation\n");
+ printf(" integer, parameter :: N_SLS = %d\n\n",n);
+
+ printf("! put this in file attenuation_model.f90\n\n");
+
+ printf("! frequency range: %lf Hz - %lf Hz\n", f1 , f2);
+ printf("! central frequency in log scale in Hz = %20.15f\n",om0 / PI2);
+
+ printf("! target constant attenuation factor Qp = %20.10lf\n", target_Qp);
+ printf("! target constant attenuation factor Qs = %20.10lf\n\n", target_Qs);
+
+ printf("! tau_sigma evenly spaced in log frequency, do not depend on value of Q\n\n");
+ */
+
+ plot = 0;
+
+/* loop on the Qp dilatation mode (nu = 1) and Qs shear mode (nu = 2) */
+ for (nu = 1; nu <= 2; nu++) {
+
+/* assign Qp or Qs to generic variable Q_s which is used for the calculations */
+ if (nu == 1) { Q_s = target_Qp ; }
+ if (nu == 2) { Q_s = target_Qs ; }
+
+ tau_s = dvector(1, n);
+ tau_e = dvector(1, n);
+
+ constant_Q2_sub(f1, f2, n, Q_s, tau_s, tau_e, xmgr);
+
+/* 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];
+ }
+ if ( nu == 2 ) {
+ 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]);
+ */
+ /* We put the results in tau_epsilon_nu to get them in fortran. */
+ if ( nu == 1 ) {
+ tau_epsilon_nu1[i-1] = tau_e[i];
+ }
+ if ( nu == 2 ) {
+ tau_epsilon_nu2[i-1] = tau_e[i];
+ }
+
+ }
+ //printf("\n");
+
+ free_dvector(tau_s, 1, n);
+ free_dvector(tau_e, 1, n);
+
+ }
+
+}
+
+void plot_modulus(f1, f2, n, m, mR, Q, tau_e, tau_s ,xmgr)
+ int n, xmgr;
+ double f1, f2, m, mR, Q, *tau_e, *tau_s;
+{
+int pid, i;
+double exp1, exp2, dexp, expo;
+double f, om, Omega;
+double a, b, m_om, m_prem;
+char strng[180];
+int getpid(), system();
+FILE *fp_v, *fp_q;
+
+pid = getpid();
+sprintf(strng, "modulus%1d", pid);
+if((fp_v=fopen(strng,"w"))==NULL) {
+ puts("cannot open file\n");
+ exit;
+}
+sprintf(strng, "Q%1d", pid);
+if((fp_q=fopen(strng,"w"))==NULL) {
+ puts("cannot open file\n");
+ exit;
+}
+
+exp1 = log10(f1) - 2.0;
+exp2 = log10(f2) + 2.0;
+dexp = (exp2 - exp1) / 100.0;
+for (expo = exp1; expo <= exp2; expo += dexp) {
+ f = pow(10.0, expo);
+ om = PI2 * f;
+ a = 1.0;
+ b = 0.0;
+ for (i = 1; i <= n; i++) {
+ a -= om * om * tau_e[i] * (tau_e[i] - tau_s[i]) /
+ (1.0 + om * om * tau_e[i] * tau_e[i]);
+ b += om * (tau_e[i] - tau_s[i]) /
+ (1.0 + om * om * tau_e[i] * tau_e[i]);
+ }
+ Omega=a*(sqrt(1.0+b*b/(a*a))-1.0);
+ m_om = 2.0*mR* Omega/(b*b);
+ m_prem = m * (1.0 + (2.0 / (PI * Q)) * log(om / PI2));
+ fprintf(fp_v, "%f %f %f\n", expo, m_om/m, m_prem/m);
+ if (om >= PI2 * f1 && om <= PI2 * f2) {
+ fprintf(fp_q, "%f %f %f\n", expo, 1.0/atan(b/a), Q);
+ }
+}
+fclose(fp_v);
+fclose(fp_q);
+
+/* DK DK call xmgr to plot curves if needed */
+
+if (xmgr == 1) {
+ sprintf(strng, "xmgr -nxy Q%1d", pid);
+ system(strng);
+ sprintf(strng, "xmgr -nxy modulus%1d", pid);
+ system(strng);
+ sprintf(strng, "rm modulus%1d", pid);
+ system(strng);
+ sprintf(strng, "rm Q%1d", pid);
+ system(strng);
+}
+
+}
+
+#include <malloc.h>
+#include <stdio.h>
+
+void nrerror(error_text)
+char error_text[];
+{
+ void exit();
+
+ fprintf(stderr,"Numerical Recipes run-time error...\n");
+ fprintf(stderr,"%s\n",error_text);
+ fprintf(stderr,"...now exiting to system...\n");
+ exit(1);
+}
+
+float *vector(nl,nh)
+int nl,nh;
+{
+ float *v;
+
+ v=(float *)malloc((unsigned) (nh-nl+1)*sizeof(float));
+ if (!v) nrerror("allocation failure in vector()");
+ return v-nl;
+}
+
+int *ivector(nl,nh)
+int nl,nh;
+{
+ int *v;
+
+ v=(int *)malloc((unsigned) (nh-nl+1)*sizeof(int));
+ if (!v) nrerror("allocation failure in ivector()");
+ return v-nl;
+}
+
+double *dvector(nl,nh)
+int nl,nh;
+{
+ double *v;
+
+ v=(double *)malloc((unsigned) (nh-nl+1)*sizeof(double));
+ if (!v) nrerror("allocation failure in dvector()");
+ return v-nl;
+}
+
+
+
+float **matrix(nrl,nrh,ncl,nch)
+int nrl,nrh,ncl,nch;
+{
+ int i;
+ float **m;
+
+ m=(float **) malloc((unsigned) (nrh-nrl+1)*sizeof(float*));
+ if (!m) nrerror("allocation failure 1 in matrix()");
+ m -= nrl;
+
+ for(i=nrl;i<=nrh;i++) {
+ m[i]=(float *) malloc((unsigned) (nch-ncl+1)*sizeof(float));
+ if (!m[i]) nrerror("allocation failure 2 in matrix()");
+ m[i] -= ncl;
+ }
+ return m;
+}
+
+double **dmatrix(nrl,nrh,ncl,nch)
+int nrl,nrh,ncl,nch;
+{
+ int i;
+ double **m;
+
+ m=(double **) malloc((unsigned) (nrh-nrl+1)*sizeof(double*));
+ if (!m) nrerror("allocation failure 1 in dmatrix()");
+ m -= nrl;
+
+ for(i=nrl;i<=nrh;i++) {
+ m[i]=(double *) malloc((unsigned) (nch-ncl+1)*sizeof(double));
+ if (!m[i]) nrerror("allocation failure 2 in dmatrix()");
+ m[i] -= ncl;
+ }
+ return m;
+}
+
+int **imatrix(nrl,nrh,ncl,nch)
+int nrl,nrh,ncl,nch;
+{
+ int i,**m;
+
+ m=(int **)malloc((unsigned) (nrh-nrl+1)*sizeof(int*));
+ if (!m) nrerror("allocation failure 1 in imatrix()");
+ m -= nrl;
+
+ for(i=nrl;i<=nrh;i++) {
+ m[i]=(int *)malloc((unsigned) (nch-ncl+1)*sizeof(int));
+ if (!m[i]) nrerror("allocation failure 2 in imatrix()");
+ m[i] -= ncl;
+ }
+ return m;
+}
+
+
+
+float **submatrix(a,oldrl,oldrh,oldcl,oldch,newrl,newcl)
+float **a;
+int oldrl,oldrh,oldcl,oldch,newrl,newcl;
+{
+ int i,j;
+ float **m;
+
+ m=(float **) malloc((unsigned) (oldrh-oldrl+1)*sizeof(float*));
+ if (!m) nrerror("allocation failure in submatrix()");
+ m -= newrl;
+
+ for(i=oldrl,j=newrl;i<=oldrh;i++,j++) m[j]=a[i]+oldcl-newcl;
+
+ return m;
+}
+
+
+
+void free_vector(v,nl,nh)
+float *v;
+int nl,nh;
+{
+ free((char*) (v+nl));
+}
+
+void free_ivector(v,nl,nh)
+int *v,nl,nh;
+{
+ free((char*) (v+nl));
+}
+
+void free_dvector(v,nl,nh)
+double *v;
+int nl,nh;
+{
+ free((char*) (v+nl));
+}
+
+
+
+void free_matrix(m,nrl,nrh,ncl,nch)
+float **m;
+int nrl,nrh,ncl,nch;
+{
+ int i;
+
+ for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
+ free((char*) (m+nrl));
+}
+
+void free_dmatrix(m,nrl,nrh,ncl,nch)
+double **m;
+int nrl,nrh,ncl,nch;
+{
+ int i;
+
+ for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
+ free((char*) (m+nrl));
+}
+
+void free_imatrix(m,nrl,nrh,ncl,nch)
+int **m;
+int nrl,nrh,ncl,nch;
+{
+ int i;
+
+ for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
+ free((char*) (m+nrl));
+}
+
+
+
+void free_submatrix(b,nrl,nrh,ncl,nch)
+float **b;
+int nrl,nrh,ncl,nch;
+{
+ free((char*) (b+nrl));
+}
+
+
+
+float **convert_matrix(a,nrl,nrh,ncl,nch)
+float *a;
+int nrl,nrh,ncl,nch;
+{
+ int i,j,nrow,ncol;
+ float **m;
+
+ nrow=nrh-nrl+1;
+ ncol=nch-ncl+1;
+ m = (float **) malloc((unsigned) (nrow)*sizeof(float*));
+ if (!m) nrerror("allocation failure in convert_matrix()");
+ m -= nrl;
+ for(i=0,j=nrl;i<=nrow-1;i++,j++) m[j]=a+ncol*i-ncl;
+ return m;
+}
+
+
+
+void free_convert_matrix(b,nrl,nrh,ncl,nch)
+float **b;
+int nrl,nrh,ncl,nch;
+{
+ free((char*) (b+nrl));
+}
+
+#include <math.h>
+
+#define NMAX 5000
+#define ALPHA 1.0
+#define BETA 0.5
+#define GAMMA 2.0
+
+#define GET_PSUM for (j=1;j<=ndim;j++) { for (i=1,sum=0.0;i<=mpts;i++)\
+ sum += p[i][j]; psum[j]=sum;}
+
+void amoeba(p,y,ndim,ftol,funk,nfunk)
+float **p,y[],ftol,(*funk)();
+int ndim,*nfunk;
+{
+ int i,j,ilo,ihi,inhi,mpts=ndim+1;
+ float ytry,ysave,sum,rtol,amotry(),*psum,*vector();
+ void nrerror(),free_vector();
+
+ psum=vector(1,ndim);
+ *nfunk=0;
+ GET_PSUM
+ for (;;) {
+ ilo=1;
+ ihi = y[1]>y[2] ? (inhi=2,1) : (inhi=1,2);
+ for (i=1;i<=mpts;i++) {
+ if (y[i] < y[ilo]) ilo=i;
+ if (y[i] > y[ihi]) {
+ inhi=ihi;
+ ihi=i;
+ } else if (y[i] > y[inhi])
+ if (i != ihi) inhi=i;
+ }
+ rtol=2.0*fabs(y[ihi]-y[ilo])/(fabs(y[ihi])+fabs(y[ilo]));
+ if (rtol < ftol) break;
+ if (*nfunk >= NMAX) nrerror("Too many iterations in AMOEBA");
+ ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,-ALPHA);
+ if (ytry <= y[ilo])
+ ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,GAMMA);
+ else if (ytry >= y[inhi]) {
+ ysave=y[ihi];
+ ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,BETA);
+ if (ytry >= ysave) {
+ for (i=1;i<=mpts;i++) {
+ if (i != ilo) {
+ for (j=1;j<=ndim;j++) {
+ psum[j]=0.5*(p[i][j]+p[ilo][j]);
+ p[i][j]=psum[j];
+ }
+ y[i]=(*funk)(psum);
+ }
+ }
+ *nfunk += ndim;
+ GET_PSUM
+ }
+ }
+ }
+ free_vector(psum,1,ndim);
+}
+
+float amotry(p,y,psum,ndim,funk,ihi,nfunk,fac)
+float **p,*y,*psum,(*funk)(),fac;
+int ndim,ihi,*nfunk;
+{
+ int j;
+ float fac1,fac2,ytry,*ptry,*vector();
+ void nrerror(),free_vector();
+
+ ptry=vector(1,ndim);
+ fac1=(1.0-fac)/ndim;
+ fac2=fac1-fac;
+ for (j=1;j<=ndim;j++) ptry[j]=psum[j]*fac1-p[ihi][j]*fac2;
+ ytry=(*funk)(ptry);
+ ++(*nfunk);
+ if (ytry < y[ihi]) {
+ y[ihi]=ytry;
+ for (j=1;j<=ndim;j++) {
+ psum[j] += ptry[j]-p[ihi][j];
+ p[ihi][j]=ptry[j];
+ }
+ }
+ free_vector(ptry,1,ndim);
+ return ytry;
+}
+
+#undef ALPHA
+#undef BETA
+#undef GAMMA
+#undef NMAX
+
+void spline(x,y,n,yp1,ypn,y2)
+float x[],y[],yp1,ypn,y2[];
+int n;
+{
+ int i,k;
+ float p,qn,sig,un,*u,*vector();
+ void free_vector();
+
+ u=vector(1,n-1);
+ if (yp1 > 0.99e30)
+ y2[1]=u[1]=0.0;
+ else {
+ y2[1] = -0.5;
+ u[1]=(3.0/(x[2]-x[1]))*((y[2]-y[1])/(x[2]-x[1])-yp1);
+ }
+ for (i=2;i<=n-1;i++) {
+ sig=(x[i]-x[i-1])/(x[i+1]-x[i-1]);
+ p=sig*y2[i-1]+2.0;
+ y2[i]=(sig-1.0)/p;
+ u[i]=(y[i+1]-y[i])/(x[i+1]-x[i]) - (y[i]-y[i-1])/(x[i]-x[i-1]);
+ u[i]=(6.0*u[i]/(x[i+1]-x[i-1])-sig*u[i-1])/p;
+ }
+ if (ypn > 0.99e30)
+ qn=un=0.0;
+ else {
+ qn=0.5;
+ un=(3.0/(x[n]-x[n-1]))*(ypn-(y[n]-y[n-1])/(x[n]-x[n-1]));
+ }
+ y2[n]=(un-qn*u[n-1])/(qn*y2[n-1]+1.0);
+ for (k=n-1;k>=1;k--)
+ y2[k]=y2[k]*y2[k+1]+u[k];
+ free_vector(u,1,n-1);
+}
+
+void splint(xa,ya,y2a,n,x,y)
+float xa[],ya[],y2a[],x,*y;
+int n;
+{
+ int klo,khi,k;
+ float h,b,a;
+ void nrerror();
+
+ klo=1;
+ khi=n;
+ while (khi-klo > 1) {
+ k=(khi+klo) >> 1;
+ if (xa[k] > x) khi=k;
+ else klo=k;
+ }
+ h=xa[khi]-xa[klo];
+ if (h == 0.0) nrerror("Bad XA input to routine SPLINT");
+ a=(xa[khi]-x)/h;
+ b=(x-xa[klo])/h;
+ *y=a*ya[klo]+b*ya[khi]+((a*a*a-a)*y2a[klo]+(b*b*b-b)*y2a[khi])*(h*h)/6.0;
+}
+
+#define FUNC(x) ((*func)(x))
+
+float trapzd(func,a,b,n)
+float a,b;
+float (*func)(); /* ANSI: float (*func)(float); */
+int n;
+{
+ float x,tnm,sum,del;
+ static float s;
+ static int it;
+ int j;
+
+ if (n == 1) {
+ it=1;
+ return (s=0.5*(b-a)*(FUNC(a)+FUNC(b)));
+ } else {
+ tnm=it;
+ del=(b-a)/tnm;
+ x=a+0.5*del;
+ for (sum=0.0,j=1;j<=it;j++,x+=del) sum += FUNC(x);
+ it *= 2;
+ s=0.5*(s+(b-a)*sum/tnm);
+ return s;
+ }
+}
+
+#include <math.h>
+
+#define EPS 0.5e-5
+#define JMAX 20
+#define JMAXP JMAX+1
+#define K 5
+
+float qromb(func,a,b)
+float a,b;
+float (*func)();
+{
+ float ss,dss,trapzd();
+ float s[JMAXP+1],h[JMAXP+1];
+ int j;
+ void polint(),nrerror();
+
+ h[1]=1.0;
+ for (j=1;j<=JMAX;j++) {
+ s[j]=trapzd(func,a,b,j);
+ if (j >= K) {
+ polint(&h[j-K],&s[j-K],K,0.0,&ss,&dss);
+ if (fabs(dss) < EPS*fabs(ss)) return ss;
+ }
+ s[j+1]=s[j];
+ h[j+1]=0.25*h[j];
+ }
+ nrerror("Too many steps in routine QROMB");
+}
+
+#undef EPS
+#undef JMAX
+#undef JMAXP
+#undef K
+
+#include <math.h>
+
+void polint(xa,ya,n,x,y,dy)
+float xa[],ya[],x,*y,*dy;
+int n;
+{
+ int i,m,ns=1;
+ float den,dif,dift,ho,hp,w;
+ float *c,*d,*vector();
+ void nrerror(),free_vector();
+
+ dif=fabs(x-xa[1]);
+ c=vector(1,n);
+ d=vector(1,n);
+ for (i=1;i<=n;i++) {
+ if ( (dift=fabs(x-xa[i])) < dif) {
+ ns=i;
+ dif=dift;
+ }
+ c[i]=ya[i];
+ d[i]=ya[i];
+ }
+ *y=ya[ns--];
+ for (m=1;m<n;m++) {
+ for (i=1;i<=n-m;i++) {
+ ho=xa[i]-x;
+ hp=xa[i+m]-x;
+ w=c[i+1]-d[i];
+ if ( (den=ho-hp) == 0.0) nrerror("Error in routine POLINT");
+ den=w/den;
+ d[i]=hp*den;
+ c[i]=ho*den;
+ }
+ *y += (*dy=(2*ns < (n-m) ? c[ns+1] : d[ns--]));
+ }
+ free_vector(d,1,n);
+ free_vector(c,1,n);
+}
+
+#define MBIG 1000000000
+#define MSEED 161803398
+#define MZ 0
+#define FAC (1.0/MBIG)
+
+float ran3(idum)
+int *idum;
+{
+ static int inext,inextp;
+ static long ma[56];
+ static int iff=0;
+ long mj,mk;
+ int i,ii,k;
+
+ if (*idum < 0 || iff == 0) {
+ iff=1;
+ mj=MSEED-(*idum < 0 ? -*idum : *idum);
+ mj %= MBIG;
+ ma[55]=mj;
+ mk=1;
+ for (i=1;i<=54;i++) {
+ ii=(21*i) % 55;
+ ma[ii]=mk;
+ mk=mj-mk;
+ if (mk < MZ) mk += MBIG;
+ mj=ma[ii];
+ }
+ for (k=1;k<=4;k++)
+ for (i=1;i<=55;i++) {
+ ma[i] -= ma[1+(i+30) % 55];
+ if (ma[i] < MZ) ma[i] += MBIG;
+ }
+ inext=0;
+ inextp=31;
+ *idum=1;
+ }
+ if (++inext == 56) inext=1;
+ if (++inextp == 56) inextp=1;
+ mj=ma[inext]-ma[inextp];
+ if (mj < MZ) mj += MBIG;
+ ma[inext]=mj;
+ return mj*FAC;
+}
+
+#undef MBIG
+#undef MSEED
+#undef MZ
+#undef FAC
+
+#include <math.h>
+
+static double at,bt,ct;
+#define PYTHAG(a,b) ((at=fabs(a)) > (bt=fabs(b)) ? \
+(ct=bt/at,at*sqrt(1.0+ct*ct)) : (bt ? (ct=at/bt,bt*sqrt(1.0+ct*ct)): 0.0))
+
+static double maxarg1,maxarg2;
+#define MAX(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1) > (maxarg2) ?\
+ (maxarg1) : (maxarg2))
+#define SIGN(a,b) ((b) >= 0.0 ? fabs(a) : -fabs(a))
+
+void dsvdcmp(a,m,n,w,v)
+double **a,*w,**v;
+int m,n;
+{
+ int flag,i,its,j,jj,k,l,nm;
+ double c,f,h,s,x,y,z;
+ double anorm=0.0,g=0.0,scale=0.0;
+ double *rv1,*dvector();
+ void nrerror(),free_dvector();
+
+ if (m < n) nrerror("SVDCMP: You must augment A with extra zero rows");
+ rv1=dvector(1,n);
+ for (i=1;i<=n;i++) {
+ l=i+1;
+ rv1[i]=scale*g;
+ g=s=scale=0.0;
+ if (i <= m) {
+ for (k=i;k<=m;k++) scale += fabs(a[k][i]);
+ if (scale) {
+ for (k=i;k<=m;k++) {
+ a[k][i] /= scale;
+ s += a[k][i]*a[k][i];
+ }
+ f=a[i][i];
+ g = -SIGN(sqrt(s),f);
+ h=f*g-s;
+ a[i][i]=f-g;
+ if (i != n) {
+ for (j=l;j<=n;j++) {
+ for (s=0.0,k=i;k<=m;k++) s += a[k][i]*a[k][j];
+ f=s/h;
+ for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
+ }
+ }
+ for (k=i;k<=m;k++) a[k][i] *= scale;
+ }
+ }
+ w[i]=scale*g;
+ g=s=scale=0.0;
+ if (i <= m && i != n) {
+ for (k=l;k<=n;k++) scale += fabs(a[i][k]);
+ if (scale) {
+ for (k=l;k<=n;k++) {
+ a[i][k] /= scale;
+ s += a[i][k]*a[i][k];
+ }
+ f=a[i][l];
+ g = -SIGN(sqrt(s),f);
+ h=f*g-s;
+ a[i][l]=f-g;
+ for (k=l;k<=n;k++) rv1[k]=a[i][k]/h;
+ if (i != m) {
+ for (j=l;j<=m;j++) {
+ for (s=0.0,k=l;k<=n;k++) s += a[j][k]*a[i][k];
+ for (k=l;k<=n;k++) a[j][k] += s*rv1[k];
+ }
+ }
+ for (k=l;k<=n;k++) a[i][k] *= scale;
+ }
+ }
+ anorm=MAX(anorm,(fabs(w[i])+fabs(rv1[i])));
+ }
+ for (i=n;i>=1;i--) {
+ if (i < n) {
+ if (g) {
+ for (j=l;j<=n;j++)
+ v[j][i]=(a[i][j]/a[i][l])/g;
+ for (j=l;j<=n;j++) {
+ for (s=0.0,k=l;k<=n;k++) s += a[i][k]*v[k][j];
+ for (k=l;k<=n;k++) v[k][j] += s*v[k][i];
+ }
+ }
+ for (j=l;j<=n;j++) v[i][j]=v[j][i]=0.0;
+ }
+ v[i][i]=1.0;
+ g=rv1[i];
+ l=i;
+ }
+ for (i=n;i>=1;i--) {
+ l=i+1;
+ g=w[i];
+ if (i < n)
+ for (j=l;j<=n;j++) a[i][j]=0.0;
+ if (g) {
+ g=1.0/g;
+ if (i != n) {
+ for (j=l;j<=n;j++) {
+ for (s=0.0,k=l;k<=m;k++) s += a[k][i]*a[k][j];
+ f=(s/a[i][i])*g;
+ for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
+ }
+ }
+ for (j=i;j<=m;j++) a[j][i] *= g;
+ } else {
+ for (j=i;j<=m;j++) a[j][i]=0.0;
+ }
+ ++a[i][i];
+ }
+ for (k=n;k>=1;k--) {
+ for (its=1;its<=30;its++) {
+ flag=1;
+ for (l=k;l>=1;l--) {
+ nm=l-1;
+ if (fabs(rv1[l])+anorm == anorm) {
+ flag=0;
+ break;
+ }
+ if (fabs(w[nm])+anorm == anorm) break;
+ }
+ if (flag) {
+ c=0.0;
+ s=1.0;
+ for (i=l;i<=k;i++) {
+ f=s*rv1[i];
+ if (fabs(f)+anorm != anorm) {
+ g=w[i];
+ h=PYTHAG(f,g);
+ w[i]=h;
+ h=1.0/h;
+ c=g*h;
+ s=(-f*h);
+ for (j=1;j<=m;j++) {
+ y=a[j][nm];
+ z=a[j][i];
+ a[j][nm]=y*c+z*s;
+ a[j][i]=z*c-y*s;
+ }
+ }
+ }
+ }
+ z=w[k];
+ if (l == k) {
+ if (z < 0.0) {
+ w[k] = -z;
+ for (j=1;j<=n;j++) v[j][k]=(-v[j][k]);
+ }
+ break;
+ }
+ if (its == 60) nrerror("No convergence in 60 SVDCMP iterations");
+ x=w[l];
+ nm=k-1;
+ y=w[nm];
+ g=rv1[nm];
+ h=rv1[k];
+ f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y);
+ g=PYTHAG(f,1.0);
+ f=((x-z)*(x+z)+h*((y/(f+SIGN(g,f)))-h))/x;
+ c=s=1.0;
+ for (j=l;j<=nm;j++) {
+ i=j+1;
+ g=rv1[i];
+ y=w[i];
+ h=s*g;
+ g=c*g;
+ z=PYTHAG(f,h);
+ rv1[j]=z;
+ c=f/z;
+ s=h/z;
+ f=x*c+g*s;
+ g=g*c-x*s;
+ h=y*s;
+ y=y*c;
+ for (jj=1;jj<=n;jj++) {
+ x=v[jj][j];
+ z=v[jj][i];
+ v[jj][j]=x*c+z*s;
+ v[jj][i]=z*c-x*s;
+ }
+ z=PYTHAG(f,h);
+ w[j]=z;
+ if (z) {
+ z=1.0/z;
+ c=f*z;
+ s=h*z;
+ }
+ f=(c*g)+(s*y);
+ x=(c*y)-(s*g);
+ for (jj=1;jj<=m;jj++) {
+ y=a[jj][j];
+ z=a[jj][i];
+ a[jj][j]=y*c+z*s;
+ a[jj][i]=z*c-y*s;
+ }
+ }
+ rv1[l]=0.0;
+ rv1[k]=f;
+ w[k]=x;
+ }
+ }
+ free_dvector(rv1,1,n);
+}
+
+#undef SIGN
+#undef MAX
+#undef PYTHAG
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <stdio.h>
+#include <math.h>
+#include <sgtty.h>
+#include <signal.h>
+#include <stdlib.h>
+
+/* useful constants */
+
+#define PI 3.14159265358979
+#define PI2 6.28318530717958
+
+void constant_Q2_sub(f1, f2, n, Q, tau_s, tau_e, xmgr)
+
+ int n, xmgr;
+ double f1, f2, Q;
+ double *tau_s, *tau_e;
+{
+ int i,j;
+ double *x1, *x2;
+ double *gradient, **hessian;
+ double *dvector(), **dmatrix();
+ void derivatives();
+ void initialize(), invert();
+ void free_dvector(), free_dmatrix();
+
+ if (f2 < f1) {
+ printf("T2 > T1\n");
+ exit;
+ }
+ if (Q < 0.0) {
+ printf("Q < 0\n");
+ exit;
+ }
+ if (n < 1) {
+ printf("n < 1\n");
+ exit;
+ }
+
+ x1 = dvector(1, n);
+ x2 = dvector(1, n);
+ gradient = dvector(1, n);
+ hessian = dmatrix(1, n, 1, n);
+ for(i=1;i<=n;i++) {
+ x1[i]=0.0;
+ x2[i]=0.0;
+ gradient[i]=0.0;
+ for(j=1;j<=n;j++) hessian[i][j]=0.0;
+ }
+
+ initialize(f1, f2, n, Q, x1, x2);
+
+ derivatives(f1, f2, n, Q, x1, x2, gradient, hessian);
+
+ invert(x1, gradient, hessian, n);
+
+ free_dvector(gradient, 1, n);
+ free_dmatrix(hessian, 1, n, 1, n);
+
+ for (i = 1; i <= n; i++) {
+ tau_e[i]=x1[i] + x2[i];
+ }
+ for (i = 1; i <= n; i++) {
+ tau_s[i]=x2[i];
+ }
+
+ free_dvector(x1, 1, n);
+ free_dvector(x2, 1, n);
+
+}
+
+void initialize(f1, f2, n, Q, x1, x2)
+ int n;
+ double f1, f2, Q, *x1, *x2;
+{
+int i;
+double q, omega, *tau_e, *tau_s;
+double exp1, exp2, dexp, expo;
+double *dvector();
+void free_dvector();
+
+tau_e = dvector(1, n);
+tau_s = dvector(1, n);
+if (n > 1) {
+ exp1 = log10(f1);
+ exp2 = log10(f2);
+ dexp = (exp2 - exp1) / ((double) (n - 1));
+ q = 1.0 / ((n - 1.0) * Q);
+ for (i = 1, expo = exp1; i <= n; i++, expo += dexp) {
+ omega = PI2 * pow(10.0, expo);
+ tau_s[i] = 1.0 / omega;
+ tau_e[i] = tau_s[i] * (1.0 + q) / (1.0 - q);
+ }
+} else {
+ q = 1.0 / Q;
+ exp1 = log10(f1);
+ exp2 = log10(f2);
+ expo=(exp1+exp2)/2.0;
+ omega = PI2 * pow(10.0, expo);
+ tau_s[1] = 1.0 / omega;
+ tau_e[1] = tau_s[1] * (1.0 + q) / (1.0 - q);
+}
+/*
+ * x1 denotes the parameter tau_e - tau_s and x2 denotes the parameter tau_s
+ */
+for (i = 1; i <= n; i++) {
+ x1[i] = tau_e[i] - tau_s[i];
+ x2[i] = tau_s[i];
+}
+
+free_dvector(tau_e, 1, n);
+free_dvector(tau_s, 1, n);
+}
+
+double penalty(f1, f2, n, Q, x1, x2)
+ int n;
+ double f1, f2, Q, *x1, *x2;
+{
+int i;
+double exp1, exp2, dexp, expo;
+double pnlt;
+double f, df, omega;
+double tau_e, tau_s, a, b, Q_omega;
+
+exp1 = log10(f1);
+exp2 = log10(f2);
+dexp = (exp2 - exp1) / 100.0;
+pnlt = 0.0;
+for (expo = exp1; expo <= exp2; expo += dexp) {
+ f = pow(10.0, expo);
+ df = pow(10.0, expo + dexp) - f;
+ omega = PI2 * f;
+ a = (double) (1 - n);
+ b = 0.0;
+ for (i = 1; i <= n; i++) {
+ tau_e = x1[i] + x2[i];
+ tau_s = x2[i];
+ a += (1.0 + omega * omega * tau_e * tau_s) /
+ (1.0 + omega * omega * tau_s * tau_s);
+ b += omega * (tau_e - tau_s) /
+ (1.0 + omega * omega * tau_s * tau_s);
+ }
+ Q_omega = a / b;
+ pnlt += pow(1.0 / Q - 1.0 / Q_omega, 2.0) * df;
+}
+pnlt /= (f2 - f1);
+return pnlt;
+}
+
+
+void derivatives(f1, f2, n, Q, x1, x2, gradient, hessian)
+ int n;
+ double f1, f2, Q, *x1, *x2;
+ double *gradient, **hessian;
+{
+int i, j;
+double exp1, exp2, dexp, expo;
+double f, df, omega;
+double *dadp, *dbdp, *dqdp, d2qdp2;
+double tau_e, tau_s, a, b, Q_omega;
+double *dvector();
+void free_dvector();
+
+dadp = dvector(1, n);
+dbdp = dvector(1, n);
+dqdp = dvector(1, n);
+exp1 = log10(f1);
+exp2 = log10(f2);
+dexp = (exp2 - exp1) / 100.0;
+for (i = 1; i <= n; i++) {
+ gradient[i] = 0.0;
+ for (j = 1; j <= i; j++) {
+ hessian[j][i] = 0.0;
+ hessian[j][i] = hessian[i][j];
+ }
+}
+for (expo = exp1; expo <= exp2; expo += dexp) {
+ f = pow(10.0, expo);
+ df = pow(10.0, expo + dexp) - f;
+ omega = PI2 * f;
+ a = (double) (1 - n);
+ b = 0.0;
+ for (i = 1; i <= n; i++) {
+ tau_e = x1[i] + x2[i];
+ tau_s = x2[i];
+ a += (1.0 + omega * omega * tau_e * tau_s) /
+ (1.0 + omega * omega * tau_s * tau_s);
+ b += omega * (tau_e - tau_s) /
+ (1.0 + omega * omega * tau_s * tau_s);
+ dadp[i] = omega * omega * tau_s / (1.0 + omega * omega * tau_s * tau_s);
+ dbdp[i] = omega / (1.0 + omega * omega * tau_s * tau_s);
+ }
+ Q_omega = a / b;
+ for (i = 1; i <= n; i++) {
+ dqdp[i] = (dbdp[i] - (b / a) * dadp[i]) / a;
+ gradient[i] += 2.0 * (1.0 / Q_omega - 1.0 / Q) * dqdp[i] * df / (f2 - f1);
+ for (j = 1; j <= i; j++) {
+ d2qdp2 = -(dadp[i] * dbdp[j] + dbdp[i] * dadp[j]
+ - 2.0 * (b / a) * dadp[i] * dadp[j]) / (a * a);
+ hessian[i][j] += (2.0 * dqdp[i] * dqdp[j] + 2.0 * (1.0 / Q_omega - 1.0 / Q) * d2qdp2)
+ * df / (f2 - f1);
+ hessian[j][i] = hessian[i][j];
+ }
+ }
+}
+free_dvector(dadp, 1, n);
+free_dvector(dbdp, 1, n);
+free_dvector(dqdp, 1, n);
+}
+
+void invert(x, b, A, n)
+ int n;
+ double *x;
+ double *b, **A;
+{
+int i, j, k;
+double *dvector(), **dmatrix();
+double *xp, *W, **V, **A_inverse;
+void free_dvector(), free_dmatrix(), dsvdcmp();
+
+xp = dvector(1, n);
+W = dvector(1, n);
+V = dmatrix(1, n, 1, n);
+A_inverse = dmatrix(1, n, 1, n);
+dsvdcmp(A, n, n, W, V);
+for (i = 1; i <= n; i++)
+ for (j = 1; j <= n; j++)
+ V[i][j] = (1.0 / W[i]) * A[j][i];
+for (i = 1; i <= n; i++) {
+ for (j = 1; j <= n; j++) {
+ A_inverse[i][j] = 0.0;
+ for (k = 1; k <= n; k++)
+ A_inverse[i][j] += A[i][k] * V[k][j];
+ }
+}
+free_dvector(W, 1, n);
+free_dmatrix(V, 1, n, 1, n);
+for (i = 1; i <= n; i++) {
+ xp[i] = x[i];
+ for (j = 1; j <= n; j++) {
+ xp[i] -= A_inverse[i][j] * b[j];
+ }
+ x[i] = xp[i];
+}
+free_dvector(xp, 1, n);
+free_dmatrix(A_inverse, 1, n, 1, n);
+}
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/attenuation_model.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/attenuation_model.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/attenuation_model.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/attenuation_model.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,153 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine 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 constants
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: N_SLS
+ double precision :: Qp_attenuation,Qs_attenuation,f0_attenuation
+ double precision, dimension(N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
+ double precision :: Mu_nu1,Mu_nu2
+
+ integer :: i_sls
+
+ double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,tau_epsilon_nu2,tau_sigma_nu2
+
+ double precision :: f1_attenuation, f2_attenuation
+
+
+! f1 and f2 are computed as : f2/f1=12 and (log(f1)+log(f2))/2 = log(f0)
+ f1_attenuation = exp(log(f0_attenuation)-log(12.d0)/2.d0)
+ f2_attenuation = 12.d0 * f1_attenuation
+
+! Call of C function that computes attenuation parameters (function in file "attenuation_compute_param.c";
+! a main can be found in UTILS/attenuation directory).
+! Beware of underscores in this function name; depending on your compiler and compilation options, you will have to add or
+! delete underscores. Also look in file "attenuation_compute_param.c" for this issue.
+ call attenuation_compute_param(N_SLS, Qp_attenuation, Qs_attenuation, &
+ f1_attenuation,f2_attenuation, &
+ tau_sigma_nu1, tau_sigma_nu2, tau_epsilon_nu1, tau_epsilon_nu2)
+
+! attenuation constants for standard linear solids
+
+! nu1 is the dilatation mode
+! nu2 is the shear mode
+
+! array index (1) is the first standard linear solid, (2) is the second etc.
+
+! from J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993) for two memory-variable mechanisms (page 112).
+! Beware: these values implement specific values of the quality factors:
+! Qp approximately equal to 13 and Qs approximately equal to 10,
+! which means very high attenuation, see that paper for details.
+! tau_epsilon_nu1(1) = 0.0334d0
+! tau_sigma_nu1(1) = 0.0303d0
+! tau_epsilon_nu2(1) = 0.0352d0
+! tau_sigma_nu2(1) = 0.0287d0
+
+! tau_epsilon_nu1(2) = 0.0028d0
+! tau_sigma_nu1(2) = 0.0025d0
+! tau_epsilon_nu2(2) = 0.0029d0
+! tau_sigma_nu2(2) = 0.0024d0
+
+! from J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation
+! in a linear viscoelastic medium, Geophysical Journal International,
+! vol. 95, p. 597-611 (1988) for two memory-variable mechanisms (page 604).
+! Beware: these values implement specific values of the quality factors:
+! Qp approximately equal to 27 and Qs approximately equal to 20,
+! which means very high attenuation, see that paper for details.
+! tau_epsilon_nu1(1) = 0.0325305d0
+! tau_sigma_nu1(1) = 0.0311465d0
+! tau_epsilon_nu2(1) = 0.0332577d0
+! tau_sigma_nu2(1) = 0.0304655d0
+
+! tau_epsilon_nu1(2) = 0.0032530d0
+! tau_sigma_nu1(2) = 0.0031146d0
+! tau_epsilon_nu2(2) = 0.0033257d0
+! tau_sigma_nu2(2) = 0.0030465d0
+
+! values for Paul Cristini for fluid-solid ocean acoustics simulations
+
+! for N_SLS = 2
+! frequency range: 1.500000 Hz - 18.000000 Hz
+! central frequency in log scale in Hz = 5.196152422706633
+! target constant attenuation factor Q = 136.4376068115
+! tau sigma evenly spaced in log frequency, do not depend on value of Q
+
+! tau_sigma_nu1(1) = 0.10610329539459699422d0
+! tau_sigma_nu1(2) = 0.00884194128288308401d0
+
+! tau_epsilon_nu1(1) = 0.10754721280605997191d0
+! tau_epsilon_nu1(2) = 0.00895488050110176612d0
+
+! tau_epsilon_nu2(1) = tau_epsilon_nu1(1)
+! tau_epsilon_nu2(2) = tau_epsilon_nu1(2)
+! tau_sigma_nu2(1) = tau_sigma_nu1(1)
+! tau_sigma_nu2(2) = tau_sigma_nu1(2)
+
+!
+!--- other constants computed from the parameters above, do not modify
+!
+ inv_tau_sigma_nu1(:) = ONE / tau_sigma_nu1(:)
+ inv_tau_sigma_nu2(:) = ONE / tau_sigma_nu2(:)
+
+ phi_nu1(:) = (ONE - tau_epsilon_nu1(:)/tau_sigma_nu1(:)) / tau_sigma_nu1(:)
+ phi_nu2(:) = (ONE - tau_epsilon_nu2(:)/tau_sigma_nu2(:)) / tau_sigma_nu2(:)
+
+ Mu_nu1 = ONE
+ Mu_nu2 = ONE
+
+ do i_sls = 1,N_SLS
+ Mu_nu1 = Mu_nu1 - (ONE - tau_epsilon_nu1(i_sls)/tau_sigma_nu1(i_sls))
+ Mu_nu2 = Mu_nu2 - (ONE - tau_epsilon_nu2(i_sls)/tau_sigma_nu2(i_sls))
+ enddo
+
+ end subroutine attenuation_model
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/calendar.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/calendar.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/calendar.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/calendar.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,729 @@
+
+ integer function julian_day(yr,mo,da)
+
+ implicit none
+
+ integer yr,mo,da
+
+ integer mon(12)
+ integer lpyr
+ data mon /0,31,59,90,120,151,181,212,243,273,304,334/
+
+ julian_day = da + mon(mo)
+ if(mo>2) julian_day = julian_day + lpyr(yr)
+
+ end function julian_day
+
+! ------------------------------------------------------------------
+
+ integer function lpyr(yr)
+
+ implicit none
+
+ integer yr
+!
+!---- returns 1 if leap year
+!
+ lpyr=0
+ if(mod(yr,400) == 0) then
+ lpyr=1
+ else if(mod(yr,4) == 0) then
+ lpyr=1
+ if(mod(yr,100) == 0) lpyr=0
+ endif
+
+ end function lpyr
+
+! ------------------------------------------------------------------
+
+! function to determine if year is a leap year
+ logical function is_leap_year(yr)
+
+ implicit none
+
+ integer yr
+
+ integer, external :: lpyr
+
+!---- function lpyr above returns 1 if leap year
+ if(lpyr(yr) == 1) then
+ is_leap_year = .true.
+ else
+ is_leap_year = .false.
+ endif
+
+ end function is_leap_year
+
+
+!----------------------------------------------------------------------------------------------
+! open-source subroutines below taken from ftp://ftp.met.fsu.edu/pub/ahlquist/calendar_software
+!----------------------------------------------------------------------------------------------
+
+ integer function idaywk(jdayno)
+
+! IDAYWK = compute the DAY of the WeeK given the Julian Day number,
+! version 1.0.
+
+ implicit none
+
+! Input variable
+ integer, intent(in) :: jdayno
+! jdayno = Julian Day number starting at noon of the day in question.
+
+! Output of the function:
+! idaywk = day of the week, where 0=Sunday, 1=Monday, ..., 6=Saturday.
+
+!----------
+! Compute the day of the week given the Julian Day number.
+! You can find the Julian Day number given (day,month,year)
+! using subroutine calndr below.
+! Example: For the first day of the Gregorian calendar,
+! Friday 15 October 1582, compute the Julian day number (option 3 of
+! subroutine calndr) and compute the day of the week.
+! call calndr (3, 15, 10, 1582, jdayno)
+! write(*,*) jdayno, idaywk(jdayno)
+! The numbers printed should be 2299161 and 5, where 5 refers to Friday.
+!
+! Copyright (C) 1999 Jon Ahlquist.
+! Issued under the second GNU General Public License.
+! See www.gnu.org for details.
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+! If you find any errors, please notify:
+! Jon Ahlquist <ahlquist at met.fsu.edu>
+! Dept of Meteorology
+! Florida State University
+! Tallahassee, FL 32306-4520
+! 15 March 1999.
+!
+!-----
+
+! converted to Fortran90 by Dimitri Komatitsch,
+! University of Pau, France, January 2008.
+
+! jdSun is the Julian Day number starting at noon on any Sunday.
+! I arbitrarily chose the first Sunday after Julian Day 1,
+! which is Julian Day 6.
+ integer, parameter :: jdSun = 6
+
+ idaywk = mod(jdayno-jdSun,7)
+
+! If jdayno-jdSun < 0, then we are taking the modulus of a negative
+! number. Fortran's built-in mod function returns a negative value
+! when the argument is negative. In that case, we adjust the result
+! to a positive value.
+ if (idaywk < 0) idaywk = idaywk + 7
+
+ end function idaywk
+
+!
+!----
+!
+
+ subroutine calndr(iday,month,iyear,idayct)
+
+! CALNDR = CALeNDaR conversions, version 1.0
+
+ implicit none
+
+! specify the desired calendar conversion option.
+! in order to return the julian day number, compatible with function idaywk from above,
+! we choose option 3
+! (tested with dates: Feb, 23 2010 -> idaywk = Tue
+! Dec, 24 2009 -> idaywk = Thu
+! Oct, 15 1582 -> idaywk = Fri ...which all look o.k. )
+ integer, parameter :: ioptn = 3
+
+! Input/Output variables
+ integer, intent(inout) :: iday,month,iyear,idayct
+
+!----------
+!
+! Subroutine calndr() performs calendar calculations using either
+! the standard Gregorian calendar or the old Julian calendar.
+! This subroutine extends the definitions of these calendar systems
+! to any arbitrary year. The algorithms in this subroutine
+! will work with any date in the past or future,
+! but overflows will occur if the numbers are sufficiently large.
+! For a computer using a 32-bit integer, this routine can handle
+! any date between roughly 5.8 million BC and 5.8 million AD
+! without experiencing overflow during calculations.
+!
+! No external functions or subroutines are called.
+!
+!----------
+!
+! INPUT/OUTPUT ARGUMENTS FOR SUBROUTINE CALNDR()
+!
+! "ioptn" is the desired calendar conversion option explained below.
+! Positive option values use the standard modern Gregorian calendar.
+! Negative option values use the old Julian calendar which was the
+! standard in Europe from its institution by Julius Caesar in 45 BC
+! until at least 4 October 1582. The Gregorian and Julian calendars
+! are explained further below.
+!
+! (iday,month,iyear) is a calendar date where "iday" is the day of
+! the month, "month" is 1 for January, 2 for February, etc.,
+! and "iyear" is the year. If the year is 1968 AD, enter iyear=1968,
+! since iyear=68 would refer to 68 AD.
+! For BC years, iyear should be negative, so 45 BC would be iyear=-45.
+! By convention, there is no year 0 under the BC/AD year numbering
+! scheme. That is, years proceed as 2 BC, 1 BC, 1 AD, 2 AD, etc.,
+! without including 0. Subroutine calndr() will print an error message
+! and stop if you specify iyear=0.
+!
+! "idayct" is a day count. It is either the day number during the
+! specified year or the Julian Day number, depending on the value
+! of ioptn. By day number during the specified year, we mean
+! idayct=1 on 1 January, idayct=32 on 1 February, etc., to idayct=365
+! or 366 on 31 December, depending on whether the specified year
+! is a leap year.
+!
+! The values of input variables are not changed by this subroutine.
+!
+!
+! ALLOWABLE VALUES FOR "IOPTN" and the conversions they invoke.
+! Positive option values ( 1 to 5) use the standard Gregorian calendar.
+! Negative option values (-1 to -5) use the old Julian calendar.
+!
+! Absolute
+! value
+! of ioptn Input variable(s) Output variable(s)
+!
+! 1 iday,month,iyear idayct
+! Given a calendar date (iday,month,iyear), compute the day number
+! (idayct) during the year, where 1 January is day number 1 and
+! 31 December is day number 365 or 366, depending on whether it is
+! a leap year.
+!
+! 2 idayct,iyear iday,month
+! Given the day number of the year (idayct) and the year (iyear),
+! compute the day of the month (iday) and the month (month).
+!
+! 3 iday,month,iyear idayct
+! Given a calendar date (iday,month,iyear), compute the Julian Day
+! number (idayct) that starts at noon of the calendar date specified.
+!
+! 4 idayct iday,month,iyear
+! Given the Julian Day number (idayct) that starts at noon,
+! compute the corresponding calendar date (iday,month,iyear).
+!
+! 5 idayct iday,month,iyear
+! Given the Julian Day number (idayct) that starts at noon,
+! compute the corresponding day number for the year (iday)
+! and year (iyear). On return from calndr(), "month" will always
+! be set equal to 1 when ioptn=5.
+!
+! No inverse function is needed for ioptn=5 because it is
+! available through option 3. One simply calls calndr() with:
+! ioptn = 3,
+! iday = day number of the year instead of day of the month,
+! month = 1, and
+! iyear = whatever the desired year is.
+!
+!----------
+!
+! EXAMPLES
+! The first 6 examples are for the standard Gregorian calendar.
+! All the examples deal with 15 October 1582, which was the first day
+! of the Gregorian calendar. 15 October is the 288-th day of the year.
+! Julian Day number 2299161 began at noon on 15 October 1582.
+!
+! Find the day number during the year on 15 October 1582
+! ioptn = 1
+! call calndr (ioptn, 15, 10, 1582, idayct)
+! calndr() should return idayct=288
+!
+! Find the day of the month and month for day 288 in year 1582.
+! ioptn = 2
+! call calndr (ioptn, iday, month, 1582, 288)
+! calndr() should return iday=15 and month=10.
+!
+! Find the Julian Day number for 15 October 1582.
+! ioptn = 3
+! call calndr (ioptn, 15, 10, 1582, julian)
+! calndr() should return julian=2299161
+!
+! Find the Julian Day number for day 288 during 1582 AD.
+! When the input is day number of the year, one should specify month=1
+! ioptn = 3
+! call calndr (ioptn, 288, 1, 1582, julian)
+! calndr() should return dayct=2299161
+!
+! Find the date for Julian Day number 2299161.
+! ioptn = 4
+! call calndr (ioptn, iday, month, iyear, 2299161)
+! calndr() should return iday=15, month=10, and iyear=1582
+!
+! Find the day number during the year (iday) and year
+! for Julian Day number 2299161.
+! ioptn = 5
+! call calndr (ioptn, iday, month, iyear, 2299161)
+! calndr() should return iday=288, month=1, iyear=1582
+!
+! Given 15 October 1582 under the Gregorian calendar,
+! find the date (idayJ,imonthJ,iyearJ) under the Julian calendar.
+! To do this, we call calndr() twice, using the Julian Day number
+! as the intermediate value.
+! call calndr ( 3, 15, 10, 1582, julian)
+! call calndr (-4, idayJ, monthJ, iyearJ, julian)
+! The first call to calndr() should return julian=2299161, and
+! the second should return idayJ=5, monthJ=10, iyearJ=1582
+!
+!----------
+!
+! BASIC CALENDAR INFORMATION
+!
+! The Julian calendar was instituted by Julius Caesar in 45 BC.
+! Every fourth year is a leap year in which February has 29 days.
+! That is, the Julian calendar assumes that the year is exactly
+! 365.25 days long. Actually, the year is not quite this long.
+! The modern Gregorian calendar remedies this by omitting leap years
+! in years divisible by 100 except when the year is divisible by 400.
+! Thus, 1700, 1800, and 1900 are leap years under the Julian calendar
+! but not under the Gregorian calendar. The years 1600 and 2000 are
+! leap years under both the Julian and the Gregorian calendars.
+! Other years divisible by 4 are leap years under both calendars,
+! such as 1992, 1996, 2004, 2008, 2012, etc. For BC years, we recall
+! that year 0 was omitted, so 1 BC, 5 BC, 9 BC, 13 BC, etc., and 401 BC,
+! 801 BC, 1201 BC, etc., are leap years under both calendars, while
+! 101 BC, 201 BC, 301 BC, 501 BC, 601 BC, 701 BC, 901 BC, 1001 BC,
+! 1101 BC, etc., are leap years under the Julian calendar but not
+! the Gregorian calendar.
+!
+! The Gregorian calendar is named after Pope Gregory XIII. He declared
+! that the last day of the old Julian calendar would be Thursday,
+! 4 October 1582 and that the following day, Friday, would be reckoned
+! under the new calendar as 15 October 1582. The jump of 10 days was
+! included to make 21 March closer to the spring equinox.
+!
+! Only a few Catholic countries (Italy, Poland, Portugal, and Spain)
+! switched to the Gregorian calendar on the day after 4 October 1582.
+! It took other countries months to centuries to change to the
+! Gregorian calendar. For example, England's first day under the
+! Gregorian calendar was 14 September 1752. The same date applied to
+! the entire British empire, including America. Japan, Russia, and many
+! eastern European countries did not change to the Gregorian calendar
+! until the 20th century. The last country to change was Turkey,
+! which began using the Gregorian calendar on 1 January 1927.
+!
+! Therefore, between the years 1582 and 1926 AD, you must know
+! the country in which an event was dated to interpret the date
+! correctly. In Sweden, there was even a year (1712) when February
+! had 30 days. Consult a book on calendars for more details
+! about when various countries changed their calendars.
+!
+! DAY NUMBER DURING THE YEAR
+! The day number during the year is simply a counter equal to 1 on
+! 1 January, 32 on 1 February, etc., thorugh 365 or 366 on 31 December,
+! depending on whether the year is a leap year. Sometimes this is
+! called the Julian Day, but that term is better reserved for the
+! day counter explained below.
+!
+! JULIAN DAY NUMBER
+! The Julian Day numbering system was designed by Joseph Scaliger
+! in 1582 to remove ambiguity caused by varying calendar systems.
+! The name "Julian Day" was chosen to honor Scaliger's father,
+! Julius Caesar Scaliger (1484-1558), an Italian scholar and physician
+! who lived in France. Because Julian Day numbering was especially
+! designed for astronomers, Julian Days begin at noon so that the day
+! counter does not change in the middle of an astronmer's observing
+! period. Julian Day 0 began at noon on 1 January 4713 BC under the
+! Julian calendar. A modern reference point is that 23 May 1968
+! (Gregorian calendar) was Julian Day 2,440,000.
+!
+! JULIAN DAY NUMBER EXAMPLES
+!
+! The table below shows a few Julian Day numbers and their corresponding
+! dates, depending on which calendar is used. A negative 'iyear' refers
+! to BC (Before Christ).
+!
+! Julian Day under calendar:
+! iday month iyear Gregorian Julian
+! 24 11 -4714 0 -38
+! 1 1 -4713 38 0
+! 1 1 1 1721426 1721424
+! 4 10 1582 2299150 2299160
+! 15 10 1582 2299161 2299171
+! 1 3 1600 2305508 2305518
+! 23 5 1968 2440000 2440013
+! 5 7 1998 2451000 2451013
+! 1 3 2000 2451605 2451618
+! 1 1 2001 2451911 2451924
+!
+! From this table, we can see that the 10 day difference between the
+! two calendars in 1582 grew to 13 days by 1 March 1900, since 1900 was
+! a leap year under the Julian calendar but not under the Gregorian
+! calendar. The gap will widen to 14 days after 1 March 2100 for the
+! same reason.
+!
+!----------
+!
+! PORTABILITY
+!
+! This subroutine is written in standard FORTRAN 90.
+! It calls no external functions or subroutines and should run
+! without problem on any computer having a 32-bit word or longer.
+!
+!----------
+!
+! ALGORITHM
+!
+! The goal in coding calndr() was clear, clean code, not efficiency.
+! Calendar calculations usually take a trivial fraction of the time
+! in any program in which dates conversions are involved.
+! Data analysis usually takes the most time.
+!
+! Standard algorithms are followed in this subroutine. Internal to
+! this subroutine, we use a year counter "jyear" such that
+! jyear=iyear when iyear is positive
+! =iyear+1 when iyear is negative.
+! Thus, jyear does not experience a 1 year jump like iyear does
+! when going from BC to AD. Specifically, jyear=0 when iyear=-1,
+! i.e., when the year is 1 BC.
+!
+! For simplicity in dealing with February, inside this subroutine,
+! we let the year begin on 1 March so that the adjustable month,
+! February is the last month of the year.
+! It is clear that the calendar used to work this way because the
+! months September, October, November, and December refer to
+! 7, 8, 9, and 10. For consistency, jyear is incremented on 1 March
+! rather than on 1 January. Of course, everything is adjusted back to
+! standard practice of years beginning on 1 January before answers
+! are returned to the routine that calls calndr().
+!
+! Lastly, we use a trick to calculate the number of days from 1 March
+! until the end of the month that precedes the specified month.
+! That number of days is int(30.6001*(month+1))-122,
+! where 30.6001 is used to avoid the possibility of round-off and
+! truncation error. For example, if 30.6 were used instead,
+! 30.6*5 should be 153, but round-off error could make it 152.99999,
+! which would then truncated to 152, causing an error of 1 day.
+!
+! Algorithm reference:
+! Dershowitz, Nachum and Edward M. Reingold, 1990: Calendrical
+! Calculations. Software-Practice and Experience, vol. 20, number 9
+! (September 1990), pp. 899-928.
+!
+! Copyright (C) 1999 Jon Ahlquist.
+! Issued under the second GNU General Public License.
+! See www.gnu.org for details.
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+! If you find any errors, please notify:
+! Jon Ahlquist <ahlquist at met.fsu.edu>
+! Dept of Meteorology
+! Florida State University
+! Tallahassee, FL 32306-4520
+! 15 March 1999.
+!
+!-----
+
+! converted to Fortran90 by Dimitri Komatitsch,
+! University of Pau, France, January 2008.
+
+! Declare internal variables.
+ integer jdref, jmonth, jyear, leap, n1yr, n4yr, n100yr, n400yr, ndays, ndy400, ndy100, nyrs, yr400, yrref
+!
+! Explanation of all internal variables.
+! jdref Julian Day on which 1 March begins in the reference year.
+! jmonth Month counter which equals month+1 if month .gt. 2
+! or month+13 if month .le. 2.
+! jyear Year index, jyear=iyear if iyear .gt. 0, jyear=iyear+1
+! if iyear .lt. 0. Thus, jyear does not skip year 0
+! like iyear does between BC and AD years.
+! leap =1 if the year is a leap year, =0 if not.
+! n1yr Number of complete individual years between iyear and
+! the reference year after all 4, 100,
+! and 400 year periods have been removed.
+! n4yr Number of complete 4 year cycles between iyear and
+! the reference year after all 100 and 400 year periods
+! have been removed.
+! n100yr Number of complete 100 year periods between iyear and
+! the reference year after all 400 year periods
+! have been removed.
+! n400yr Number of complete 400 year periods between iyear and
+! the reference year.
+! ndays Number of days since 1 March during iyear. (In intermediate
+! steps, it holds other day counts as well.)
+! ndy400 Number of days in 400 years. Under the Gregorian calendar,
+! this is 400*365 + 100 - 3 = 146097. Under the Julian
+! calendar, this is 400*365 + 100 = 146100.
+! ndy100 Number of days in 100 years, Under the Gregorian calendar,
+! this is 100*365 + 24 = 36524. Under the Julian calendar,
+! this is 100*365 + 25 = 36525.
+! nyrs Number of years from the beginning of yr400
+! to the beginning of jyear. (Used for option +/-3).
+! yr400 The largest multiple of 400 years that is .le. jyear.
+!
+!
+!----------------------------------------------------------------
+! Do preparation work.
+!
+! Look for out-of-range option values.
+ if ((ioptn == 0) .or. (abs(ioptn) >= 6)) then
+ write(*,*)'For calndr(), you specified ioptn = ', ioptn
+ write(*,*) 'Allowable values are 1 to 5 for the Gregorian calendar'
+ write(*,*) 'and -1 to -5 for the Julian calendar.'
+ stop
+ endif
+!
+! Options 1-3 have "iyear" as an input value.
+! Internally, we use variable "jyear" that does not have a jump
+! from -1 (for 1 BC) to +1 (for 1 AD).
+ if (abs(ioptn) <= 3) then
+ if (iyear > 0) then
+ jyear = iyear
+ elseif (iyear == 0) then
+ write(*,*) 'For calndr(), you specified the nonexistent year 0'
+ stop
+ else
+ jyear = iyear + 1
+ endif
+!
+! Set "leap" equal to 0 if "jyear" is not a leap year
+! and equal to 1 if it is a leap year.
+ leap = 0
+ if ((jyear/4)*4 == jyear) then
+ leap = 1
+ endif
+ if ((ioptn > 0) .and. &
+ ((jyear/100)*100 == jyear) .and. &
+ ((jyear/400)*400 /= jyear) ) then
+ leap = 0
+ endif
+ endif
+!
+! Options 3-5 involve Julian Day numbers, which need a reference year
+! and the Julian Days that began at noon on 1 March of the reference
+! year under the Gregorian and Julian calendars. Any year for which
+! "jyear" is divisible by 400 can be used as a reference year.
+! We chose 1600 AD as the reference year because it is the closest
+! multiple of 400 to the institution of the Gregorian calendar, making
+! it relatively easy to compute the Julian Day for 1 March 1600
+! given that, on 15 October 1582 under the Gregorian calendar,
+! the Julian Day was 2299161. Similarly, we need to do the same
+! calculation for the Julian calendar. We can compute this Julian
+! Day knwoing that on 4 October 1582 under the Julian calendar,
+! the Julian Day number was 2299160. The details of these calculations
+! is next.
+! From 15 October until 1 March, the number of days is the remainder
+! of October plus the days in November, December, January, and February:
+! 17+30+31+31+28 = 137, so 1 March 1583 under the Gregorian calendar
+! was Julian Day 2,299,298. Because of the 10 day jump ahead at the
+! switch from the Julian calendar to the Gregorian calendar, 1 March
+! 1583 under the Julian calendar was Julian Day 2,299,308. Making use
+! of the rules for the two calendar systems, 1 March 1600 was Julian
+! Day 2,299,298 + (1600-1583)*365 + 5 (due to leap years) =
+! 2,305,508 under the Gregorian calendar and day 2,305,518 under the
+! Julian calendar.
+! We also set the number of days in 400 years and 100 years.
+! For reference, 400 years is 146097 days under the Gregorian calendar
+! and 146100 days under the Julian calendar. 100 years is 36524 days
+! under the Gregorian calendar and 36525 days under the Julian calendar.
+ if (abs(ioptn) >= 3) then
+!
+! Julian calendar values.
+ yrref = 1600
+ jdref = 2305518
+! = Julian Day reference value for the day that begins
+! at noon on 1 March of the reference year "yrref".
+ ndy400 = 400*365 + 100
+ ndy100 = 100*365 + 25
+!
+! Adjust for Gregorian calendar values.
+ if (ioptn > 0) then
+ jdref = jdref - 10
+ ndy400 = ndy400 - 3
+ ndy100 = ndy100 - 1
+ endif
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -1 and +1:
+! Given a calendar date (iday,month,iyear), compute the day number
+! of the year (idayct), where 1 January is day number 1 and 31 December
+! is day number 365 or 366, depending on whether it is a leap year.
+ if (abs(ioptn) == 1) then
+!
+! Compute the day number during the year.
+ if (month <= 2) then
+ idayct = iday + (month-1)*31
+ else
+ idayct = iday + int(30.6001 * (month+1)) - 63 + leap
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -2 and +2:
+! Given the day number of the year (idayct) and the year (iyear),
+! compute the day of the month (iday) and the month (month).
+ elseif (abs(ioptn) == 2) then
+!
+ if (idayct < 60+leap) then
+ month = (idayct-1)/31
+ iday = idayct - month*31
+ month = month + 1
+ else
+ ndays = idayct - (60+leap)
+! = number of days past 1 March of the current year.
+ jmonth = (10*(ndays+31))/306 + 3
+! = month counter, =4 for March, =5 for April, etc.
+ iday = (ndays+123) - int(30.6001*jmonth)
+ month = jmonth - 1
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -3 and +3:
+! Given a calendar date (iday,month,iyear), compute the Julian Day
+! number (idayct) that starts at noon.
+ elseif (abs(ioptn) == 3) then
+!
+! Shift to a system where the year starts on 1 March, so January
+! and February belong to the preceding year.
+! Define jmonth=4 for March, =5 for April, ..., =15 for February.
+ if (month <= 2) then
+ jyear = jyear - 1
+ jmonth = month + 13
+ else
+ jmonth = month + 1
+ endif
+!
+! Find the closest multiple of 400 years that is .le. jyear.
+ yr400 = (jyear/400)*400
+! = multiple of 400 years at or less than jyear.
+ if (jyear < yr400) then
+ yr400 = yr400 - 400
+ endif
+!
+ n400yr = (yr400 - yrref)/400
+! = number of 400-year periods from yrref to yr400.
+ nyrs = jyear - yr400
+! = number of years from the beginning of yr400
+! to the beginning of jyear.
+!
+! Compute the Julian Day number.
+ idayct = iday + int(30.6001*jmonth) - 123 + 365*nyrs + nyrs/4 &
+ + jdref + n400yr*ndy400
+!
+! If we are using the Gregorian calendar, we must not count
+! every 100-th year as a leap year. nyrs is less than 400 years,
+! so we do not need to consider the leap year that would occur if
+! nyrs were divisible by 400, i.e., we do not add nyrs/400.
+ if (ioptn > 0) then
+ idayct = idayct - nyrs/100
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -5, -4, +4, and +5:
+! Given the Julian Day number (idayct) that starts at noon,
+! compute the corresponding calendar date (iday,month,iyear)
+! (abs(ioptn)=4) or day number during the year (abs(ioptn)=5).
+ else
+!
+! Create a new reference date which begins on the nearest
+! 400-year cycle less than or equal to the Julian Day for 1 March
+! in the year in which the given Julian Day number (idayct) occurs.
+ ndays = idayct - jdref
+ n400yr = ndays / ndy400
+! = integral number of 400-year periods separating
+! idayct and the reference date, jdref.
+ jdref = jdref + n400yr*ndy400
+ if (jdref > idayct) then
+ n400yr = n400yr - 1
+ jdref = jdref - ndy400
+ endif
+!
+ ndays = idayct - jdref
+! = number from the reference date to idayct.
+!
+ n100yr = min(ndays/ndy100, 3)
+! = number of complete 100-year periods
+! from the reference year to the current year.
+! The min() function is necessary to avoid n100yr=4
+! on 29 February of the last year in the 400-year cycle.
+!
+ ndays = ndays - n100yr*ndy100
+! = remainder after removing an integral number of
+! 100-year periods.
+!
+ n4yr = ndays / 1461
+! = number of complete 4-year periods in the current century.
+! 4 years consists of 4*365 + 1 = 1461 days.
+!
+ ndays = ndays - n4yr*1461
+! = remainder after removing an integral number
+! of 4-year periods.
+!
+ n1yr = min(ndays/365, 3)
+! = number of complete years since the last leap year.
+! The min() function is necessary to avoid n1yr=4
+! when the date is 29 February on a leap year,
+! in which case ndays=1460, and 1460/365 = 4.
+!
+ ndays = ndays - 365*n1yr
+! = number of days so far in the current year,
+! where ndays=0 on 1 March.
+!
+ iyear = n1yr + 4*n4yr + 100*n100yr + 400*n400yr + yrref
+! = year, as counted in the standard way,
+! but relative to 1 March.
+!
+! At this point, we need to separate ioptn=abs(4), which seeks a
+! calendar date, and ioptn=abs(5), which seeks the day number during
+! the year. First compute the calendar date if desired (abs(ioptn)=4).
+ if (abs(ioptn) == 4) then
+ jmonth = (10*(ndays+31))/306 + 3
+! = offset month counter. jmonth=4 for March, =13 for
+! December, =14 for January, =15 for February.
+ iday = (ndays+123) - int(30.6001*jmonth)
+! = day of the month, starting with 1 on the first day
+! of the month.
+!
+! Now adjust for the fact that the year actually begins
+! on 1 January.
+ if (jmonth <= 13) then
+ month = jmonth - 1
+ else
+ month = jmonth - 13
+ iyear = iyear + 1
+ endif
+!
+! This code handles abs(ioptn)=5, finding the day number during the year.
+ else
+! ioptn=5 always returns month=1, which we set now.
+ month = 1
+!
+! We need to determine whether this is a leap year.
+ leap = 0
+ if ((jyear/4)*4 == jyear) then
+ leap = 1
+ endif
+ if ((ioptn > 0) .and. &
+ ((jyear/100)*100 == jyear) .and. &
+ ((jyear/400)*400 /= jyear) ) then
+ leap = 0
+ endif
+!
+! Now find the day number "iday".
+! ndays is the number of days since the most recent 1 March,
+! so ndays=0 on 1 March.
+ if (ndays <=305) then
+ iday = ndays + 60 + leap
+ else
+ iday = ndays - 305
+ iyear = iyear + 1
+ endif
+ endif
+!
+! Adjust the year if it is .le. 0, and hence BC (Before Christ).
+ if (iyear <= 0) then
+ iyear = iyear - 1
+ endif
+!
+! End the code for the last option, ioptn.
+ endif
+
+ end subroutine calndr
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/check_stability.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/check_stability.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/check_stability.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/check_stability.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,305 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine check_stability(myrank,time,it,NSTEP, &
+ npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ any_elastic_glob,any_elastic,displ_elastic, &
+ any_poroelastic_glob,any_poroelastic, &
+ displs_poroelastic,displw_poroelastic, &
+ any_acoustic_glob,any_acoustic,potential_acoustic, &
+ year_start,month_start,time_start)
+
+! checks simulation stability and outputs timerun infos
+
+ implicit none
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: myrank,it,NSTEP
+
+ double precision :: time
+
+ logical :: any_elastic_glob,any_elastic
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
+
+ logical :: any_poroelastic_glob,any_poroelastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
+
+ logical :: any_acoustic_glob,any_acoustic
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
+
+ double precision :: time_start
+ integer :: year_start,month_start
+
+ ! local parameters
+ double precision displnorm_all,displnorm_all_glob
+ ! timer to count elapsed time
+ double precision :: time_end
+ integer :: year_end,month_end
+ double precision :: tCPU,t_remain,t_total
+ integer :: ihours,iminutes,iseconds,int_tCPU, &
+ ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
+ ihours_total,iminutes_total,iseconds_total,int_t_total
+ ! to determine date and time at which the run will finish
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ character(len=3), dimension(12) :: month_name
+ character(len=3), dimension(0:6) :: weekday_name
+ data month_name /'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/
+ data weekday_name /'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'/
+ integer :: year,mon,day,hr,minutes,timestamp,julian_day_number,day_of_week
+ integer, external :: idaywk
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+ ! user output
+ 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
+
+
+ ! elastic wavefield
+ if(any_elastic_glob) then
+ if(any_elastic) then
+ displnorm_all = maxval(sqrt(displ_elastic(1,:)**2 &
+ + displ_elastic(2,:)**2 &
+ + displ_elastic(3,:)**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 solid (elastic) = ',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 (elastic)')
+
+ endif
+
+ ! poroelastic wavefield
+ if(any_poroelastic_glob) then
+ if(any_poroelastic) then
+ displnorm_all = maxval(sqrt(displs_poroelastic(1,:)**2 &
+ + displs_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 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
+ ! 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
+
+
+ ! acoustic wavefield
+ if(any_acoustic_glob) then
+ if(any_acoustic) then
+ displnorm_all = maxval(abs(potential_acoustic(:)))
+ 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 absolute value of scalar field in fluid (acoustic) = ',displnorm_all_glob
+
+ ! check stability of the code in fluid, exit if unstable
+ ! negative values can occur with some compilers when the unstable value is greater
+ ! than the greatest possible floating-point number of the machine
+ if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
+ call exit_MPI('code became unstable and blew up in fluid (acoustic)')
+
+ endif
+
+ ! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+ ! time_values(1): year
+ ! time_values(2): month of the year
+ ! time_values(3): day of the month
+ ! time_values(5): hour of the day
+ ! time_values(6): minutes of the hour
+ ! time_values(7): seconds of the minute
+ ! time_values(8): milliseconds of the second
+ ! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+ month_end = time_values(2)
+ year_end = time_values(1)
+
+ ! elapsed time since beginning of the simulation
+ if (myrank == 0) then
+ if(month_end == month_start .and. year_end == year_start) then
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ 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)
+
+ ! compute estimated remaining simulation time
+ t_remain = (NSTEP - it) * (tCPU/dble(it))
+ int_t_remain = int(t_remain)
+ ihours_remain = int_t_remain / 3600
+ iminutes_remain = (int_t_remain - 3600*ihours_remain) / 60
+ iseconds_remain = int_t_remain - 3600*ihours_remain - 60*iminutes_remain
+ write(IOUT,*) 'Time steps remaining = ',NSTEP - it
+ write(IOUT,*) 'Estimated remaining time in seconds = ',t_remain
+ write(IOUT,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_remain,iminutes_remain,iseconds_remain
+
+ ! compute estimated total simulation time
+ t_total = t_remain + tCPU
+ int_t_total = int(t_total)
+ ihours_total = int_t_total / 3600
+ iminutes_total = (int_t_total - 3600*ihours_total) / 60
+ iseconds_total = int_t_total - 3600*ihours_total - 60*iminutes_total
+ write(IOUT,*) 'Estimated total run time in seconds = ',t_total
+ write(IOUT,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_total,iminutes_total,iseconds_total
+
+ if(it < NSTEP) then
+ ! compute date and time at which the run should finish
+ ! (useful for long runs); for simplicity only minutes
+ ! are considered, seconds are ignored; in any case the prediction is not
+ ! accurate down to seconds because of system and network fluctuations
+ year = time_values(1)
+ mon = time_values(2)
+ day = time_values(3)
+ hr = time_values(5)
+ minutes = time_values(6)
+
+ ! get timestamp in minutes of current date and time
+ call convtime(timestamp,year,mon,day,hr,minutes)
+
+ ! add remaining minutes
+ timestamp = timestamp + nint(t_remain / 60.d0)
+
+ ! get date and time of that future timestamp in minutes
+ call invtime(timestamp,year,mon,day,hr,minutes)
+
+ ! convert to Julian day to get day of the week
+ call calndr(day,mon,year,julian_day_number)
+ day_of_week = idaywk(julian_day_number)
+
+ write(IOUT,"(' The run will finish approximately on: ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
+ weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
+
+ endif
+ write(IOUT,*)
+ else
+ write(IOUT,*) 'The calendar has crossed the end of the month during the simulation,'
+ write(IOUT,*) 'cannot produce accurate CPU time estimates any more.'
+ write(IOUT,*)
+ endif
+ endif
+
+ if (myrank == 0) write(IOUT,*)
+
+ end subroutine check_stability
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/checkgrid.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/checkgrid.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/checkgrid.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/checkgrid.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,3102 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine checkgrid(vpext,vsext,rhoext,density,poroelastcoef, &
+ porosity,tortuosity,permeability,ibool,kmato, &
+ coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
+ assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat, &
+ f0,initialfield,time_function_type, &
+ coorg,xinterp,zinterp,shapeint,knods,simulation_title, &
+ npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,all_anisotropic, &
+ myrank,nproc,NSOURCES,poroelastic, &
+ freq0,Q0,TURN_VISCATTENUATION_ON)
+
+! check the mesh, stability and number of points per wavelength
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ 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
+
+ integer :: npoin,nspec,numat
+ 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(3,numat) :: permeability
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
+
+ double precision coord(NDIM,npoin)
+
+ integer :: NSOURCES
+ integer, dimension(NSOURCES) :: time_function_type
+ double precision, dimension(NSOURCES) :: f0
+
+ integer :: pointsdisp,npgeo,ngnod
+
+ integer :: knods(ngnod,nspec)
+
+ double precision :: xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
+ double precision :: shapeint(ngnod,pointsdisp,pointsdisp)
+
+ double precision :: coorg(NDIM,npgeo)
+
+! title of the plot
+ character(len=60) :: simulation_title
+
+ double precision :: vpImin,vpImax
+ double precision :: vpIImin,vpIImax
+ double precision :: deltat
+
+ logical :: assign_external_model,initialfield,any_elastic,any_poroelastic,all_anisotropic, &
+ TURN_VISCATTENUATION_ON
+
+ integer :: myrank,nproc
+
+ ! local parameters
+ double precision vpIImax_local,vpIImin_local
+ double precision vsmin,vsmax,densmin,densmax,vpImax_local,vpImin_local,vsmin_local
+ double precision kappa_s,kappa_f,kappa_fr,mu_s,mu_fr,denst_s,denst_f,denst,phi,tort,cpIloc,cpIIloc,csloc
+ double precision D_biot,H_biot,C_biot,M_biot,cpIsquare,cpIIsquare,cssquare
+ double precision f0min,f0max,freq0,Q0,w_c,eta_f,perm
+ double precision lambdaplus2mu,mu
+ double precision distance_min,distance_max,distance_min_local,distance_max_local
+ double precision courant_stability_number_max,lambdaPImin,lambdaPImax,lambdaPIImin,lambdaPIImax, &
+ lambdaSmin,lambdaSmax
+ double precision distance_1,distance_2,distance_3,distance_4
+
+! for the stability condition
+! maximum polynomial degree for which we can compute the stability condition
+ integer, parameter :: NGLLX_MAX_STABILITY = 15
+ double precision :: percent_GLL(NGLLX_MAX_STABILITY)
+
+! color palette
+ integer, parameter :: NUM_COLORS = 236
+ double precision, dimension(NUM_COLORS) :: red,green,blue
+
+ double precision :: xmax,zmax,height,usoffset,sizex,sizez,courant_stability_number
+ double precision :: x1,z1,x2,z2,ratio_page,xmin,zmin,lambdaS_local,lambdaPI_local
+
+#ifdef USE_MPI
+ integer :: icol
+ double precision :: vpImin_glob,vpImax_glob,vsmin_glob,vsmax_glob,densmin_glob,densmax_glob
+ double precision :: vpIImin_glob,vpIImax_glob
+ double precision :: distance_min_glob,distance_max_glob
+ double precision :: courant_stability_max_glob,lambdaPImin_glob,lambdaPImax_glob,&
+ lambdaPIImin_glob,lambdaPIImax_glob,lambdaSmin_glob,lambdaSmax_glob
+ double precision :: xmin_glob, xmax_glob, zmin_glob, zmax_glob
+#endif
+
+ logical :: any_elastic_glob,any_poroelastic_glob
+ double precision, dimension(2,nspec*5) :: coorg_send
+ double precision, dimension(:,:), allocatable :: coorg_recv
+ integer, dimension(nspec) :: RGB_send
+ integer, dimension(:), allocatable :: RGB_recv
+ real, dimension(nspec) :: greyscale_send
+ real, dimension(:), allocatable :: greyscale_recv
+ integer :: nspec_recv
+ integer :: num_ispec
+ integer :: iproc
+ integer :: ier
+ integer :: i,j,ispec,material
+ integer :: is,ir,in,nnum
+
+#ifdef USE_MPI
+ integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
+#endif
+
+ ! check
+ if(UPPER_LIMIT_DISPLAY > nspec) &
+ call exit_MPI('cannot have UPPER_LIMIT_DISPLAY > nspec in checkgrid.F90')
+
+#ifndef USE_MPI
+ allocate(coorg_recv(1,1))
+ allocate(RGB_recv(1))
+ allocate(greyscale_recv(1))
+ nspec_recv = 0
+ ier = 0
+ iproc = nproc
+ deallocate(coorg_recv)
+ deallocate(RGB_recv)
+ 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
+ call checkgrid_setup_GLLper(percent_GLL,NGLLX_MAX_STABILITY)
+
+! define color palette in random order
+ call checkgrid_setup_colorp(red,green,blue,NUM_COLORS)
+
+!---- compute parameters for the spectral elements
+
+ vpImin = HUGEVAL
+ vpImax = -HUGEVAL
+
+ if(any_elastic .or. any_poroelastic) then
+ vsmin = HUGEVAL
+ vsmax = -HUGEVAL
+ else
+ vsmin = 0
+ vsmax = 0
+ endif
+
+ if(any_poroelastic) then
+ vpIImin = HUGEVAL
+ vpIImax = -HUGEVAL
+ else
+ vpIImin = 0
+ vpIImax = 0
+ endif
+
+ densmin = HUGEVAL
+ densmax = -HUGEVAL
+
+ distance_min = HUGEVAL
+ distance_max = -HUGEVAL
+
+ courant_stability_number_max = -HUGEVAL
+
+ lambdaPImin = HUGEVAL
+ lambdaPImax = -HUGEVAL
+
+ if(any_elastic .or. any_poroelastic) then
+ lambdaSmin = HUGEVAL
+ lambdaSmax = -HUGEVAL
+ else
+ lambdaSmin = 0
+ lambdaSmax = 0
+ endif
+
+ if(any_poroelastic) then
+ lambdaPIImin = HUGEVAL
+ lambdaPIImax = -HUGEVAL
+ else
+ lambdaPIImin = 0
+ lambdaPIImax = 0
+ endif
+
+ do ispec=1,nspec
+
+ material = kmato(ispec)
+
+ if(poroelastic(ispec)) then
+
+ ! poroelastic material
+
+ phi = porosity(material)
+ tort = tortuosity(material)
+ perm = permeability(1,material)
+ ! solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+ denst = denst_s
+ ! fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+ eta_f = poroelastcoef(2,2,material)
+ ! frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ ! 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)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
+ tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIloc = sqrt(cpIsquare)
+ cpIIloc = sqrt(cpIIsquare)
+ csloc = sqrt(cssquare)
+ else
+ mu = poroelastcoef(2,1,material)
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
+
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ cpIIloc = 0.d0
+ csloc = sqrt(mu/denst)
+ endif
+
+ vpImax_local = -HUGEVAL
+ vpImin_local = HUGEVAL
+ vpIImax_local = -HUGEVAL
+ vpIImin_local = HUGEVAL
+ vsmin_local = HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cpIloc = vpext(i,j,ispec)
+ csloc = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ endif
+
+!--- compute min and max of velocity and density models
+ vpImin = min(vpImin,cpIloc)
+ vpImax = max(vpImax,cpIloc)
+
+! ignore acoustic and elastic regions with cpII = 0
+ if(cpIIloc > 0.0001d0) vpIImin = min(vpIImin,cpIIloc)
+ vpIImax = max(vpIImax,cpIIloc)
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) vsmin = min(vsmin,csloc)
+ vsmax = max(vsmax,csloc)
+
+ densmin = min(densmin,denst)
+ densmax = max(densmax,denst)
+
+ vpImax_local = max(vpImax_local,vpImax)
+ vpImin_local = min(vpImin_local,vpImin)
+ vpIImax_local = max(vpIImax_local,vpIImax)
+ vpIImin_local = min(vpIImin_local,vpIImin)
+ vsmin_local = min(vsmin_local,vsmin)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ distance_min = min(distance_min,distance_min_local)
+ distance_max = max(distance_max,distance_max_local)
+
+ courant_stability_number_max = max(courant_stability_number_max, &
+ vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX)))
+
+! ignore fluid regions with Vs = 0
+ 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
+
+ lambdaPImin = min(lambdaPImin,vpImin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPImax = max(lambdaPImax,vpImin_local / (distance_max_local / (NGLLX - 1)))
+
+ if(cpIIloc > 0.0001d0) then
+ lambdaPIImin = min(lambdaPIImin,vpIImin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPIImax = max(lambdaPIImax,vpIImin_local / (distance_max_local / (NGLLX - 1)))
+ endif
+
+ enddo
+
+ any_elastic_glob = any_elastic
+ any_poroelastic_glob = any_poroelastic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (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 (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)
+ call MPI_ALLREDUCE (densmax, densmax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (distance_min, distance_min_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (distance_max, distance_max_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (courant_stability_number_max, courant_stability_max_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPImin, lambdaPImin_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPImax, lambdaPImax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPIImin, lambdaPIImin_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPIImax, lambdaPIImax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaSmin, lambdaSmin_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaSmax, lambdaSmax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (any_elastic, any_elastic_glob, 1, MPI_LOGICAL, &
+ MPI_LOR, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, &
+ MPI_LOR, MPI_COMM_WORLD, ier)
+ vpImin = vpImin_glob
+ vpImax = vpImax_glob
+ vpIImin = vpIImin_glob
+ vpIImax = vpIImax_glob
+ vsmin = vsmin_glob
+ vsmax = vsmax_glob
+ densmin = densmin_glob
+ densmax = densmax_glob
+ distance_min = distance_min_glob
+ distance_max = distance_max_glob
+ courant_stability_number_max = courant_stability_max_glob
+ lambdaPImin = lambdaPImin_glob
+ lambdaPImax = lambdaPImax_glob
+ lambdaPIImin = lambdaPIImin_glob
+ lambdaPIImax = lambdaPIImax_glob
+ lambdaSmin = lambdaSmin_glob
+ lambdaSmax = lambdaSmax_glob
+
+#endif
+
+ if ( myrank == 0 ) then
+ if(.not. all_anisotropic) then
+ write(IOUT,*)
+ write(IOUT,*) '********'
+ 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
+ write(IOUT,*) '********'
+ write(IOUT,*)
+
+ write(IOUT,*)
+ write(IOUT,*) '*********************************************'
+ write(IOUT,*) '*** Verification of simulation parameters ***'
+ write(IOUT,*) '*********************************************'
+ write(IOUT,*)
+ write(IOUT,*) '*** Max grid size = ',distance_max
+ write(IOUT,*) '*** Min grid size = ',distance_min
+ write(IOUT,*) '*** Max/min ratio = ',distance_max/distance_min
+ write(IOUT,*)
+ write(IOUT,*) '*** Max stability for P wave velocity = ',courant_stability_number_max
+ write(IOUT,*)
+ end if
+
+! 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) then
+ f0max = -HUGEVAL
+ f0min = HUGEVAL
+! write(IOUT,*) ' USER_T0 = ',USER_T0
+
+ do i = 1,NSOURCES
+
+ ! excludes Dirac and Heaviside sources
+ if(time_function_type(i) /= 4 .and. time_function_type(i) /= 5) then
+! write(IOUT,*) ' Onset time = ',t0+tshift_src(i)
+! write(IOUT,*) ' Fundamental period = ',1.d0/f0(i)
+! write(IOUT,*) ' Fundamental frequency = ',f0(i)
+! ! checks source onset time
+! if( t0+tshift_src(i) <= 1.d0/f0(i)) then
+! call exit_MPI('Onset time too small')
+! else
+! write(IOUT,*) ' --> onset time ok'
+! endif
+
+ ! sets min/max frequency
+ if(f0(i) > f0max) f0max = f0(i)
+ if(f0(i) < f0min) f0min = f0(i)
+
+ if( i == NSOURCES ) then
+ write(IOUT,*) '----'
+ 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*f0min)
+ write(IOUT,*) ' Nb pts / lambdaPIImin_fmax min = ',lambdaPIImin/(2.5d0*f0max)
+ write(IOUT,*) '----'
+ 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
+
+!
+!--------------------------------------------------------------------------------
+!
+
+! A4 or US letter paper
+ if(US_LETTER) then
+ usoffset = 1.75d0
+ sizex = 27.94d0
+ sizez = 21.59d0
+ else
+ usoffset = 0.d0
+ sizex = 29.7d0
+ sizez = 21.d0
+ endif
+
+! height of domain numbers in centimeters
+ height = 0.25d0
+
+! get minimum and maximum values of mesh coordinates
+ xmin = minval(coord(1,:))
+ zmin = minval(coord(2,:))
+ xmax = maxval(coord(1,:))
+ zmax = maxval(coord(2,:))
+
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (xmin, xmin_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 (zmin, zmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (zmax, zmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ xmin = xmin_glob
+ xmax = xmax_glob
+ zmin = zmin_glob
+ zmax = zmax_glob
+
+#endif
+
+! ratio of physical page size/size of the domain meshed
+ ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
+
+
+ if (myrank == 0) then
+
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with stability condition'
+
+!
+!---- open PostScript file
+!
+ open(unit=24,file='OUTPUT_FILES/mesh_stability.ps',status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+ !
+ !--- write captions of PostScript figure
+ !
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Z axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ 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,*) 'grestore'
+ write(24,*) '25.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,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 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,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+ !
+ !---- draw the spectral element mesh
+ !
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ num_ispec = 0
+ endif
+
+ do ispec = 1, nspec
+ if ( myrank == 0 ) then
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ endif
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ if ( myrank == 0 ) then
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+ else
+ coorg_send(1,(ispec-1)*5+1) = x1
+ coorg_send(2,(ispec-1)*5+1) = z1
+ endif
+
+ ! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+2) = x2
+ coorg_send(2,(ispec-1)*5+2) = z2
+ endif
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+3) = x2
+ coorg_send(2,(ispec-1)*5+3) = z2
+ endif
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+4) = x2
+ coorg_send(2,(ispec-1)*5+4) = z2
+ endif
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ write(24,*) 'CO'
+ else
+ coorg_send(1,(ispec-1)*5+5) = x2
+ coorg_send(2,(ispec-1)*5+5) = z2
+ endif
+
+ material = kmato(ispec)
+
+ if(poroelastic(ispec)) then
+
+ ! poroelastic material
+
+ phi=porosity(material)
+ tort=tortuosity(material)
+ perm=permeability(1,material)
+ ! solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+ denst = denst_s
+ ! fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+ eta_f = poroelastcoef(2,2,material)
+ ! frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ ! 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)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
+ tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ 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
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ !--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cpIloc = vpext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ endif
+
+ vpImax_local = max(vpImax_local,cpIloc)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ distance_min = min(distance_min,distance_min_local)
+ distance_max = max(distance_max,distance_max_local)
+
+ courant_stability_number = vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX))
+
+! display bad elements that are above 80% of the threshold
+ if(courant_stability_number >= 0.80 * courant_stability_number_max) then
+ if ( myrank == 0 ) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ else
+ RGB_send(ispec) = 1
+ endif
+ else
+! do not color the elements if below the threshold
+ if ( myrank == 0 ) then
+ write(24,*) 'ST'
+ else
+ RGB_send(ispec) = 0
+ endif
+ endif
+
+ enddo ! end of loop on all the spectral elements
+
+#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*5))
+ allocate(RGB_recv(nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ call MPI_RECV (RGB_recv(1), nspec_recv, MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ do ispec = 1, nspec_recv
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ write(24,*) 'mark'
+ write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
+ write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
+ write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
+ write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
+ write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
+ write(24,*) 'CO'
+ if ( RGB_recv(ispec) == 1) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ else
+ write(24,*) 'ST'
+ endif
+ enddo
+ deallocate(coorg_recv)
+ deallocate(RGB_recv)
+
+ 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)
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ write(IOUT,*) 'End of creation of PostScript file with stability condition'
+ endif
+
+!
+!--------------------------------------------------------------------------------
+!
+
+ if (myrank == 0) then
+
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with mesh dispersion'
+
+!
+!---- open PostScript file
+!
+ 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')
+ endif
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Z axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ 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'
+ if(any_elastic_glob) then
+ write(24,*) '(Mesh elastic S-wave dispersion \(red = good, blue = bad\)) show'
+ else
+ write(24,*) '(Mesh acoustic P-wave dispersion \(red = good, blue = bad\)) show'
+ endif
+ write(24,*) 'grestore'
+ write(24,*) '25.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,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 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,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ num_ispec = 0
+ endif
+
+ do ispec = 1, nspec
+ if ( myrank == 0 ) then
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ endif
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ if ( myrank == 0 ) then
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+ else
+ coorg_send(1,(ispec-1)*5+1) = x1
+ coorg_send(2,(ispec-1)*5+1) = z1
+ endif
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+2) = x2
+ coorg_send(2,(ispec-1)*5+2) = z2
+ endif
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+3) = x2
+ coorg_send(2,(ispec-1)*5+3) = z2
+ endif
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+4) = x2
+ coorg_send(2,(ispec-1)*5+4) = z2
+ endif
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ write(24,*) 'CO'
+ else
+ coorg_send(1,(ispec-1)*5+5) = x2
+ coorg_send(2,(ispec-1)*5+5) = z2
+ endif
+
+ material = kmato(ispec)
+
+ if(poroelastic(ispec)) then
+ phi = porosity(material)
+ tort = tortuosity(material)
+ perm = permeability(1,material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+ denst = denst_s
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+ eta_f = poroelastcoef(2,2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+!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)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
+ tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIloc = sqrt(cpIsquare)
+ csloc = sqrt(cssquare)
+ else
+ mu = poroelastcoef(2,1,material)
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
+
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+ endif
+
+ vpImax_local = -HUGEVAL
+ vpImin_local = HUGEVAL
+ vsmin_local = HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cpIloc = vpext(i,j,ispec)
+ csloc = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ endif
+
+ vpImax_local = max(vpImax_local,cpIloc)
+ vpImin_local = min(vpImin_local,cpIloc)
+ vsmin_local = min(vsmin_local,csloc)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ distance_min = min(distance_min,distance_min_local)
+ distance_max = max(distance_max,distance_max_local)
+
+! display mesh dispersion for S waves if there is at least one elastic element in the mesh
+ if(any_elastic_glob .or. any_poroelastic_glob) then
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) then
+
+ lambdaS_local = vsmin_local / (distance_max_local / (NGLLX - 1))
+
+! display very good elements that are above 80% of the threshold in red
+ if(lambdaS_local >= 0.80 * lambdaSmax) then
+ if ( myrank == 0 ) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ else
+ RGB_send(ispec) = 1
+ endif
+
+! display bad elements that are below 120% of the threshold in blue
+ else if(lambdaS_local <= 1.20 * lambdaSmin) then
+ if ( myrank == 0 ) then
+ write(24,*) '0 0 1 RG GF 0 setgray ST'
+ else
+ RGB_send(ispec) = 3
+ endif
+
+ else
+! do not color the elements if not close to the threshold
+ if ( myrank == 0 ) then
+ write(24,*) 'ST'
+ else
+ RGB_send(ispec) = 0
+ endif
+ endif
+
+ else
+! do not color the elements if S-wave velocity undefined
+ if ( myrank == 0 ) then
+ write(24,*) 'ST'
+ else
+ RGB_send(ispec) = 0
+ endif
+ endif
+
+! 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))
+
+! display very good elements that are above 80% of the threshold in red
+ if(lambdaPI_local >= 0.80 * lambdaPImax) then
+ if ( myrank == 0 ) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ else
+ RGB_send(ispec) = 1
+ endif
+
+! display bad elements that are below 120% of the threshold in blue
+ else if(lambdaPI_local <= 1.20 * lambdaPImin) then
+ if ( myrank == 0 ) then
+ write(24,*) '0 0 1 RG GF 0 setgray ST'
+ else
+ RGB_send(ispec) = 3
+ endif
+
+ else
+! do not color the elements if not close to the threshold
+ if ( myrank == 0 ) then
+ write(24,*) 'ST'
+ else
+ RGB_send(ispec) = 0
+ endif
+ endif
+
+ endif
+
+ enddo ! end of loop on all the spectral elements
+
+#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*5))
+ allocate(RGB_recv(nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ call MPI_RECV (RGB_recv(1), nspec_recv, MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ do ispec = 1, nspec_recv
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ write(24,*) 'mark'
+ write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
+ write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
+ write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
+ write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
+ write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
+ write(24,*) 'CO'
+ if ( RGB_recv(ispec) == 1) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ endif
+ if ( RGB_recv(ispec) == 3) then
+ write(24,*) '0 0 1 RG GF 0 setgray ST'
+ endif
+ if ( RGB_recv(ispec) == 0) then
+ write(24,*) 'ST'
+ endif
+
+ enddo
+ deallocate(coorg_recv)
+ deallocate(RGB_recv)
+
+ 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)
+
+ endif
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ write(IOUT,*) 'End of creation of PostScript file with mesh dispersion'
+
+ endif
+
+!
+!--------------------------------------------------------------------------------
+!
+
+ if (myrank == 0) then
+
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with velocity model'
+
+!
+!---- open PostScript file
+!
+ open(unit=24,file='OUTPUT_FILES/P_velocity_model.ps',status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Z axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ 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,*) '(P-velocity model \(dark = fast, light = slow\)) show'
+ write(24,*) 'grestore'
+ write(24,*) '25.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,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 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,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ num_ispec = 0
+endif
+
+ do ispec = 1, UPPER_LIMIT_DISPLAY
+ if ( myrank == 0 ) then
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ endif
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ if ( myrank == 0 ) then
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+ else
+ coorg_send(1,(ispec-1)*5+1) = x1
+ coorg_send(2,(ispec-1)*5+1) = z1
+ endif
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+2) = x2
+ coorg_send(2,(ispec-1)*5+2) = z2
+ endif
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+3) = x2
+ coorg_send(2,(ispec-1)*5+3) = z2
+ endif
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+4) = x2
+ coorg_send(2,(ispec-1)*5+4) = z2
+ endif
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ write(24,*) 'CO'
+ else
+ coorg_send(1,(ispec-1)*5+5) = x2
+ coorg_send(2,(ispec-1)*5+5) = z2
+ endif
+
+ if((vpImax-vpImin)/vpImin > 0.02d0) then
+ if(assign_external_model) then
+! use lower-left corner
+ x1 = (vpext(1,1,ispec)-vpImin) / (vpImax-vpImin)
+ else
+ material = kmato(ispec)
+ if(poroelastic(ispec)) then
+ phi = porosity(material)
+ tort = tortuosity(material)
+ perm = permeability(1,material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+ eta_f = poroelastcoef(2,2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+!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)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
+ tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIloc = sqrt(cpIsquare)
+ else
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ endif
+ x1 = (cpIloc-vpImin)/(vpImax-vpImin)
+ endif
+ else
+ x1 = 0.5d0
+ endif
+
+! rescale to avoid very dark gray levels
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+! invert scale: white = vpmin, dark gray = vpmax
+ x1 = 1.d0 - x1
+
+! display P-velocity model using gray levels
+ if ( myrank == 0 ) then
+ write(24,*) sngl(x1),' setgray GF 0 setgray ST'
+ else
+ greyscale_send(ispec) = sngl(x1)
+ endif
+ enddo ! end of loop on all the spectral elements
+
+#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*5))
+ allocate(greyscale_recv(nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ call MPI_RECV (greyscale_recv(1), nspec_recv, MPI_REAL, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ do ispec = 1, nspec_recv
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ write(24,*) 'mark'
+ write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
+ write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
+ write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
+ write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
+ write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
+ write(24,*) 'CO'
+ write(24,*) greyscale_recv(ispec), ' setgray GF 0 setgray ST'
+
+ enddo
+ deallocate(coorg_recv)
+ deallocate(greyscale_recv)
+
+ enddo
+
+ else
+ 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
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ write(IOUT,*) 'End of creation of PostScript file with velocity model'
+
+ endif
+
+ if (myrank == 0) then
+
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with mesh partitioning'
+
+!
+!---- open PostScript file
+!
+ open(unit=24,file='OUTPUT_FILES/mesh_partitioning.ps',status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Z axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(Mesh partitioning) show'
+ write(24,*) 'grestore'
+ write(24,*) '25.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,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 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,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ num_ispec = 0
+ endif
+
+ do ispec = 1, UPPER_LIMIT_DISPLAY
+
+ if ( myrank == 0 ) then
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ endif
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ if ( myrank == 0 ) then
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+ else
+ coorg_send(1,(ispec-1)*5+1) = x1
+ coorg_send(2,(ispec-1)*5+1) = z1
+ endif
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+2) = x2
+ coorg_send(2,(ispec-1)*5+2) = z2
+ endif
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+3) = x2
+ coorg_send(2,(ispec-1)*5+3) = z2
+ endif
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+4) = x2
+ coorg_send(2,(ispec-1)*5+4) = z2
+ endif
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ write(24,*) 'CO'
+ else
+ coorg_send(1,(ispec-1)*5+5) = x2
+ coorg_send(2,(ispec-1)*5+5) = z2
+ endif
+
+ if ( myrank == 0 ) then
+ write(24,*) red(1), green(1), blue(1), 'RG GF 0 setgray ST'
+ endif
+
+ enddo ! end of loop on all the spectral elements
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+
+! use a different color for each material set
+ icol = mod(iproc, NUM_COLORS) + 1
+
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ allocate(coorg_recv(2,nspec_recv*5))
+ call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ do ispec = 1, nspec_recv
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ write(24,*) 'mark'
+ write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
+ write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
+ write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
+ write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
+ write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
+ write(24,*) 'CO'
+
+ write(24,*) red(icol), green(icol), blue(icol), ' RG GF 0 setgray ST'
+
+ enddo
+ deallocate(coorg_recv)
+
+ enddo
+
+ else
+ 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)
+
+ endif
+#endif
+
+ if (myrank == 0) then
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ write(IOUT,*) 'End of creation of PostScript file with partitioning'
+ write(IOUT,*)
+ endif
+
+ 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a100,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
+
+ 681 format(f6.2,1x,f6.2)
+
+ end subroutine checkgrid
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine checkgrid_setup_GLLper(percent_GLL,NGLLX_MAX_STABILITY)
+
+ implicit none
+ include "constants.h"
+
+ integer :: NGLLX_MAX_STABILITY
+ double precision :: percent_GLL(NGLLX_MAX_STABILITY)
+
+ if( NGLLX_MAX_STABILITY /= 15 ) call exit_MPI('check NGLLX_MAX_STABILITY in checkgrid.f90')
+
+! 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
+ percent_GLL(3) = 50.d0
+ percent_GLL(4) = 27.639320225002102d0
+ percent_GLL(5) = 17.267316464601141d0
+ percent_GLL(6) = 11.747233803526763d0
+ percent_GLL(7) = 8.4888051860716516d0
+ percent_GLL(8) = 6.4129925745196719d0
+ percent_GLL(9) = 5.0121002294269914d0
+ percent_GLL(10) = 4.0233045916770571d0
+ percent_GLL(11) = 3.2999284795970416d0
+ percent_GLL(12) = 2.7550363888558858d0
+ percent_GLL(13) = 2.3345076678918053d0
+ percent_GLL(14) = 2.0032477366369594d0
+ percent_GLL(15) = 1.7377036748080721d0
+
+! convert to real percentage
+ percent_GLL(:) = percent_GLL(:) / 100.d0
+
+ if(NGLLX > NGLLX_MAX_STABILITY) then
+ call exit_MPI('cannot estimate the stability condition for that degree')
+ endif
+
+ end subroutine checkgrid_setup_GLLper
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine checkgrid_setup_colorp(red,green,blue,NUM_COLORS)
+
+! color palette
+
+ implicit none
+ integer :: NUM_COLORS
+ double precision, dimension(NUM_COLORS) :: red,green,blue
+
+ if( NUM_COLORS /= 236 ) call exit_MPI('check NUM_COLORS in checkgrid.f90')
+
+! red
+ red(1) = 1.00000000000000
+ green(1) = 0.000000000000000E+000
+ blue(1) = 0.000000000000000E+000
+
+! DodgerBlue2
+ red(2) = 0.109803921568627
+ green(2) = 0.525490196078431
+ blue(2) = 0.933333333333333
+
+! gold
+ red(3) = 1.00000000000000
+ green(3) = 0.840000000000000
+ blue(3) = 0.000000000000000E+000
+
+! springgreen
+ red(4) = 0.000000000000000E+000
+ green(4) = 1.00000000000000
+ blue(4) = 0.500000000000000
+
+! NavajoWhite
+ red(5) = 1.00000000000000
+ green(5) = 0.870588235294118
+ blue(5) = 0.678431372549020
+
+! SteelBlue3
+ red(6) = 0.309803921568627
+ green(6) = 0.580392156862745
+ blue(6) = 0.803921568627451
+
+! Ivory3
+ red(7) = 0.803921568627451
+ green(7) = 0.803921568627451
+ blue(7) = 0.756862745098039
+
+! SkyBlue4
+ red(8) = 0.290196078431373
+ green(8) = 0.439215686274510
+ blue(8) = 0.545098039215686
+
+! Snow
+ red(9) = 0.980392156862745
+ green(9) = 0.980392156862745
+ blue(9) = 0.980392156862745
+
+! SteelBlue
+ red(10) = 0.274509803921569
+ green(10) = 0.509803921568627
+ blue(10) = 0.705882352941177
+
+! Bisque3
+ red(11) = 0.803921568627451
+ green(11) = 0.717647058823529
+ blue(11) = 0.619607843137255
+
+! Salmon
+ red(12) = 0.980392156862745
+ green(12) = 0.501960784313725
+ blue(12) = 0.447058823529412
+
+! SlateBlue2
+ red(13) = 0.478431372549020
+ green(13) = 0.403921568627451
+ blue(13) = 0.933333333333333
+
+! NavajoWhite2
+ red(14) = 0.933333333333333
+ green(14) = 0.811764705882353
+ blue(14) = 0.631372549019608
+
+! MediumBlue
+ red(15) = 0.000000000000000E+000
+ green(15) = 0.000000000000000E+000
+ blue(15) = 0.803921568627451
+
+! LightCoral
+ red(16) = 0.941176470588235
+ green(16) = 0.501960784313725
+ blue(16) = 0.501960784313725
+
+! FloralWhite
+ red(17) = 1.00000000000000
+ green(17) = 0.980392156862745
+ blue(17) = 0.941176470588235
+
+! Cornsilk3
+ red(18) = 0.803921568627451
+ green(18) = 0.784313725490196
+ blue(18) = 0.694117647058824
+
+! GhostWhite
+ red(19) = 0.972549019607843
+ green(19) = 0.972549019607843
+ blue(19) = 1.00000000000000
+
+! blue
+ red(20) = 0.000000000000000E+000
+ green(20) = 0.000000000000000E+000
+ blue(20) = 1.00000000000000
+
+! Linen
+ red(21) = 0.980392156862745
+ green(21) = 0.941176470588235
+ blue(21) = 0.901960784313726
+
+! peachpuff
+ red(22) = 1.00000000000000
+ green(22) = 0.850000000000000
+ blue(22) = 0.730000000000000
+
+! Cornsilk1
+ red(23) = 1.00000000000000
+ green(23) = 0.972549019607843
+ blue(23) = 0.862745098039216
+
+! LightSalmon
+ red(24) = 1.00000000000000
+ green(24) = 0.627450980392157
+ blue(24) = 0.478431372549020
+
+! DeepSkyBlue1
+ red(25) = 0.000000000000000E+000
+ green(25) = 0.749019607843137
+ blue(25) = 1.00000000000000
+
+! LemonChiffon4
+ red(26) = 0.545098039215686
+ green(26) = 0.537254901960784
+ blue(26) = 0.439215686274510
+
+! PeachPuff1
+ red(27) = 1.00000000000000
+ green(27) = 0.854901960784314
+ blue(27) = 0.725490196078431
+
+! BlanchedAlmond
+ red(28) = 1.00000000000000
+ green(28) = 0.921568627450980
+ blue(28) = 0.803921568627451
+
+! SlateBlue3
+ red(29) = 0.411764705882353
+ green(29) = 0.349019607843137
+ blue(29) = 0.803921568627451
+
+! LightSkyBlue1
+ red(30) = 0.690196078431373
+ green(30) = 0.886274509803922
+ blue(30) = 1.00000000000000
+
+! DarkViolet
+ red(31) = 0.580392156862745
+ green(31) = 0.000000000000000E+000
+ blue(31) = 0.827450980392157
+
+! Azure3
+ red(32) = 0.756862745098039
+ green(32) = 0.803921568627451
+ blue(32) = 0.803921568627451
+
+! LavenderBlush3
+ red(33) = 0.803921568627451
+ green(33) = 0.756862745098039
+ blue(33) = 0.772549019607843
+
+! Honeydew1
+ red(34) = 0.941176470588235
+ green(34) = 1.00000000000000
+ blue(34) = 0.941176470588235
+
+! Ivory2
+ red(35) = 0.933333333333333
+ green(35) = 0.933333333333333
+ blue(35) = 0.878431372549020
+
+! RosyBrown
+ red(36) = 0.737254901960784
+ green(36) = 0.560784313725490
+ blue(36) = 0.560784313725490
+
+! Thistle
+ red(37) = 0.847058823529412
+ green(37) = 0.749019607843137
+ blue(37) = 0.847058823529412
+
+! Orange
+ red(38) = 1.00000000000000
+ green(38) = 0.647058823529412
+ blue(38) = 0.000000000000000E+000
+
+! DarkSeaGreen
+ red(39) = 0.560784313725490
+ green(39) = 0.737254901960784
+ blue(39) = 0.560784313725490
+
+! Moccasin
+ red(40) = 1.00000000000000
+ green(40) = 0.894117647058824
+ blue(40) = 0.709803921568627
+
+! DeepSkyBlue2
+ red(41) = 0.000000000000000E+000
+ green(41) = 0.698039215686274
+ blue(41) = 0.933333333333333
+
+! SlateGray4
+ red(42) = 0.423529411764706
+ green(42) = 0.482352941176471
+ blue(42) = 0.545098039215686
+
+! Beige
+ red(43) = 0.960784313725490
+ green(43) = 0.960784313725490
+ blue(43) = 0.862745098039216
+
+! Gold
+ red(44) = 1.00000000000000
+ green(44) = 0.843137254901961
+ blue(44) = 0.000000000000000E+000
+
+! SlateBlue
+ red(45) = 0.415686274509804
+ green(45) = 0.352941176470588
+ blue(45) = 0.803921568627451
+
+! SteelBlue1
+ red(46) = 0.388235294117647
+ green(46) = 0.721568627450980
+ blue(46) = 1.00000000000000
+
+! SaddleBrown
+ red(47) = 0.545098039215686
+ green(47) = 0.270588235294118
+ blue(47) = 7.450980392156863E-002
+
+! Pink
+ red(48) = 1.00000000000000
+ green(48) = 0.752941176470588
+ blue(48) = 0.796078431372549
+
+! Black
+ red(49) = 0.000000000000000E+000
+ green(49) = 0.000000000000000E+000
+ blue(49) = 0.000000000000000E+000
+
+! SlateGrey
+ red(50) = 0.439215686274510
+ green(50) = 0.501960784313725
+ blue(50) = 0.564705882352941
+
+! Ivory
+ red(51) = 1.00000000000000
+ green(51) = 1.00000000000000
+ blue(51) = 0.941176470588235
+
+! OliveDrab
+ red(52) = 0.419607843137255
+ green(52) = 0.556862745098039
+ blue(52) = 0.137254901960784
+
+! Ivory1
+ red(53) = 1.00000000000000
+ green(53) = 1.00000000000000
+ blue(53) = 0.941176470588235
+
+! SkyBlue
+ red(54) = 0.529411764705882
+ green(54) = 0.807843137254902
+ blue(54) = 0.921568627450980
+
+! MistyRose3
+ red(55) = 0.803921568627451
+ green(55) = 0.717647058823529
+ blue(55) = 0.709803921568627
+
+! LimeGreen
+ red(56) = 0.196078431372549
+ green(56) = 0.803921568627451
+ blue(56) = 0.196078431372549
+
+! Purple
+ red(57) = 0.627450980392157
+ green(57) = 0.125490196078431
+ blue(57) = 0.941176470588235
+
+! SkyBlue2
+ red(58) = 0.494117647058824
+ green(58) = 0.752941176470588
+ blue(58) = 0.933333333333333
+
+! Red
+ red(59) = 1.00000000000000
+ green(59) = 0.000000000000000E+000
+ blue(59) = 0.000000000000000E+000
+
+! DarkKhaki
+ red(60) = 0.741176470588235
+ green(60) = 0.717647058823529
+ blue(60) = 0.419607843137255
+
+! MediumTurquoise
+ red(61) = 0.282352941176471
+ green(61) = 0.819607843137255
+ blue(61) = 0.800000000000000
+
+! Grey
+ red(62) = 0.745098039215686
+ green(62) = 0.745098039215686
+ blue(62) = 0.745098039215686
+
+! Coral
+ red(63) = 1.00000000000000
+ green(63) = 0.498039215686275
+ blue(63) = 0.313725490196078
+
+! NavajoWhite4
+ red(64) = 0.545098039215686
+ green(64) = 0.474509803921569
+ blue(64) = 0.368627450980392
+
+! SlateBlue4
+ red(65) = 0.278431372549020
+ green(65) = 0.235294117647059
+ blue(65) = 0.545098039215686
+
+! RoyalBlue4
+ red(66) = 0.152941176470588
+ green(66) = 0.250980392156863
+ blue(66) = 0.545098039215686
+
+! YellowGreen
+ red(67) = 0.603921568627451
+ green(67) = 0.803921568627451
+ blue(67) = 0.196078431372549
+
+! DeepSkyBlue3
+ red(68) = 0.000000000000000E+000
+ green(68) = 0.603921568627451
+ blue(68) = 0.803921568627451
+
+! goldenrod
+ red(69) = 0.854901960784314
+ green(69) = 0.647058823529412
+ blue(69) = 0.125490196078431
+
+! AntiqueWhite4
+ red(70) = 0.545098039215686
+ green(70) = 0.513725490196078
+ blue(70) = 0.470588235294118
+
+! lemonchiffon
+ red(71) = 1.00000000000000
+ green(71) = 0.980000000000000
+ blue(71) = 0.800000000000000
+
+! GreenYellow
+ red(72) = 0.678431372549020
+ green(72) = 1.00000000000000
+ blue(72) = 0.184313725490196
+
+! LightSlateGray
+ red(73) = 0.466666666666667
+ green(73) = 0.533333333333333
+ blue(73) = 0.600000000000000
+
+! RoyalBlue
+ red(74) = 0.254901960784314
+ green(74) = 0.411764705882353
+ blue(74) = 0.882352941176471
+
+! DarkGreen
+ red(75) = 0.000000000000000E+000
+ green(75) = 0.392156862745098
+ blue(75) = 0.000000000000000E+000
+
+! NavajoWhite3
+ red(76) = 0.803921568627451
+ green(76) = 0.701960784313725
+ blue(76) = 0.545098039215686
+
+! Azure1
+ red(77) = 0.941176470588235
+ green(77) = 1.00000000000000
+ blue(77) = 1.00000000000000
+
+! PowderBlue
+ red(78) = 0.690196078431373
+ green(78) = 0.878431372549020
+ blue(78) = 0.901960784313726
+
+! slateblue
+ red(79) = 0.420000000000000
+ green(79) = 0.350000000000000
+ blue(79) = 0.800000000000000
+
+! MediumOrchid
+ red(80) = 0.729411764705882
+ green(80) = 0.333333333333333
+ blue(80) = 0.827450980392157
+
+! turquoise
+ red(81) = 0.250000000000000
+ green(81) = 0.880000000000000
+ blue(81) = 0.820000000000000
+
+! Snow1
+ red(82) = 1.00000000000000
+ green(82) = 0.980392156862745
+ blue(82) = 0.980392156862745
+
+! violet
+ red(83) = 0.930000000000000
+ green(83) = 0.510000000000000
+ blue(83) = 0.930000000000000
+
+! DeepPink
+ red(84) = 1.00000000000000
+ green(84) = 7.843137254901961E-002
+ blue(84) = 0.576470588235294
+
+! MistyRose4
+ red(85) = 0.545098039215686
+ green(85) = 0.490196078431373
+ blue(85) = 0.482352941176471
+
+! PeachPuff3
+ red(86) = 0.803921568627451
+ green(86) = 0.686274509803922
+ blue(86) = 0.584313725490196
+
+! MediumSeaGreen
+ red(87) = 0.235294117647059
+ green(87) = 0.701960784313725
+ blue(87) = 0.443137254901961
+
+! Honeydew4
+ red(88) = 0.513725490196078
+ green(88) = 0.545098039215686
+ blue(88) = 0.513725490196078
+
+! Tan
+ red(89) = 0.823529411764706
+ green(89) = 0.705882352941177
+ blue(89) = 0.549019607843137
+
+! DarkGoldenrod
+ red(90) = 0.721568627450980
+ green(90) = 0.525490196078431
+ blue(90) = 4.313725490196078E-002
+
+! Blue2
+ red(91) = 0.000000000000000E+000
+ green(91) = 0.000000000000000E+000
+ blue(91) = 0.933333333333333
+
+! Maroon
+ red(92) = 0.690196078431373
+ green(92) = 0.188235294117647
+ blue(92) = 0.376470588235294
+
+! LightSkyBlue3
+ red(93) = 0.552941176470588
+ green(93) = 0.713725490196078
+ blue(93) = 0.803921568627451
+
+! LemonChiffon2
+ red(94) = 0.933333333333333
+ green(94) = 0.913725490196078
+ blue(94) = 0.749019607843137
+
+! Snow3
+ red(95) = 0.803921568627451
+ green(95) = 0.788235294117647
+ blue(95) = 0.788235294117647
+
+! Ivory4
+ red(96) = 0.545098039215686
+ green(96) = 0.545098039215686
+ blue(96) = 0.513725490196078
+
+! AntiqueWhite3
+ red(97) = 0.803921568627451
+ green(97) = 0.752941176470588
+ blue(97) = 0.690196078431373
+
+! Bisque4
+ red(98) = 0.545098039215686
+ green(98) = 0.490196078431373
+ blue(98) = 0.419607843137255
+
+! Snow2
+ red(99) = 0.933333333333333
+ green(99) = 0.913725490196078
+ blue(99) = 0.913725490196078
+
+! SlateGray1
+ red(100) = 0.776470588235294
+ green(100) = 0.886274509803922
+ blue(100) = 1.00000000000000
+
+! Seashell2
+ red(101) = 0.933333333333333
+ green(101) = 0.898039215686275
+ blue(101) = 0.870588235294118
+
+! Aquamarine
+ red(102) = 0.498039215686275
+ green(102) = 1.00000000000000
+ blue(102) = 0.831372549019608
+
+! SlateGray2
+ red(103) = 0.725490196078431
+ green(103) = 0.827450980392157
+ blue(103) = 0.933333333333333
+
+! White
+ red(104) = 1.00000000000000
+ green(104) = 1.00000000000000
+ blue(104) = 1.00000000000000
+
+! LavenderBlush
+ red(105) = 1.00000000000000
+ green(105) = 0.941176470588235
+ blue(105) = 0.960784313725490
+
+! DodgerBlue3
+ red(106) = 9.411764705882353E-002
+ green(106) = 0.454901960784314
+ blue(106) = 0.803921568627451
+
+! RoyalBlue3
+ red(107) = 0.227450980392157
+ green(107) = 0.372549019607843
+ blue(107) = 0.803921568627451
+
+! LightYellow
+ red(108) = 1.00000000000000
+ green(108) = 1.00000000000000
+ blue(108) = 0.878431372549020
+
+! DeepSkyBlue
+ red(109) = 0.000000000000000E+000
+ green(109) = 0.749019607843137
+ blue(109) = 1.00000000000000
+
+! AntiqueWhite2
+ red(110) = 0.933333333333333
+ green(110) = 0.874509803921569
+ blue(110) = 0.800000000000000
+
+! CornflowerBlue
+ red(111) = 0.392156862745098
+ green(111) = 0.584313725490196
+ blue(111) = 0.929411764705882
+
+! PeachPuff4
+ red(112) = 0.545098039215686
+ green(112) = 0.466666666666667
+ blue(112) = 0.396078431372549
+
+! SpringGreen
+ red(113) = 0.000000000000000E+000
+ green(113) = 1.00000000000000
+ blue(113) = 0.498039215686275
+
+! Honeydew
+ red(114) = 0.941176470588235
+ green(114) = 1.00000000000000
+ blue(114) = 0.941176470588235
+
+! Honeydew2
+ red(115) = 0.878431372549020
+ green(115) = 0.933333333333333
+ blue(115) = 0.878431372549020
+
+! LightSeaGreen
+ red(116) = 0.125490196078431
+ green(116) = 0.698039215686274
+ blue(116) = 0.666666666666667
+
+! NavyBlue
+ red(117) = 0.000000000000000E+000
+ green(117) = 0.000000000000000E+000
+ blue(117) = 0.501960784313725
+
+! Azure4
+ red(118) = 0.513725490196078
+ green(118) = 0.545098039215686
+ blue(118) = 0.545098039215686
+
+! MediumAquamarine
+ red(119) = 0.400000000000000
+ green(119) = 0.803921568627451
+ blue(119) = 0.666666666666667
+
+! SkyBlue3
+ red(120) = 0.423529411764706
+ green(120) = 0.650980392156863
+ blue(120) = 0.803921568627451
+
+! LavenderBlush2
+ red(121) = 0.933333333333333
+ green(121) = 0.878431372549020
+ blue(121) = 0.898039215686275
+
+! Bisque1
+ red(122) = 1.00000000000000
+ green(122) = 0.894117647058824
+ blue(122) = 0.768627450980392
+
+! DarkOrange
+ red(123) = 1.00000000000000
+ green(123) = 0.549019607843137
+ blue(123) = 0.000000000000000E+000
+
+! LightSteelBlue
+ red(124) = 0.690196078431373
+ green(124) = 0.768627450980392
+ blue(124) = 0.870588235294118
+
+! SteelBlue2
+ red(125) = 0.360784313725490
+ green(125) = 0.674509803921569
+ blue(125) = 0.933333333333333
+
+! LemonChiffon3
+ red(126) = 0.803921568627451
+ green(126) = 0.788235294117647
+ blue(126) = 0.647058823529412
+
+! DarkSlateBlue
+ red(127) = 0.282352941176471
+ green(127) = 0.239215686274510
+ blue(127) = 0.545098039215686
+
+! Seashell
+ red(128) = 1.00000000000000
+ green(128) = 0.960784313725490
+ blue(128) = 0.933333333333333
+
+! Firebrick
+ red(129) = 0.698039215686274
+ green(129) = 0.133333333333333
+ blue(129) = 0.133333333333333
+
+! LightGray
+ red(130) = 0.827450980392157
+ green(130) = 0.827450980392157
+ blue(130) = 0.827450980392157
+
+! Blue
+ red(131) = 0.000000000000000E+000
+ green(131) = 0.000000000000000E+000
+ blue(131) = 1.00000000000000
+
+! Bisque2
+ red(132) = 0.933333333333333
+ green(132) = 0.835294117647059
+ blue(132) = 0.717647058823529
+
+! WhiteSmoke
+ red(133) = 0.960784313725490
+ green(133) = 0.960784313725490
+ blue(133) = 0.960784313725490
+
+! SeaGreen
+ red(134) = 0.180392156862745
+ green(134) = 0.545098039215686
+ blue(134) = 0.341176470588235
+
+! Burlywood
+ red(135) = 0.870588235294118
+ green(135) = 0.721568627450980
+ blue(135) = 0.529411764705882
+
+! RoyalBlue2
+ red(136) = 0.262745098039216
+ green(136) = 0.431372549019608
+ blue(136) = 0.933333333333333
+
+! RoyalBlue1
+ red(137) = 0.282352941176471
+ green(137) = 0.462745098039216
+ blue(137) = 1.00000000000000
+
+! SteelBlue4
+ red(138) = 0.211764705882353
+ green(138) = 0.392156862745098
+ blue(138) = 0.545098039215686
+
+! AliceBlue
+ red(139) = 0.941176470588235
+ green(139) = 0.972549019607843
+ blue(139) = 1.00000000000000
+
+! LightSlateBlue
+ red(140) = 0.517647058823529
+ green(140) = 0.439215686274510
+ blue(140) = 1.00000000000000
+
+! MistyRose1
+ red(141) = 1.00000000000000
+ green(141) = 0.894117647058824
+ blue(141) = 0.882352941176471
+
+! SandyBrown
+ red(142) = 0.956862745098039
+ green(142) = 0.643137254901961
+ blue(142) = 0.376470588235294
+
+! DarkOliveGreen
+ red(143) = 0.333333333333333
+ green(143) = 0.419607843137255
+ blue(143) = 0.184313725490196
+
+! Yellow
+ red(144) = 1.00000000000000
+ green(144) = 1.00000000000000
+ blue(144) = 0.000000000000000E+000
+
+! SlateGray3
+ red(145) = 0.623529411764706
+ green(145) = 0.713725490196078
+ blue(145) = 0.803921568627451
+
+! HotPink
+ red(146) = 1.00000000000000
+ green(146) = 0.411764705882353
+ blue(146) = 0.705882352941177
+
+! Violet
+ red(147) = 0.933333333333333
+ green(147) = 0.509803921568627
+ blue(147) = 0.933333333333333
+
+! LightSkyBlue
+ red(148) = 0.529411764705882
+ green(148) = 0.807843137254902
+ blue(148) = 0.980392156862745
+
+! Cornsilk2
+ red(149) = 0.933333333333333
+ green(149) = 0.909803921568627
+ blue(149) = 0.803921568627451
+
+! MidnightBlue
+ red(150) = 9.803921568627451E-002
+ green(150) = 9.803921568627451E-002
+ blue(150) = 0.439215686274510
+
+! AntiqueWhite
+ red(151) = 0.980392156862745
+ green(151) = 0.921568627450980
+ blue(151) = 0.843137254901961
+
+! PaleGreen
+ red(152) = 0.596078431372549
+ green(152) = 0.984313725490196
+ blue(152) = 0.596078431372549
+
+! MedSpringGreen
+ red(153) = 0.000000000000000E+000
+ green(153) = 0.980392156862745
+ blue(153) = 0.603921568627451
+
+! DodgerBlue1
+ red(154) = 0.117647058823529
+ green(154) = 0.564705882352941
+ blue(154) = 1.00000000000000
+
+! Blue3
+ red(155) = 0.000000000000000E+000
+ green(155) = 0.000000000000000E+000
+ blue(155) = 0.803921568627451
+
+! Cyan
+ red(156) = 0.000000000000000E+000
+ green(156) = 1.00000000000000
+ blue(156) = 1.00000000000000
+
+! LemonChiffon
+ red(157) = 1.00000000000000
+ green(157) = 0.980392156862745
+ blue(157) = 0.803921568627451
+
+! mediumorchid
+ red(158) = 0.730000000000000
+ green(158) = 0.330000000000000
+ blue(158) = 0.830000000000000
+
+! Turquoise
+ red(159) = 0.250980392156863
+ green(159) = 0.878431372549020
+ blue(159) = 0.815686274509804
+
+! IndianRed
+ red(160) = 0.803921568627451
+ green(160) = 0.360784313725490
+ blue(160) = 0.360784313725490
+
+! DodgerBlue
+ red(161) = 0.117647058823529
+ green(161) = 0.564705882352941
+ blue(161) = 1.00000000000000
+
+! Seashell3
+ red(162) = 0.803921568627451
+ green(162) = 0.772549019607843
+ blue(162) = 0.749019607843137
+
+! BlueViolet
+ red(163) = 0.541176470588235
+ green(163) = 0.168627450980392
+ blue(163) = 0.886274509803922
+
+! DeepSkyBlue4
+ red(164) = 0.000000000000000E+000
+ green(164) = 0.407843137254902
+ blue(164) = 0.545098039215686
+
+! PaleVioletRed
+ red(165) = 0.858823529411765
+ green(165) = 0.439215686274510
+ blue(165) = 0.576470588235294
+
+! Azure2
+ red(166) = 0.878431372549020
+ green(166) = 0.933333333333333
+ blue(166) = 0.933333333333333
+
+! greenyellow
+ red(167) = 0.680000000000000
+ green(167) = 1.00000000000000
+ blue(167) = 0.180000000000000
+
+! LightGoldenrod
+ red(168) = 0.933333333333333
+ green(168) = 0.866666666666667
+ blue(168) = 0.509803921568627
+
+! MistyRose
+ red(169) = 1.00000000000000
+ green(169) = 0.894117647058824
+ blue(169) = 0.882352941176471
+
+! LightSkyBlue4
+ red(170) = 0.376470588235294
+ green(170) = 0.482352941176471
+ blue(170) = 0.545098039215686
+
+! OrangeRed
+ red(171) = 1.00000000000000
+ green(171) = 0.270588235294118
+ blue(171) = 0.000000000000000E+000
+
+! DimGrey
+ red(172) = 0.411764705882353
+ green(172) = 0.411764705882353
+ blue(172) = 0.411764705882353
+
+! MediumVioletRed
+ red(173) = 0.780392156862745
+ green(173) = 8.235294117647059E-002
+ blue(173) = 0.521568627450980
+
+! DarkSlateGray
+ red(174) = 0.184313725490196
+ green(174) = 0.309803921568627
+ blue(174) = 0.309803921568627
+
+! yellow
+ red(175) = 1.00000000000000
+ green(175) = 1.00000000000000
+ blue(175) = 0.000000000000000E+000
+
+! Plum
+ red(176) = 0.866666666666667
+ green(176) = 0.627450980392157
+ blue(176) = 0.866666666666667
+
+! DarkTurquoise
+ red(177) = 0.000000000000000E+000
+ green(177) = 0.807843137254902
+ blue(177) = 0.819607843137255
+
+! DodgerBlue4
+ red(178) = 6.274509803921569E-002
+ green(178) = 0.305882352941176
+ blue(178) = 0.545098039215686
+
+! Cornsilk
+ red(179) = 1.00000000000000
+ green(179) = 0.972549019607843
+ blue(179) = 0.862745098039216
+
+! SkyBlue1
+ red(180) = 0.529411764705882
+ green(180) = 0.807843137254902
+ blue(180) = 1.00000000000000
+
+! Seashell1
+ red(181) = 1.00000000000000
+ green(181) = 0.960784313725490
+ blue(181) = 0.933333333333333
+
+! lavender
+ red(182) = 0.901960784313726
+ green(182) = 0.901960784313726
+ blue(182) = 0.980392156862745
+
+! Snow4
+ red(183) = 0.545098039215686
+ green(183) = 0.537254901960784
+ blue(183) = 0.537254901960784
+
+! Peru
+ red(184) = 0.803921568627451
+ green(184) = 0.521568627450980
+ blue(184) = 0.247058823529412
+
+! PeachPuff
+ red(185) = 1.00000000000000
+ green(185) = 0.854901960784314
+ blue(185) = 0.725490196078431
+
+! Green
+ red(186) = 0.000000000000000E+000
+ green(186) = 1.00000000000000
+ blue(186) = 0.000000000000000E+000
+
+! Blue1
+ red(187) = 0.000000000000000E+000
+ green(187) = 0.000000000000000E+000
+ blue(187) = 1.00000000000000
+
+! Seashell4
+ red(188) = 0.545098039215686
+ green(188) = 0.525490196078431
+ blue(188) = 0.509803921568627
+
+! dodgerblue
+ red(189) = 0.120000000000000
+ green(189) = 0.560000000000000
+ blue(189) = 1.00000000000000
+
+! MistyRose2
+ red(190) = 0.933333333333333
+ green(190) = 0.835294117647059
+ blue(190) = 0.823529411764706
+
+! Tomato
+ red(191) = 1.00000000000000
+ green(191) = 0.388235294117647
+ blue(191) = 0.278431372549020
+
+! Wheat
+ red(192) = 0.960784313725490
+ green(192) = 0.870588235294118
+ blue(192) = 0.701960784313725
+
+! LightBlue
+ red(193) = 0.678431372549020
+ green(193) = 0.847058823529412
+ blue(193) = 0.901960784313726
+
+! Chocolate
+ red(194) = 0.823529411764706
+ green(194) = 0.411764705882353
+ blue(194) = 0.117647058823529
+
+! Blue4
+ red(195) = 0.000000000000000E+000
+ green(195) = 0.000000000000000E+000
+ blue(195) = 0.545098039215686
+
+! LavenderBlush1
+ red(196) = 1.00000000000000
+ green(196) = 0.941176470588235
+ blue(196) = 0.960784313725490
+
+! Magenta
+ red(197) = 1.00000000000000
+ green(197) = 0.000000000000000E+000
+ blue(197) = 1.00000000000000
+
+! darkturquoise
+ red(198) = 0.000000000000000E+000
+ green(198) = 0.810000000000000
+ blue(198) = 0.820000000000000
+
+! blueviolet
+ red(199) = 0.540000000000000
+ green(199) = 0.170000000000000
+ blue(199) = 0.890000000000000
+
+! MintCream
+ red(200) = 0.960784313725490
+ green(200) = 1.00000000000000
+ blue(200) = 0.980392156862745
+
+! PaleGoldenrod
+ red(201) = 0.933333333333333
+ green(201) = 0.909803921568627
+ blue(201) = 0.666666666666667
+
+! MediumPurple
+ red(202) = 0.576470588235294
+ green(202) = 0.439215686274510
+ blue(202) = 0.858823529411765
+
+! PapayaWhip
+ red(203) = 1.00000000000000
+ green(203) = 0.937254901960784
+ blue(203) = 0.835294117647059
+
+! LavenderBlush4
+ red(204) = 0.545098039215686
+ green(204) = 0.513725490196078
+ blue(204) = 0.525490196078431
+
+! Cornsilk4
+ red(205) = 0.545098039215686
+ green(205) = 0.533333333333333
+ blue(205) = 0.470588235294118
+
+! LtGoldenrodYello
+ red(206) = 0.980392156862745
+ green(206) = 0.980392156862745
+ blue(206) = 0.823529411764706
+
+! limegreen
+ red(207) = 0.200000000000000
+ green(207) = 0.800000000000000
+ blue(207) = 0.200000000000000
+
+! LemonChiffon1
+ red(208) = 1.00000000000000
+ green(208) = 0.980392156862745
+ blue(208) = 0.803921568627451
+
+! DarkOrchid
+ red(209) = 0.600000000000000
+ green(209) = 0.196078431372549
+ blue(209) = 0.800000000000000
+
+! SlateBlue1
+ red(210) = 0.513725490196078
+ green(210) = 0.435294117647059
+ blue(210) = 1.00000000000000
+
+! chartreuse
+ red(211) = 0.500000000000000
+ green(211) = 1.00000000000000
+ blue(211) = 0.000000000000000E+000
+
+! PaleTurquoise
+ red(212) = 0.686274509803922
+ green(212) = 0.933333333333333
+ blue(212) = 0.933333333333333
+
+! NavajoWhite1
+ red(213) = 1.00000000000000
+ green(213) = 0.870588235294118
+ blue(213) = 0.678431372549020
+
+! LightSkyBlue2
+ red(214) = 0.643137254901961
+ green(214) = 0.827450980392157
+ blue(214) = 0.933333333333333
+
+! VioletRed
+ red(215) = 0.815686274509804
+ green(215) = 0.125490196078431
+ blue(215) = 0.564705882352941
+
+! mocassin
+ red(216) = 1.00000000000000
+ green(216) = 0.890000000000000
+ blue(216) = 0.710000000000000
+
+! OldLace
+ red(217) = 0.992156862745098
+ green(217) = 0.960784313725490
+ blue(217) = 0.901960784313726
+
+! deeppink
+ red(218) = 1.00000000000000
+ green(218) = 8.000000000000000E-002
+ blue(218) = 0.580000000000000
+
+! Honeydew3
+ red(219) = 0.756862745098039
+ green(219) = 0.803921568627451
+ blue(219) = 0.756862745098039
+
+! Gainsboro
+ red(220) = 0.862745098039216
+ green(220) = 0.862745098039216
+ blue(220) = 0.862745098039216
+
+! DarkSalmon
+ red(221) = 0.913725490196078
+ green(221) = 0.588235294117647
+ blue(221) = 0.478431372549020
+
+! AntiqueWhite1
+ red(222) = 1.00000000000000
+ green(222) = 0.937254901960784
+ blue(222) = 0.858823529411765
+
+! LightCyan
+ red(223) = 0.878431372549020
+ green(223) = 1.00000000000000
+ blue(223) = 1.00000000000000
+
+! ForestGreen
+ red(224) = 0.133333333333333
+ green(224) = 0.545098039215686
+ blue(224) = 0.133333333333333
+
+! Orchid
+ red(225) = 0.854901960784314
+ green(225) = 0.439215686274510
+ blue(225) = 0.839215686274510
+
+! PeachPuff2
+ red(226) = 0.933333333333333
+ green(226) = 0.796078431372549
+ blue(226) = 0.678431372549020
+
+! LightPink
+ red(227) = 1.00000000000000
+ green(227) = 0.713725490196078
+ blue(227) = 0.756862745098039
+
+! Sienna
+ red(228) = 0.627450980392157
+ green(228) = 0.321568627450980
+ blue(228) = 0.176470588235294
+
+! darkorchid
+ red(229) = 0.600000000000000
+ green(229) = 0.200000000000000
+ blue(229) = 0.800000000000000
+
+! MediumSlateBlue
+ red(230) = 0.482352941176471
+ green(230) = 0.407843137254902
+ blue(230) = 0.933333333333333
+
+! CadetBlue
+ red(231) = 0.372549019607843
+ green(231) = 0.619607843137255
+ blue(231) = 0.627450980392157
+
+! LawnGreen
+ red(232) = 0.486274509803922
+ green(232) = 0.988235294117647
+ blue(232) = 0.000000000000000E+000
+
+! Chartreuse
+ red(233) = 0.498039215686275
+ green(233) = 1.00000000000000
+ blue(233) = 0.000000000000000E+000
+
+! Brown
+ red(234) = 0.647058823529412
+ green(234) = 0.164705882352941
+ blue(234) = 0.164705882352941
+
+! Azure
+ red(235) = 0.941176470588235
+ green(235) = 1.00000000000000
+ blue(235) = 1.00000000000000
+
+! Bisque
+ red(236) = 1.00000000000000
+ green(236) = 0.894117647058824
+ blue(236) = 0.768627450980392
+
+ end subroutine checkgrid_setup_colorp
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_Bielak_conditions.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_Bielak_conditions.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_Bielak_conditions.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_Bielak_conditions.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,237 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! compute analytical initial plane wave for Bielak's conditions
+
+subroutine 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)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: iglob,npoin,it
+
+ double precision, intent(in) :: deltat
+
+ double precision, intent(out) :: dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert
+
+ double precision, dimension(NDIM,npoin), intent(in) :: coord
+
+ double precision :: time_veloc,time_traction,t,x,z
+
+ double precision, external :: ricker_Bielak_veloc
+
+ double precision x0_source, z0_source, angleforce, angleforce_refl
+ double precision c_inc, c_refl, time_offset, f0
+ double precision, dimension(NDIM) :: A_plane, B_plane, C_plane
+
+
+! get the coordinates of the mesh point
+ x = coord(1,iglob) - x0_source
+ z = z0_source - coord(2,iglob)
+
+! times for velocity and traction are staggered i.e. separated by deltat/2.d0
+ time_veloc = (it-1)*deltat + deltat/2.d0 + time_offset
+ time_traction = time_veloc + deltat/2.d0
+
+ t = time_traction
+
+!!$!SV30
+!!$
+!!$!analytical expression of the displacement for a SV 30 degrees and 0.3333 poisson ratio
+!!$! Ux = sqrt(3.d0)/2.d0 * rickertest(t - x/2.d0 + (9 - z) * sqrt(3.d0)/2.d0) &
+!!$! + sqrt(3.d0)/2.d0 * rickertest(t - x/2.d0 - (9 - z) * sqrt(3.d0)/2.d0) &
+!!$! + sqrt(3.d0) * rickertest(t - x/2.d0)
+!!$! Uz = - HALF * rickertest(t - x/2.d0 + (9 - z) * sqrt(3.d0)/2.d0) &
+!!$! + HALF * rickertest(t - x/2.d0 - (9 - z) * sqrt(3.d0)/2.d0)
+!!$
+!!$
+!!$! derivatives of analytical expression of horizontal and vertical displacements,
+!!$! computed using the "Mathematica" script in UTILS/deriv_ricker_spatial.m
+!!$ dxUx = (sqrt(3.d0)*a*((-8*t + 4*x)*exp(-a*(t - x/2.d0)**2) + &
+!!$ ((2*t - x)*(-2 + a*(-2*t + x)**2))*exp(-a*(t - x/2.d0)**2) + &
+!!$ (2*(-2*t + x - sqrt(3.d0)*(-9 + z)))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ ((1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (-2*t + x - sqrt(3.d0)*(-9 + z)))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (2*(-2*t + x + sqrt(3.d0)*(-9 + z)))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (-2*t + x + sqrt(3.d0)*(-9 + z)))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/4.d0
+!!$
+!!$ dzUx = (3*a*(((t + (-x + sqrt(3.d0)*(-9 + z))/2.d0)* &
+!!$ (1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) - &
+!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (t - x/2.d0 - (sqrt(3.d0)*(-9 + z))/2.d0))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (2*t - x + sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (-2*t + x + sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
+!!$
+!!$ dxUz = (a*((2*t - x - sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (-2*t + x - sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ ((1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (-2*t + x - sqrt(3.d0)*(-9 + z)))/2.d0*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) - &
+!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (-2*t + x + sqrt(3.d0)*(-9 + z)))/2.d0*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
+!!$
+!!$ dzUz = (sqrt(3.d0)*a*(((t + (-x + sqrt(3.d0)*(-9 + z))/2.d0)* &
+!!$ (1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (2*t - x - sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (t - x/2.d0 - (sqrt(3.d0)*(-9 + z))/2.d0))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (2*t - x + sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
+
+! to ompute the derivative of the displacement, we take the velocity ricker expression and we multiply by
+! the derivative of the interior argument of ricker_Bielak_veloc
+
+ dxUx = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
+ + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
+ + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
+ * (-sin(angleforce_refl)/c_refl)
+
+ dzUx = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-cos(angleforce)/c_inc)&
+ + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (cos(angleforce)/c_inc)&
+ + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
+ * (cos(angleforce_refl)/c_refl)
+
+ dxUz = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
+ + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
+ + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
+ * (-sin(angleforce_refl)/c_refl)
+
+ dzUz = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-cos(angleforce)/c_inc)&
+ + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (cos(angleforce)/c_inc)&
+ + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
+ * (cos(angleforce_refl)/c_refl)
+
+ t = time_veloc
+
+!!$!SV30
+!!$! analytical expression of the two components of the velocity vector
+!!$ veloc_horiz = (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_vert = - 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))
+
+ veloc_horiz = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
+ + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
+ + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ veloc_vert = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
+ + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
+ + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+
+end subroutine compute_Bielak_conditions
+
+! ********
+
+! compute time variation of the source for analytical initial plane wave
+double precision function ricker_Bielak_integrale_displ(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: t,f0,a
+
+ a = pi*pi*f0*f0
+
+! Ricker
+ ricker_Bielak_integrale_displ = t*exp(-a*t**2)
+
+end function ricker_Bielak_integrale_displ
+
+! ********
+
+! compute time variation of the source for analytical initial plane wave
+double precision function ricker_Bielak_displ(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: t,f0,a
+
+ a = pi*pi*f0*f0
+
+! Ricker
+ ricker_Bielak_displ = (1 - 2*a*t**2)*exp(-a*t**2)
+
+end function ricker_Bielak_displ
+
+! *******
+
+! compute time variation of the source for analytical initial plane wave
+double precision function ricker_Bielak_veloc(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: t,f0,a
+
+ a = pi*pi*f0*f0
+
+! first time derivative of a Ricker
+ ricker_Bielak_veloc = - 2*a*t*(3 - 2*a*t**2)*exp(-a*t**2)
+
+end function ricker_Bielak_veloc
+
+! *******
+
+! compute time variation of the source for analytical initial plane wave
+double precision function ricker_Bielak_accel(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: t,f0,a
+
+ a = pi*pi*f0*f0
+
+! second time derivative of a Ricker
+ ricker_Bielak_accel = - 2*a*(3 - 12*a*t**2 + 4*a**2*t**4)* exp(-a*t**2)
+
+end function ricker_Bielak_accel
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_arrays_source.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_arrays_source.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_arrays_source.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_arrays_source.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,190 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
+ Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec_selected_source
+ integer nspec
+
+ double precision xi_source,gamma_source
+ double precision Mxx,Mzz,Mxz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
+
+ double precision xixd,xizd,gammaxd,gammazd
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+! source arrays
+ double precision, dimension(NGLLX,NGLLZ) :: G11,G13,G31,G33
+ double precision, dimension(NGLLX) :: hxis,hpxis
+ double precision, dimension(NGLLZ) :: hgammas,hpgammas
+
+ integer k,m
+ integer ir,iv
+
+! calculate G_ij for general source location
+! the source does not necessarily correspond to a Gauss-Lobatto point
+ do m=1,NGLLZ
+ do k=1,NGLLX
+
+ xixd = xix(k,m,ispec_selected_source)
+ xizd = xiz(k,m,ispec_selected_source)
+ gammaxd = gammax(k,m,ispec_selected_source)
+ gammazd = gammaz(k,m,ispec_selected_source)
+
+ G11(k,m) = Mxx*xixd+Mxz*xizd
+ G13(k,m) = Mxx*gammaxd+Mxz*gammazd
+ G31(k,m) = Mxz*xixd+Mzz*xizd
+ G33(k,m) = Mxz*gammaxd+Mzz*gammazd
+
+!!!! G21(k,m) = Mxy*xixd+Myz*xizd
+!!!! G23(k,m) = Mxy*gammaxd+Myz*gammazd
+
+ enddo
+ enddo
+
+! compute Lagrange polynomials at the source location
+ call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
+ call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
+
+! calculate source array
+ do m=1,NGLLZ
+ do k=1,NGLLX
+
+ sourcearray(:,k,m) = ZERO
+
+ do iv=1,NGLLZ
+ do ir=1,NGLLX
+
+ sourcearray(1,k,m) = sourcearray(1,k,m) + hxis(ir)*hgammas(iv) &
+ *(G11(ir,iv)*hpxis(k)*hgammas(m) &
+ +G13(ir,iv)*hxis(k)*hpgammas(m))
+
+! sourcearray(2,k,m) = sourcearray(2,k,m) + hxis(ir)*hgammas(iv) &
+! *(G21(ir,iv)*hpxis(k)*hgammas(m) &
+! +G23(ir,iv)*hxis(k)*hpgammas(m))
+
+ sourcearray(2,k,m) = sourcearray(2,k,m) + hxis(ir)*hgammas(iv) &
+ *(G31(ir,iv)*hpxis(k)*hgammas(m) &
+ +G33(ir,iv)*hxis(k)*hpgammas(m))
+
+ enddo
+ enddo
+
+ enddo
+ enddo
+
+ end subroutine compute_arrays_source
+
+! ------------------------------------------------------------------------------------------------------
+
+
+ subroutine compute_arrays_adj_source(adj_source_file,xi_receiver,gamma_receiver,adj_sourcearray, &
+ xigll,zigll,NSTEP)
+
+ implicit none
+
+ include 'constants.h'
+
+! input
+ integer NSTEP
+
+ double precision xi_receiver, gamma_receiver
+
+ character(len=*) adj_source_file
+
+! output
+ real(kind=CUSTOM_REAL), dimension(NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearray
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hgammar(NGLLZ), hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL) :: adj_src_s(NSTEP,3)
+
+ integer icomp, itime, i, k, ios
+ double precision :: junk
+ character(len=3) :: comp(3)
+ character(len=150) :: filename
+
+ call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
+
+ adj_sourcearray(:,:,:,:) = 0.
+
+ comp = (/"BHX","BHY","BHZ"/)
+
+ do icomp = 1,3
+
+ filename = 'OUTPUT_FILES/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit = IIN, file = trim(filename), iostat = ios)
+ if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')
+
+ do itime = 1, NSTEP
+ read(IIN,*) junk, adj_src_s(itime,icomp)
+ enddo
+ close(IIN)
+
+ enddo
+
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ adj_sourcearray(:,:,i,k) = hxir(i) * hgammar(k) * adj_src_s(:,:)
+ enddo
+ enddo
+
+
+end subroutine compute_arrays_adj_source
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_curl_one_element.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_curl_one_element.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_curl_one_element.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_curl_one_element.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,164 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_curl_one_element(curl_element,displ_elastic, &
+ displs_poroelastic,elastic,poroelastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
+ nspec,npoin_elastic,npoin_poroelastic,ispec)
+
+ ! compute curl in (poro)elastic elements (for rotational study)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,ispec
+
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ ! curl in this element
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
+
+ logical, dimension(nspec) :: elastic,poroelastic
+
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic
+
+ ! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ ! local variables
+ integer :: i,j,k
+
+ ! jacobian
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
+
+ ! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ real(kind=CUSTOM_REAL) :: duz_dxl,dux_dzl
+
+ if(elastic(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 + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,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(3,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
+
+ 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')
+
+ endif ! end of test if acoustic or elastic element
+
+end subroutine compute_curl_one_element
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_energy.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_energy.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_energy.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_energy.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,403 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ 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_acoustic,npoin_elastic,npoin_poroelastic, &
+ assign_external_model,it,deltat,t0,kmato,poroelastcoef,density, &
+ porosity,tortuosity, &
+ vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext, &
+ anisotropic,anisotropy,wxgll,wzgll,numat, &
+ pressure_element,vector_field_element,e1,e11, &
+ potential_dot_acoustic,potential_dot_dot_acoustic, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS,p_sv)
+
+! compute kinetic and potential energy in the solid (acoustic elements are excluded)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,numat
+
+! vector field in an element
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
+
+! pressure in an element
+ integer :: N_SLS
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
+
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: &
+ potential_dot_acoustic,potential_dot_dot_acoustic
+
+ logical :: TURN_ATTENUATION_ON,p_sv
+
+ integer :: it
+ double precision :: t0,deltat
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ logical, dimension(nspec) :: elastic,poroelastic,anisotropic
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ integer, dimension(nspec) :: kmato
+ logical :: assign_external_model
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(6,numat) :: anisotropy
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext, &
+ c33ext,c35ext,c55ext
+
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic,veloc_elastic
+
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,velocs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displw_poroelastic,velocw_poroelastic
+
+! Gauss-Lobatto-Legendre points and weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local variables
+ integer :: i,j,k,ispec
+
+! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
+
+! jacobian
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+ real(kind=CUSTOM_REAL) :: kinetic_energy,potential_energy
+ real(kind=CUSTOM_REAL) :: cpl,csl,rhol,mul_relaxed,lambdal_relaxed, &
+ lambdalplus2mul_relaxed,kappal
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
+ real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
+
+ kinetic_energy = ZERO
+ potential_energy = ZERO
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ !---
+ !--- elastic spectral element
+ !---
+ if(elastic(ispec)) then
+
+ ! checks wave type
+ if( .not. p_sv ) then
+ call exit_MPI('output energy for SH waves not implemented yet')
+ endif
+
+ ! 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))
+ rhol = density(1,kmato(ispec))
+
+ ! double loop over GLL points
+ 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)
+ rhol = rhoext(i,j,ispec)
+ mul_relaxed = rhol*csl*csl
+ lambdal_relaxed = rhol*cpl*cpl - TWO*mul_relaxed
+ lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
+ endif
+
+ ! derivative along x and along z
+ dux_dxi = 0._CUSTOM_REAL
+ duz_dxi = 0._CUSTOM_REAL
+
+ dux_dgamma = 0._CUSTOM_REAL
+ duz_dgamma = 0._CUSTOM_REAL
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,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(3,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)
+ jacobianl = jacobian(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ ! compute kinetic energy
+ kinetic_energy = kinetic_energy &
+ + rhol*(veloc_elastic(1,ibool(i,j,ispec))**2 &
+ + veloc_elastic(3,ibool(i,j,ispec))**2) *wxgll(i)*wzgll(j)*jacobianl / TWO
+
+ ! compute potential energy
+ potential_energy = potential_energy &
+ + (lambdalplus2mul_relaxed*dux_dxl**2 &
+ + lambdalplus2mul_relaxed*duz_dzl**2 &
+ + two*lambdal_relaxed*dux_dxl*duz_dzl &
+ + mul_relaxed*(dux_dzl + duz_dxl)**2)*wxgll(i)*wzgll(j)*jacobianl / TWO
+
+ enddo
+ enddo
+
+ !---
+ !--- poroelastic spectral element
+ !---
+ elseif(poroelastic(ispec)) then
+
+ ! get relaxed elastic parameters of current spectral element
+ !for now replaced by solid, fluid, and frame parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ !solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+ !fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ !frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+ !Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
+ + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ !The RHS has the form : div T -phi/c div T_f + phi/ceta_fk^-1.partial t w
+ !where T = G:grad u_s + C div w I
+ !and T_f = C div u_s I + M div w I
+ !we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
+ mul_G = mul_fr
+ lambdal_G = H_biot - TWO*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+ ! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+ jacobianl = jacobian(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ ! compute potential energy
+ potential_energy = potential_energy &
+ + ( lambdalplus2mul_G*dux_dxl**2 &
+ + lambdalplus2mul_G*duz_dzl**2 &
+ + two*lambdal_G*dux_dxl*duz_dzl + mul_G*(dux_dzl + duz_dxl)**2 &
+ + two*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 &
+ + ( rhol_bar*(velocs_poroelastic(1,ibool(i,j,ispec))**2 &
+ + velocs_poroelastic(2,ibool(i,j,ispec))**2) &
+ + rhol_f*tortl/phil*(velocw_poroelastic(1,ibool(i,j,ispec))**2 &
+ + velocw_poroelastic(2,ibool(i,j,ispec))**2) &
+ + rhol_f*(velocs_poroelastic(1,ibool(i,j,ispec))*velocw_poroelastic(1,ibool(i,j,ispec)) &
+ + velocs_poroelastic(2,ibool(i,j,ispec))*velocw_poroelastic(2,ibool(i,j,ispec))) &
+ )*wxgll(i)*wzgll(j)*jacobianl / TWO
+ else
+ kinetic_energy = kinetic_energy &
+ + rhol_s*(velocs_poroelastic(1,ibool(i,j,ispec))**2 &
+ + velocs_poroelastic(2,ibool(i,j,ispec))**2)*wxgll(i)*wzgll(j)*jacobianl / TWO
+ endif
+ enddo
+ enddo
+
+ !---
+ !--- acoustic spectral element
+ !---
+ else
+
+ ! for the definition of potential energy in an acoustic fluid, see for instance
+ ! equation (23) of M. Maess et al., Journal of Sound and Vibration 296 (2006) 264-276
+
+ ! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
+ ! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
+ ! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
+ ! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+ ! Displacement is then: u = grad(Chi) / rho
+ ! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
+ ! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+
+ ! compute pressure in this element
+ 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_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
+ TURN_ATTENUATION_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_acoustic,npoin_elastic,npoin_poroelastic, &
+ ispec,numat,kmato,density,rhoext,assign_external_model)
+
+ ! get density of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(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
+ do i = 1,NGLLX
+
+ !--- if external medium, get density of current grid point
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ jacobianl = jacobian(i,j,ispec)
+
+ ! compute kinetic energy
+ kinetic_energy = kinetic_energy &
+ + 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 * cpl**2)
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+ ! save kinetic, potential and total energy for this time step in external file
+ write(IOUT_ENERGY,*) real(dble(it-1)*deltat - t0,4),real(kinetic_energy,4), &
+ real(potential_energy,4),real(kinetic_energy + potential_energy,4)
+
+ end subroutine compute_energy
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_acoustic.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_forces_acoustic.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_acoustic.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_acoustic.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,762 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ 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,poroelastcoef,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,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top)
+
+! compute forces for the acoustic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP,SIMULATION_TYPE
+
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nelemabs) :: ib_left
+ integer, dimension(nelemabs) :: ib_right
+ integer, dimension(nelemabs) :: ib_bottom
+ integer, dimension(nelemabs) :: ib_top
+
+ 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
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
+
+ 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
+
+! Gauss-Lobatto-Legendre weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+!---
+!--- local variables
+!---
+
+ 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
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_dux_dxl,b_dux_dzl
+ real(kind=CUSTOM_REAL) :: weight,xxi,zxi,xgamma,zgamma,jacobian1D
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2
+
+! Jacobian matrix and determinant
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the elastic medium
+ real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,kappal,cpl,rhol
+
+ integer :: ifirstelem,ilastelem
+
+ 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
+
+! derivative along x and along z
+ dux_dxi = ZERO
+ dux_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 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
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(SIMULATION_TYPE == 2) then
+ 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)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of potential
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+ endif
+
+ jacobianl = jacobian(i,j,ispec)
+
+! if external density model
+ if(assign_external_model) rhol = rhoext(i,j,ispec)
+
+! for acoustic medium
+! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl) / rhol
+ tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl) / rhol
+
+ if(SIMULATION_TYPE == 2) then
+ 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
+ enddo
+
+!
+! second double-loop over GLL to compute all the terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+! along x direction and z direction
+! and assemble the contributions
+ 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(SIMULATION_TYPE == 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))
+ endif
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if acoustic element
+
+ enddo ! end of loop over all spectral elements
+
+!
+!--- absorbing boundaries
+!
+ if(anyabs) then
+
+ do ispecabs=1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+! get elastic parameters of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ rhol = density(1,kmato(ispec))
+
+ cpl = sqrt(kappal/rhol)
+
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
+ i = 1
+
+ jbegin = jbegin_left(ispecabs)
+ jend = jend_left(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(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)
+
+ 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/rhol
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ b_absorb_acoustic_left(j,ib_left(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = &
+ b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_left(j,ib_left(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+
+ i = NGLLX
+
+ jbegin = jbegin_right(ispecabs)
+ jend = jend_right(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(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)
+
+ 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/rhol
+
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ b_absorb_acoustic_right(j,ib_right(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = &
+ b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_right(j,ib_right(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+
+ j = 1
+
+ ibegin = ibegin_bottom(ispecabs)
+ iend = iend_bottom(ispecabs)
+
+! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(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)
+
+ 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/rhol
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = &
+ b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+
+ j = NGLLZ
+
+ ibegin = ibegin_top(ispecabs)
+ iend = iend_top(ispecabs)
+
+! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(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)
+
+ 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/rhol
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ b_absorb_acoustic_top(i,ib_top(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = &
+ b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_top(i,ib_top(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
+ endif ! end of top absorbing boundary
+
+ enddo
+
+ endif ! end of absorbing boundaries
+
+ end subroutine compute_forces_acoustic
+
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine compute_forces_acoustic_2(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, &
+ density,poroelastcoef,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, &
+ SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
+ b_absorb_acoustic_left,b_absorb_acoustic_right, &
+ b_absorb_acoustic_bottom,b_absorb_acoustic_top)
+
+! compute forces for the acoustic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP,SIMULATION_TYPE
+
+ 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
+
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
+
+ logical :: anyabs,assign_external_model
+ logical :: SAVE_FORWARD
+
+! 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
+
+! Gauss-Lobatto-Legendre weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nelemabs) :: ib_left
+ integer, dimension(nelemabs) :: ib_right
+ integer, dimension(nelemabs) :: ib_bottom
+ integer, dimension(nelemabs) :: ib_top
+
+ 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
+
+!---
+!--- local variables
+!---
+
+ 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
+ real(kind=CUSTOM_REAL) :: weight,xxi,zxi,xgamma,zgamma,jacobian1D
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2
+
+! Jacobian matrix and determinant
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the elastic medium
+ real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,kappal,cpl,rhol
+
+ integer :: ifirstelem,ilastelem
+
+ 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
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ dux_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of potential
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+ jacobianl = jacobian(i,j,ispec)
+
+ ! if external density model
+ if(assign_external_model) rhol = rhoext(i,j,ispec)
+
+ ! for acoustic medium
+ ! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl) / rhol
+ tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl) / rhol
+ enddo
+ enddo
+
+!
+! second double-loop over GLL to compute all the terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ ! along x direction and z direction
+ ! and assemble the contributions
+ 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))
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if acoustic element
+
+ enddo ! end of loop over all spectral elements
+
+!
+!--- absorbing boundaries
+!
+ if(anyabs) then
+
+ do ispecabs=1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+ ! Sommerfeld condition if acoustic
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+
+ ! get elastic parameters of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ rhol = density(1,kmato(ispec))
+
+ cpl = sqrt(kappal/rhol)
+
+ !--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+ i = 1
+ jbegin = jbegin_left(ispecabs)
+ jend = jend_left(ispecabs)
+ do j = jbegin,jend
+ iglob = ibool(i,j,ispec)
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(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)
+ weight = jacobian1D * wzgll(j)
+
+ if( SIMULATION_TYPE == 1 ) then
+ ! adds absorbing boundary contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ ! adds (previously) stored contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - b_absorb_acoustic_left(j,ib_left(ispecabs),NSTEP-it+1)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ ! saves contribution
+ b_absorb_acoustic_left(j,ib_left(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+ !--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+ i = NGLLX
+ jbegin = jbegin_right(ispecabs)
+ jend = jend_right(ispecabs)
+ do j = jbegin,jend
+ iglob = ibool(i,j,ispec)
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(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)
+ weight = jacobian1D * wzgll(j)
+
+ if( SIMULATION_TYPE == 1 ) then
+ ! adds absorbing boundary contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - b_absorb_acoustic_right(j,ib_right(ispecabs),NSTEP-it+1)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ ! saves contribution
+ b_absorb_acoustic_right(j,ib_right(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ endif
+ enddo
+ endif ! end of right absorbing boundary
+
+ !--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+ j = 1
+ ibegin = ibegin_bottom(ispecabs)
+ iend = iend_bottom(ispecabs)
+ ! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+ do i = ibegin,iend
+ iglob = ibool(i,j,ispec)
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(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)
+ weight = jacobian1D * wxgll(i)
+
+ if( SIMULATION_TYPE == 1 ) then
+ ! adds absorbing boundary contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),NSTEP-it+1)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ ! saves contribution
+ b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ endif
+ enddo
+ endif ! end of bottom absorbing boundary
+
+ !--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+ j = NGLLZ
+ ibegin = ibegin_top(ispecabs)
+ iend = iend_top(ispecabs)
+ ! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+ do i = ibegin,iend
+ iglob = ibool(i,j,ispec)
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(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)
+ weight = jacobian1D * wxgll(i)
+
+ if( SIMULATION_TYPE == 1 ) then
+ ! adds absorbing boundary contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - b_absorb_acoustic_top(i,ib_top(ispecabs),NSTEP-it+1)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ ! saves contribution
+ b_absorb_acoustic_top(i,ib_top(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ endif
+ enddo
+ endif ! end of top absorbing boundary
+
+ endif ! acoustic ispec
+ enddo
+ endif ! end of absorbing boundaries
+
+ end subroutine compute_forces_acoustic_2
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_poro_fluid.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_fluid.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_poro_fluid.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_poro_fluid.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,940 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.3
+! ------------------------------
+!
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_forces_poro_fluid(npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
+ accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
+ b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,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_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,&
+ C_k,M_k,NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,f0,freq0,Q0)
+
+! compute forces for the fluid poroelastic part
+
+ implicit none
+
+ include "constants.h"
+ integer :: NSOURCES, i_source
+ integer, dimension(NSOURCES) ::ispec_selected_source,source_type,is_proc_source
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP
+ integer :: nrec,SIMULATION_TYPE,myrank
+ integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nelemabs) :: ib_left
+ integer, dimension(nelemabs) :: ib_right
+ integer, dimension(nelemabs) :: ib_bottom
+ integer, dimension(nelemabs) :: ib_top
+
+ logical :: anyabs,initialfield,TURN_ATTENUATION_ON
+ logical :: SAVE_FORWARD
+
+ double precision ::deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+
+ 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
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(3,numat) :: permeability
+ 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
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
+ real(kind=CUSTOM_REAL), dimension(npoin) :: C_k,M_k
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_poro_w_left
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_poro_w_right
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmax,NSTEP) :: b_absorb_poro_w_top
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmin,NSTEP) :: b_absorb_poro_w_bottom
+ real(kind=CUSTOM_REAL), dimension(npoin) :: b_viscodampx,b_viscodampz
+
+ integer :: N_SLS
+ 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) :: &
+ dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
+
+! viscous attenuation
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: rx_viscous
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: rz_viscous
+ double precision :: theta_e,theta_s
+ logical TURN_VISCATTENUATION_ON
+ double precision, dimension(3):: bl_unrelaxed,bl_relaxed
+
+! 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
+
+! Gauss-Lobatto-Legendre weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+!
+ double precision :: f0,freq0,Q0,w_c
+
+
+!---
+!--- local variables
+!---
+
+ 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
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
+ real(kind=CUSTOM_REAL) :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xz,sigma_zz
+ real(kind=CUSTOM_REAL) :: sigmap
+ real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xz,b_sigma_zz
+ real(kind=CUSTOM_REAL) :: b_sigmap
+ real(kind=CUSTOM_REAL) :: nx,nz,vx,vz,vn,vxf,vzf,vnf,rho_vpI,rho_vpII,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1p,tempx2p,tempz1p,tempz2p
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempz1,b_tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1p,b_tempx2p,b_tempz1p,b_tempz2p
+
+
+! Jacobian matrix and determinant
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the poroelastic medium
+ real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
+ 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
+ real(kind=CUSTOM_REAL) :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
+ real(kind=CUSTOM_REAL) :: cpIsquare,cpIIsquare,cssquare,cpIl,cpIIl,csl
+
+! for attenuation
+ real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
+
+! 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)
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+!---
+!--- poroelastic spectral element
+!---
+
+ if(poroelastic(ispec)) then
+
+! get poroelastic properties 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)
+!The RHS has the form : div T_f -rho_f/rho_bar div T - eta_fk^-1.partial t w
+!where T = G:grad u_s + C_biot div w I
+!and T_f = C_biot div u_s I + M_biot div w I
+ mul_G = mul_fr
+ lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+
+ b_dwx_dxi = ZERO
+ b_dwz_dxi = ZERO
+
+ b_dwx_dgamma = ZERO
+ b_dwz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(SIMULATION_TYPE == 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)
+ b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+
+ b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
+ b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
+
+ b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
+ b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
+ endif
+
+! compute stress tensor (include attenuation 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
+! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_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 + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
+ 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
+ e11_sum = 0._CUSTOM_REAL
+ e13_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_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 + TWO * mul_G * e11_sum
+ sigma_xz = sigma_xz + mul_G * e13_sum
+ sigma_zz = sigma_zz - TWO * mul_G * e11_sum
+
+ else
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_G*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+
+ b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
+ endif
+ endif
+
+! kernels calculation
+ if(SIMULATION_TYPE == 2) then
+ iglob = ibool(i,j,ispec)
+ C_k(iglob) = ((dux_dxl + duz_dzl) * (b_dwx_dxl + b_dwz_dzl) + &
+ (dwx_dxl + dwz_dzl) * (b_dux_dxl + b_duz_dzl)) * C_biot
+ M_k(iglob) = (dwx_dxl + dwz_dzl) * (b_dwx_dxl + b_dwz_dzl) * M_biot
+ endif
+
+ jacobianl = jacobian(i,j,ispec)
+
+! weak formulation term based on stress tensor (non-symmetric form)
+! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
+ tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
+
+ tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
+ tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
+
+ tempx1p(i,j) = wzgll(j)*jacobianl*sigmap*xixl
+ tempz1p(i,j) = wzgll(j)*jacobianl*sigmap*xizl
+
+ tempx2p(i,j) = wxgll(i)*jacobianl*sigmap*gammaxl
+ tempz2p(i,j) = wxgll(i)*jacobianl*sigmap*gammazl
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
+ b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
+
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
+ b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
+
+ b_tempx1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xixl
+ b_tempz1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xizl
+
+ b_tempx2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammaxl
+ b_tempz2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammazl
+ endif
+
+ enddo
+ enddo
+
+!
+! second double-loop over GLL to compute all the terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+! along x direction and z direction
+! and assemble the contributions
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) + ( (rhol_f/rhol_bar*tempx1(k,j) - tempx1p(k,j)) &
+ *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*tempx2(i,k) - tempx2p(i,k))*hprimewgll_zz(k,j) )
+
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + ( (rhol_f/rhol_bar*tempz1(k,j) - tempz1p(k,j)) &
+ *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*tempz2(i,k) - tempz2p(i,k))*hprimewgll_zz(k,j) )
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) + ( (rhol_f/rhol_bar*b_tempx1(k,j) - b_tempx1p(k,j)) &
+ *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*b_tempx2(i,k) - b_tempx2p(i,k))*hprimewgll_zz(k,j) )
+
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + ( (rhol_f/rhol_bar*b_tempz1(k,j) - b_tempz1p(k,j)) &
+ *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*b_tempz2(i,k) - b_tempz2p(i,k))*hprimewgll_zz(k,j) )
+ endif
+
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if poroelastic element
+
+ enddo ! end of loop over all spectral elements
+
+!
+!---- viscous damping
+!
+! add - eta_f k^-1 dot(w)
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ etal_f = poroelastcoef(2,2,kmato(ispec))
+
+ if(poroelastic(ispec) .and. etal_f > 0.d0) then
+
+ permlxx = permeability(1,kmato(ispec))
+ permlxz = permeability(2,kmato(ispec))
+ permlzz = permeability(3,kmato(ispec))
+
+! calcul of the inverse of k
+ detk = permlxx*permlzz - permlxz*permlxz
+
+ if(detk /= ZERO) then
+ invpermlxx = permlzz/detk
+ invpermlxz = -permlxz/detk
+ invpermlzz = permlxx/detk
+ else
+ stop 'Permeability matrix is not invertible'
+ endif
+
+! relaxed viscous coef
+ bl_relaxed(1) = etal_f*invpermlxx
+ bl_relaxed(2) = etal_f*invpermlxz
+ bl_relaxed(3) = etal_f*invpermlzz
+
+ if(TURN_VISCATTENUATION_ON) then
+ bl_unrelaxed(1) = etal_f*invpermlxx*theta_e/theta_s
+ bl_unrelaxed(2) = etal_f*invpermlxz*theta_e/theta_s
+ bl_unrelaxed(3) = etal_f*invpermlzz*theta_e/theta_s
+ endif
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ if(TURN_VISCATTENUATION_ON) then
+! compute the viscous damping term with the unrelaxed viscous coef and add memory variable
+ viscodampx = velocw_poroelastic(1,iglob)*bl_unrelaxed(1) + velocw_poroelastic(2,iglob)*bl_unrelaxed(2)&
+ - rx_viscous(i,j,ispec)
+ viscodampz = velocw_poroelastic(1,iglob)*bl_unrelaxed(2) + velocw_poroelastic(2,iglob)*bl_unrelaxed(3)&
+ - rz_viscous(i,j,ispec)
+ else
+! no viscous attenuation
+ viscodampx = velocw_poroelastic(1,iglob)*bl_relaxed(1) + velocw_poroelastic(2,iglob)*bl_relaxed(2)
+ viscodampz = velocw_poroelastic(1,iglob)*bl_relaxed(2) + velocw_poroelastic(2,iglob)*bl_relaxed(3)
+ endif
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
+ viscodampx
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
+ viscodampz
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_viscodampx(iglob) = wxgll(i)*wzgll(j)*jacobian(i,j,ispec) * viscodampx
+ b_viscodampz(iglob) = wxgll(i)*wzgll(j)*jacobian(i,j,ispec) * viscodampz
+ elseif(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - b_viscodampx(iglob)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - b_viscodampz(iglob)
+ endif
+
+ enddo
+ enddo
+
+ endif ! end of test if poroelastic element
+
+ enddo ! end of loop over all spectral elements
+
+
+!
+!--- absorbing boundaries
+!
+ if(anyabs) then
+
+ do ispecabs=1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+ if (poroelastic(ispec)) then
+! get poroelastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ permlxx = permeability(1,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))
+ etal_f = poroelastcoef(2,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)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
+ tortl,rhol_s,rhol_f,etal_f,permlxx,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIl = sqrt(cpIsquare)
+ cpIIl = sqrt(cpIIsquare)
+ csl = sqrt(cssquare)
+
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
+ i = 1
+
+ jbegin = jbegin_left_poro(ispecabs)
+ jend = jend_left_poro(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+ 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)
+
+ rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
+ rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
+ rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
+ tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_w_left(1,j,ib_left(ispecabs),it) = tx*weight
+ b_absorb_poro_w_left(2,j,ib_left(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_left(1,j,ib_left(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_left(2,j,ib_left(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+
+ i = NGLLX
+
+ jbegin = jbegin_right_poro(ispecabs)
+ jend = jend_right_poro(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+ 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)
+
+
+ rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
+ rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
+ rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
+ tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_w_right(1,j,ib_right(ispecabs),it) = tx*weight
+ b_absorb_poro_w_right(2,j,ib_right(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_right(1,j,ib_right(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_right(2,j,ib_right(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+
+ 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(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)
+ 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)
+
+
+ rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
+ rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
+ rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
+ tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_w_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
+ b_absorb_poro_w_bottom(2,i,ib_bottom(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+
+ 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(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)
+ 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)
+
+
+ rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
+ rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
+ rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
+ tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_w_top(1,i,ib_top(ispecabs),it) = tx*weight
+ b_absorb_poro_w_top(2,i,ib_top(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_top(1,i,ib_top(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_top(2,i,ib_top(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of top absorbing boundary
+
+ endif ! if poroelastic(ispec)
+ enddo
+
+ endif ! end of absorbing boundaries
+
+
+! --- add the source
+ if(.not. initialfield) then
+ do i_source=1,NSOURCES
+! 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
+
+ phil = porosity(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
+
+! moment tensor
+ if(source_type(i_source) == 2) then
+
+! add source array
+ if(SIMULATION_TYPE == 1) then ! forward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ accelw_poroelastic(:,iglob) = accelw_poroelastic(:,iglob) + &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
+ enddo
+ enddo
+ else ! backward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ b_accelw_poroelastic(:,iglob) = b_accelw_poroelastic(:,iglob) + &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sourcearray(i_source,:,i,j)*source_time_function(i_source,NSTEP-it+1)
+ enddo
+ enddo
+ endif !endif SIMULATION_TYPE == 1
+
+ endif !if(source_type(i_source) == 2)
+
+ endif ! if this processor carries the source and the source element is poroelastic
+ enddo
+
+ if(SIMULATION_TYPE == 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
+
+ irec_local = irec_local + 1
+ if(poroelastic(ispec_selected_rec(irec))) then
+ phil = porosity(kmato(ispec_selected_rec(irec)))
+ rhol_s = density(1,kmato(ispec_selected_rec(irec)))
+ rhol_f = density(2,kmato(ispec_selected_rec(irec)))
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - &
+ rhol_f/rhol_bar*adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - &
+ rhol_f/rhol_bar*adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
+ enddo
+ enddo
+ endif ! if element is poroelastic
+
+ endif ! if this processor carries the adjoint source and the source element is poroelastic
+ enddo ! irec = 1,nrec
+ endif ! SIMULATION_TYPE == 2 adjoint wavefield
+
+ endif ! if not using an initial field
+
+! implement attenuation
+ if(TURN_ATTENUATION_ON) then
+
+! 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)
+
+! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ if (poroelastic(ispec)) then
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
+ theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
+
+! loop on all the standard linear solids
+ do i_sls = 1,N_SLS
+
+! 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,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,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) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e11(i,j,ispec,i_sls) = Unp1
+
+! evolution e13
+ Un = e13(i,j,ispec,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,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) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e13(i,j,ispec,i_sls) = Unp1
+
+ enddo
+
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif ! end of test on attenuation
+
+ end subroutine compute_forces_poro_fluid
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_poro_solid.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_solid.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_poro_solid.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_poro_solid.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,957 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.3
+! ------------------------------
+!
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_forces_poro_solid(npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,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_displw_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ 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_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,&
+ mufr_k,B_k,NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,f0,freq0,Q0)
+
+! compute forces for the solid poroelastic part
+
+ implicit none
+
+ include "constants.h"
+ integer :: NSOURCES, i_source
+ integer, dimension(NSOURCES) :: ispec_selected_source,source_type,is_proc_source
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP
+ integer :: nrec,SIMULATION_TYPE,myrank
+ integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nelemabs) :: ib_left
+ integer, dimension(nelemabs) :: ib_right
+ integer, dimension(nelemabs) :: ib_bottom
+ integer, dimension(nelemabs) :: ib_top
+
+ logical :: anyabs,initialfield,TURN_ATTENUATION_ON
+ logical :: SAVE_FORWARD
+
+ double precision :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+
+ 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
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accels_poroelastic,b_displs_poroelastic,b_displw_poroelastic
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(3,numat) :: permeability
+ 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
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
+ real(kind=CUSTOM_REAL), dimension(npoin) :: mufr_k,B_k
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_poro_s_left
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_poro_s_right
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmax,NSTEP) :: b_absorb_poro_s_top
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmin,NSTEP) :: b_absorb_poro_s_bottom
+ real(kind=CUSTOM_REAL), dimension(npoin) :: b_viscodampx,b_viscodampz
+
+ integer :: N_SLS
+ 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) :: &
+ dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
+
+! viscous attenuation (poroelastic media)
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: rx_viscous
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: rz_viscous
+ double precision :: theta_e,theta_s
+ logical TURN_VISCATTENUATION_ON
+ double precision, dimension(3):: bl_unrelaxed,bl_relaxed
+
+! 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
+
+! Gauss-Lobatto-Legendre weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+!
+ double precision :: f0,freq0,Q0,w_c
+
+!---
+!--- local variables
+!---
+
+ 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
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
+ real(kind=CUSTOM_REAL) :: dsxx,dsxz,dszz
+ real(kind=CUSTOM_REAL) :: b_dsxx,b_dsxz,b_dszz
+ real(kind=CUSTOM_REAL) :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
+ real(kind=CUSTOM_REAL) :: dwxx,dwxz,dwzz
+ real(kind=CUSTOM_REAL) :: b_dwxx,b_dwxz,b_dwzz
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xz,sigma_zz
+ real(kind=CUSTOM_REAL) :: sigmap
+ real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xz,b_sigma_zz
+ real(kind=CUSTOM_REAL) :: b_sigmap
+ real(kind=CUSTOM_REAL) :: nx,nz,vx,vz,vn,vxf,vzf,vnf,rho_vpI,rho_vpII,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1p,tempx2p,tempz1p,tempz2p
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempz1,b_tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1p,b_tempx2p,b_tempz1p,b_tempz2p
+
+! Jacobian matrix and determinant
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the poroelastic medium
+ real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
+ 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
+ real(kind=CUSTOM_REAL) :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
+ real(kind=CUSTOM_REAL) :: cpIsquare,cpIIsquare,cssquare,cpIl,cpIIl,csl
+
+! for attenuation
+ real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
+
+! 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)
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+!---
+!--- poroelastic spectral element
+!---
+
+ if(poroelastic(ispec)) then
+
+! get poroelastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - 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)
+!The RHS has the form : div T -phi/c div T_f + phi/ceta_fk^-1.partial t w
+!where T = G:grad u_s + C_biot div w I
+!and T_f = C_biot div u_s I + M_biot div w I
+ mul_G = mul_fr
+ lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+
+ b_dwx_dxi = ZERO
+ b_dwz_dxi = ZERO
+
+ b_dwx_dgamma = ZERO
+ b_dwz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(SIMULATION_TYPE == 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)
+ b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+
+ b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
+ b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
+
+ b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
+ b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
+ endif
+
+! 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
+! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_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 + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
+ 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
+ e11_sum = 0._CUSTOM_REAL
+ e13_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_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 + TWO * mul_G * e11_sum
+ sigma_xz = sigma_xz + mul_G * e13_sum
+ sigma_zz = sigma_zz - TWO * mul_G * e11_sum
+
+ else
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_G*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+
+ b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
+ endif
+ endif
+
+! kernels calculation
+ if(SIMULATION_TYPE == 2) then
+ iglob = ibool(i,j,ispec)
+ dsxx = dux_dxl
+ dsxz = HALF * (duz_dxl + dux_dzl)
+ dszz = duz_dzl
+
+ dwxx = dwx_dxl
+ dwxz = HALF * (dwz_dxl + dwx_dzl)
+ dwzz = dwz_dzl
+
+ b_dsxx = b_dux_dxl
+ b_dsxz = HALF * (b_duz_dxl + b_dux_dzl)
+ b_dszz = b_duz_dzl
+
+ b_dwxx = b_dwx_dxl
+ b_dwxz = HALF * (b_dwz_dxl + b_dwx_dzl)
+ b_dwzz = b_dwz_dzl
+
+ B_k(iglob) = (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl) * (H_biot - FOUR_THIRDS * mul_fr)
+ mufr_k(iglob) = (dsxx * b_dsxx + dszz * b_dszz + &
+ 2._CUSTOM_REAL * dsxz * b_dsxz - &
+ 1._CUSTOM_REAL/3._CUSTOM_REAL * (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl) ) * mul_fr
+ endif
+
+ jacobianl = jacobian(i,j,ispec)
+
+! weak formulation term based on stress tensor (non-symmetric form)
+! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
+ tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
+
+ tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
+ tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
+
+ tempx1p(i,j) = wzgll(j)*jacobianl*sigmap*xixl
+ tempz1p(i,j) = wzgll(j)*jacobianl*sigmap*xizl
+
+ tempx2p(i,j) = wxgll(i)*jacobianl*sigmap*gammaxl
+ tempz2p(i,j) = wxgll(i)*jacobianl*sigmap*gammazl
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
+ b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
+
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
+ b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
+
+ b_tempx1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xixl
+ b_tempz1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xizl
+
+ b_tempx2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammaxl
+ b_tempz2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammazl
+ endif
+
+ enddo
+ enddo
+
+!
+! second double-loop over GLL to compute all the terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+! along x direction and z direction
+! and assemble the contributions
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - ( (tempx1(k,j) - phil/tortl*tempx1p(k,j)) &
+ *hprimewgll_xx(k,i) + (tempx2(i,k) - phil/tortl*tempx2p(i,k))*hprimewgll_zz(k,j) )
+
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - ( (tempz1(k,j) - phil/tortl*tempz1p(k,j)) &
+ *hprimewgll_xx(k,i) + (tempz2(i,k) - phil/tortl*tempz2p(i,k))*hprimewgll_zz(k,j) )
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - ( (b_tempx1(k,j) - phil/tortl*b_tempx1p(k,j)) &
+ *hprimewgll_xx(k,i) + (b_tempx2(i,k) - phil/tortl*b_tempx2p(i,k))*hprimewgll_zz(k,j) )
+
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - ( (b_tempz1(k,j) - phil/tortl*b_tempz1p(k,j)) &
+ *hprimewgll_xx(k,i) + (b_tempz2(i,k) - phil/tortl*b_tempz2p(i,k))*hprimewgll_zz(k,j) )
+ endif
+
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if poroelastic element
+
+ enddo ! end of loop over all spectral elements
+
+!
+!---- viscous damping
+!
+! add + phi/tort eta_f k^-1 dot(w)
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ etal_f = poroelastcoef(2,2,kmato(ispec))
+
+ if(poroelastic(ispec) .and. etal_f >0.d0) then
+
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ permlxx = permeability(1,kmato(ispec))
+ permlxz = permeability(2,kmato(ispec))
+ permlzz = permeability(3,kmato(ispec))
+
+! calcul of the inverse of k
+ detk = permlxx*permlzz - permlxz*permlxz
+
+ if(detk /= ZERO) then
+ invpermlxx = permlzz/detk
+ invpermlxz = -permlxz/detk
+ invpermlzz = permlxx/detk
+ else
+ stop 'Permeability matrix is not invertible'
+ endif
+
+! relaxed viscous coef
+ bl_relaxed(1) = etal_f*invpermlxx
+ bl_relaxed(2) = etal_f*invpermlxz
+ bl_relaxed(3) = etal_f*invpermlzz
+
+ if(TURN_VISCATTENUATION_ON) then
+ bl_unrelaxed(1) = etal_f*invpermlxx*theta_e/theta_s
+ bl_unrelaxed(2) = etal_f*invpermlxz*theta_e/theta_s
+ bl_unrelaxed(3) = etal_f*invpermlzz*theta_e/theta_s
+ endif
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ if(TURN_VISCATTENUATION_ON) then
+! compute the viscous damping term with the unrelaxed viscous coef and add memory variable
+ viscodampx = velocw_poroelastic(1,iglob)*bl_unrelaxed(1) + velocw_poroelastic(2,iglob)*bl_unrelaxed(2)&
+ - rx_viscous(i,j,ispec)
+ viscodampz = velocw_poroelastic(1,iglob)*bl_unrelaxed(2) + velocw_poroelastic(2,iglob)*bl_unrelaxed(3)&
+ - rz_viscous(i,j,ispec)
+ else
+! no viscous attenuation
+ viscodampx = velocw_poroelastic(1,iglob)*bl_relaxed(1) + velocw_poroelastic(2,iglob)*bl_relaxed(2)
+ viscodampz = velocw_poroelastic(1,iglob)*bl_relaxed(2) + velocw_poroelastic(2,iglob)*bl_relaxed(3)
+ endif
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + phil/tortl*wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
+ viscodampx
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + phil/tortl*wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
+ viscodampz
+
+! if SIMULATION_TYPE == 1 .and. SAVE_FORWARD then b_viscodamp is saved in compute_forces_poro_fluid.f90
+ if(SIMULATION_TYPE == 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)
+ endif
+
+ enddo
+ enddo
+
+ endif ! end of test if poroelastic element
+
+ enddo ! end of loop over all spectral elements
+
+
+!
+!--- absorbing boundaries
+!
+ if(anyabs) then
+
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+ if (poroelastic(ispec)) then
+
+! get poroelastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ permlxx = permeability(1,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))
+ etal_f = poroelastcoef(2,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)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
+ tortl,rhol_s,rhol_f,etal_f,permlxx,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIl = sqrt(cpIsquare)
+ cpIIl = sqrt(cpIIsquare)
+ csl = sqrt(cssquare)
+
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
+ i = 1
+
+ jbegin = jbegin_left_poro(ispecabs)
+ jend = jend_left_poro(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+
+ 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)
+
+ 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
+
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
+ tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_s_left(1,j,ib_left(ispecabs),it) = tx*weight
+ b_absorb_poro_s_left(2,j,ib_left(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_left(1,j,ib_left(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_left(2,j,ib_left(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+
+ i = NGLLX
+
+ jbegin = jbegin_right_poro(ispecabs)
+ jend = jend_right_poro(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+ 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)
+
+
+ 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
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
+ tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_s_right(1,j,ib_right(ispecabs),it) = tx*weight
+ b_absorb_poro_s_right(2,j,ib_right(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_right(1,j,ib_right(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_right(2,j,ib_right(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+
+ 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(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)
+ 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)
+
+
+ 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
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
+ tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_s_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
+ b_absorb_poro_s_bottom(2,i,ib_bottom(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+
+ 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(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)
+ 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)
+
+
+ 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
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
+ tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_s_top(1,i,ib_top(ispecabs),it) = tx*weight
+ b_absorb_poro_s_top(2,i,ib_top(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_top(1,i,ib_top(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_top(2,i,ib_top(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of top absorbing boundary
+
+ endif ! if poroelastic(ispec)
+
+ enddo
+
+ endif ! end of absorbing boundaries
+
+
+! --- add the source
+ if(.not. initialfield) then
+ do i_source=1,NSOURCES
+
+! 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
+
+ phil = porosity(kmato(ispec_selected_source(i_source)))
+ tortl = tortuosity(kmato(ispec_selected_source(i_source)))
+
+! moment tensor
+ if(source_type(i_source) == 2) then
+
+! add source array
+ if(SIMULATION_TYPE == 1) then ! forward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ accels_poroelastic(:,iglob) = accels_poroelastic(:,iglob) + &
+ (1._CUSTOM_REAL - phil/tortl)*sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
+ enddo
+ enddo
+ else ! backward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ 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
+ endif !endif SIMULATION_TYPE == 1
+
+ endif !if(source_type(i_source) == 2)
+
+ endif ! if this processor carries the source and the source element is poroelastic
+ enddo
+
+ if(SIMULATION_TYPE == 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
+
+ irec_local = irec_local + 1
+ if(poroelastic(ispec_selected_rec(irec))) then
+! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
+ enddo
+ enddo
+ endif ! if element is poroelastic
+
+ endif ! if this processor carries the adjoint source and the source element is poroelastic
+ enddo ! irec = 1,nrec
+ endif ! SIMULATION_TYPE == 2 adjoint wavefield
+
+ endif ! if not using an initial field
+
+! implement attenuation
+ if(TURN_ATTENUATION_ON) then
+
+! 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)
+
+! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ if (poroelastic(ispec)) then
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
+ theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
+
+! loop on all the standard linear solids
+ do i_sls = 1,N_SLS
+
+! 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,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,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) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e11(i,j,ispec,i_sls) = Unp1
+
+! evolution e13
+ Un = e13(i,j,ispec,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,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) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e13(i,j,ispec,i_sls) = Unp1
+
+ enddo
+
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif ! end of test on attenuation
+
+
+ end subroutine compute_forces_poro_solid
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_viscoelastic.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_forces_viscoelastic.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_viscoelastic.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_forces_viscoelastic.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,988 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+subroutine compute_forces_viscoelastic(p_sv,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,angleforce,deltatcube, &
+ 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,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy, &
+ 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, &
+ 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,NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,mu_k,kappa_k)
+
+ ! compute forces for the elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ logical :: p_sv
+ integer :: NSOURCES, i_source
+ integer :: npoin,nspec,myrank,nelemabs,numat,it,NSTEP
+ integer, dimension(NSOURCES) :: ispec_selected_source,is_proc_source,source_type
+
+ integer :: nrec,SIMULATION_TYPE
+ integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nelemabs) :: ib_left
+ integer, dimension(nelemabs) :: ib_right
+ integer, dimension(nelemabs) :: ib_bottom
+ integer, dimension(nelemabs) :: ib_top
+
+ logical :: anyabs,assign_external_model,initialfield,TURN_ATTENUATION_ON,add_Bielak_conditions
+
+ logical :: SAVE_FORWARD
+
+ double precision :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+ double precision, dimension(NSOURCES) :: angleforce
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+ integer, dimension(nelemabs) :: numabs
+
+ logical, dimension(nspec) :: elastic,anisotropic
+ logical, dimension(4,nelemabs) :: codeabs
+
+ real(kind=CUSTOM_REAL), dimension(3,npoin) :: accel_elastic,veloc_elastic,displ_elastic
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(6,numat) :: anisotropy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
+
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
+
+ real(kind=CUSTOM_REAL), dimension(3,npoin) :: b_accel_elastic,b_displ_elastic
+ real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
+ real(kind=CUSTOM_REAL), dimension(npoin) :: mu_k,kappa_k
+ real(kind=CUSTOM_REAL), dimension(3,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_elastic_left
+ real(kind=CUSTOM_REAL), dimension(3,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_elastic_right
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,nspec_zmax,NSTEP) :: b_absorb_elastic_top
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,nspec_zmin,NSTEP) :: b_absorb_elastic_bottom
+
+ integer :: N_SLS
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11,e13
+ 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
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: &
+ dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
+
+ ! 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
+
+ ! Gauss-Lobatto-Legendre weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+
+ !---
+ !--- local variables
+ !---
+
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,irec,irec_local
+
+ ! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duy_dxi,duy_dgamma,duz_dxi,duz_dgamma
+ real(kind=CUSTOM_REAL) :: dux_dxl,duy_dxl,duz_dxl,dux_dzl,duy_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duy_dxi,b_duy_dgamma,b_duz_dxi,b_duz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duy_dxl,b_duz_dxl,b_dux_dzl,b_duy_dzl,b_duz_dzl
+ real(kind=CUSTOM_REAL) :: dsxx,dsxz,dszz
+ real(kind=CUSTOM_REAL) :: b_dsxx,b_dsxz,b_dszz
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xy,sigma_xz,sigma_zy,sigma_zz
+ real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xy,b_sigma_xz,b_sigma_zy,b_sigma_zz
+ real(kind=CUSTOM_REAL) :: nx,nz,vx,vy,vz,vn,rho_vp,rho_vs,tx,ty,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempy1,tempy2,tempz1,tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempy1,b_tempy2,b_tempz1,b_tempz2
+
+ ! Jacobian matrix and determinant
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+ ! material properties of the elastic medium
+ real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal,cpl,csl,rhol, &
+ lambdal_unrelaxed,mul_unrelaxed,lambdalplus2mul_unrelaxed
+
+ ! for attenuation
+ real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
+
+ ! for anisotropy
+ double precision :: c11,c15,c13,c33,c35,c55
+
+ ! for analytical initial plane wave for Bielak's conditions
+ double precision :: veloc_horiz,veloc_vert,dxUx,dzUx,dxUz,dzUz,traction_x_t0,traction_z_t0,deltat
+ 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_bottom
+
+ integer :: ifirstelem,ilastelem
+
+ ! compute Grad(displ_elastic) at time step n for attenuation
+ if(TURN_ATTENUATION_ON) then
+ 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 = ifirstelem,ilastelem
+
+ tempx1(:,:) = ZERO
+ tempy1(:,:) = ZERO
+ tempz1(:,:) = ZERO
+ tempx2(:,:) = ZERO
+ tempy2(:,:) = ZERO
+ tempz2(:,:) = ZERO
+ if(SIMULATION_TYPE ==2)then
+ b_tempx1(:,:) = ZERO
+ b_tempy1(:,:) = ZERO
+ b_tempz1(:,:) = ZERO
+ b_tempx2(:,:) = ZERO
+ b_tempy2(:,:) = ZERO
+ b_tempz2(:,:) = ZERO
+ endif
+
+ !---
+ !--- elastic spectral element
+ !---
+ 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))
+
+ ! first double loop over GLL points to compute and store gradients
+ 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)
+ rhol = rhoext(i,j,ispec)
+ mul_relaxed = rhol*csl*csl
+ lambdal_relaxed = rhol*cpl*cpl - TWO*mul_relaxed
+ lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
+ endif
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duy_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duy_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
+ b_dux_dxi = ZERO
+ b_duy_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duy_dgamma = ZERO
+ b_duz_dgamma = ZERO
+ endif
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duy_dxi = duy_dxi + displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duy_dgamma = duy_dgamma + displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(SIMULATION_TYPE == 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_duy_dxi = b_duy_dxi + b_displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displ_elastic(3,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_duy_dgamma = b_duy_dgamma + b_displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duy_dxl = duy_dxi*xixl + duy_dgamma*gammaxl
+ duy_dzl = duy_dxi*xizl + duy_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 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
+
+ b_duy_dxl = b_duy_dxi*xixl + b_duy_dgamma*gammaxl
+ b_duy_dzl = b_duy_dxi*xizl + b_duy_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+ endif
+
+ ! compute stress tensor (include attenuation or anisotropy if needed)
+
+ if(TURN_ATTENUATION_ON) then
+
+ ! attenuation is implemented following the memory variable formulation of
+ ! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+ ! vol. 58(1), p. 110-120 (1993). More details can be found in
+ ! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+ ! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+ ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(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)
+ sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
+ sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
+
+ ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
+ ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
+ e1_sum = 0._CUSTOM_REAL
+ e11_sum = 0._CUSTOM_REAL
+ 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
+
+ else
+
+ ! no attenuation
+ sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
+ sigma_xy = mul_relaxed*duy_dxl
+ sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
+ sigma_zy = mul_relaxed*duy_dzl
+ sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
+ b_sigma_xx = lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
+ b_sigma_xy = mul_relaxed*b_duy_dxl
+ b_sigma_xz = mul_relaxed*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zy = mul_relaxed*b_duy_dzl
+ b_sigma_zz = lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
+ endif
+
+ endif
+
+ ! full anisotropy
+ if(anisotropic(ispec)) then
+ if(assign_external_model) then
+ c11 = c11ext(i,j,ispec)
+ c13 = c13ext(i,j,ispec)
+ c15 = c15ext(i,j,ispec)
+ c33 = c33ext(i,j,ispec)
+ c35 = c35ext(i,j,ispec)
+ c55 = c55ext(i,j,ispec)
+ else
+ c11 = anisotropy(1,kmato(ispec))
+ c13 = anisotropy(2,kmato(ispec))
+ c15 = anisotropy(3,kmato(ispec))
+ c33 = anisotropy(4,kmato(ispec))
+ c35 = anisotropy(5,kmato(ispec))
+ c55 = anisotropy(6,kmato(ispec))
+ end if
+
+ ! implement anisotropy in 2D
+ sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
+ sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
+ sigma_xz = c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
+
+ endif
+
+ ! Pre-kernels calculation
+ if(SIMULATION_TYPE == 2) then
+ iglob = ibool(i,j,ispec)
+ if(p_sv)then !P-SV waves
+ dsxx = dux_dxl
+ dsxz = HALF * (duz_dxl + dux_dzl)
+ dszz = duz_dzl
+
+ b_dsxx = b_dux_dxl
+ b_dsxz = HALF * (b_duz_dxl + b_dux_dzl)
+ b_dszz = b_duz_dzl
+
+ kappa_k(iglob) = (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl)
+ mu_k(iglob) = dsxx * b_dsxx + dszz * b_dszz + &
+ 2._CUSTOM_REAL * dsxz * b_dsxz - 1._CUSTOM_REAL/3._CUSTOM_REAL * kappa_k(iglob)
+ else !SH (membrane) waves
+ mu_k(iglob) = duy_dxl * b_duy_dxl + duy_dzl * b_duy_dzl
+ endif
+ endif
+
+ jacobianl = jacobian(i,j,ispec)
+
+ ! weak formulation term based on stress tensor (non-symmetric form)
+ ! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
+ tempy1(i,j) = wzgll(j)*jacobianl*(sigma_xy*xixl+sigma_zy*xizl)
+ tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
+
+ tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
+ tempy2(i,j) = wxgll(i)*jacobianl*(sigma_xy*gammaxl+sigma_zy*gammazl)
+ tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
+ b_tempy1(i,j) = wzgll(j)*jacobianl*(b_sigma_xy*xixl+b_sigma_zy*xizl)
+ b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
+
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
+ b_tempy2(i,j) = wxgll(i)*jacobianl*(b_sigma_xy*gammaxl+b_sigma_zy*gammazl)
+ b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
+ endif
+
+ enddo
+ enddo
+
+ !
+ ! second double-loop over GLL to compute all the terms
+ !
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ ! along x direction and z direction
+ ! and assemble the contributions
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tempy1(k,j)*hprimewgll_xx(k,i) + tempy2(i,k)*hprimewgll_zz(k,j))
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tempz1(k,j)*hprimewgll_xx(k,i) + tempz2(i,k)*hprimewgll_zz(k,j))
+
+ if(SIMULATION_TYPE == 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_tempy1(k,j)*hprimewgll_xx(k,i) + b_tempy2(i,k)*hprimewgll_zz(k,j))
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,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
+ enddo
+
+ endif ! end of test if elastic element
+
+ enddo ! end of loop over all spectral elements
+
+ !
+ !--- absorbing boundaries
+ !
+ if(anyabs) then
+
+ count_left=1
+ count_right=1
+ count_bottom=1
+
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+ ! get elastic parameters of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
+ csl = sqrt(mul_relaxed/rhol)
+
+ !--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
+ i = 1
+
+ do j = 1,NGLLZ
+
+ iglob = ibool(i,j,ispec)
+
+ ! for analytical initial plane wave for Bielak's conditions
+ ! left or right edge, horizontal normal vector
+ if(add_Bielak_conditions .and. initialfield) then
+ if (.not.over_critical_angle) then
+ call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
+ traction_z_t0 = mul_relaxed*(dxUz + dzUx)
+ else
+ veloc_horiz=v0x_left(count_left)
+ veloc_vert=v0z_left(count_left)
+ traction_x_t0=t0x_left(count_left)
+ traction_z_t0=t0z_left(count_left)
+ count_left=count_left+1
+ end if
+ else
+ veloc_horiz = 0
+ veloc_vert = 0
+ traction_x_t0 = 0
+ traction_z_t0 = 0
+ endif
+
+ ! 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_vp = rhol*cpl
+ rho_vs = rhol*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)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+ ! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob) - veloc_horiz
+ vy = veloc_elastic(2,iglob)
+ vz = veloc_elastic(3,iglob) - veloc_vert
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ ty = rho_vs*vy
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz + traction_z_t0)*weight
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ if(p_sv)then !P-SV waves
+ b_absorb_elastic_left(1,j,ib_left(ispecabs),it) = tx*weight
+ b_absorb_elastic_left(3,j,ib_left(ispecabs),it) = tz*weight
+ else !SH (membrane) waves
+ b_absorb_elastic_left(2,j,ib_left(ispecabs),it) = ty*weight
+ endif
+ elseif(SIMULATION_TYPE == 2) then
+ if(p_sv)then !P-SV waves
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
+ b_absorb_elastic_left(1,j,ib_left(ispecabs),NSTEP-it+1)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
+ b_absorb_elastic_left(3,j,ib_left(ispecabs),NSTEP-it+1)
+ else !SH (membrane) waves
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
+ b_absorb_elastic_left(2,j,ib_left(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+ !--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+
+ i = NGLLX
+
+ do j = 1,NGLLZ
+
+ iglob = ibool(i,j,ispec)
+
+ ! for analytical initial plane wave for Bielak's conditions
+ ! left or right edge, horizontal normal vector
+ if(add_Bielak_conditions .and. initialfield) then
+ if (.not.over_critical_angle) then
+ call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
+ traction_z_t0 = mul_relaxed*(dxUz + dzUx)
+ else
+ veloc_horiz=v0x_right(count_right)
+ veloc_vert=v0z_right(count_right)
+ traction_x_t0=t0x_right(count_right)
+ traction_z_t0=t0z_right(count_right)
+ count_right=count_right+1
+ end if
+ else
+ veloc_horiz = 0
+ veloc_vert = 0
+ traction_x_t0 = 0
+ traction_z_t0 = 0
+ endif
+
+ ! 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_vp = rhol*cpl
+ rho_vs = rhol*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)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+ ! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob) - veloc_horiz
+ vy = veloc_elastic(2,iglob)
+ vz = veloc_elastic(3,iglob) - veloc_vert
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ ty = rho_vs*vy
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz - traction_z_t0)*weight
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ if(p_sv)then !P-SV waves
+ b_absorb_elastic_right(1,j,ib_right(ispecabs),it) = tx*weight
+ b_absorb_elastic_right(3,j,ib_right(ispecabs),it) = tz*weight
+ else! SH (membrane) waves
+ b_absorb_elastic_right(2,j,ib_right(ispecabs),it) = ty*weight
+ endif
+ elseif(SIMULATION_TYPE == 2) then
+ if(p_sv)then !P-SV waves
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
+ b_absorb_elastic_right(1,j,ib_right(ispecabs),NSTEP-it+1)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
+ b_absorb_elastic_right(3,j,ib_right(ispecabs),NSTEP-it+1)
+ else! SH (membrane) waves
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
+ b_absorb_elastic_right(2,j,ib_right(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of right absorbing boundary
+
+ !--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+
+ j = 1
+
+ ! exclude corners to make sure there is no contradiction on the normal
+ ibegin = 1
+ iend = NGLLX
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+ ! for analytical initial plane wave for Bielak's conditions
+ ! top or bottom edge, vertical normal vector
+ if(add_Bielak_conditions .and. initialfield) then
+ if (.not.over_critical_angle) then
+ call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = mul_relaxed*(dxUz + dzUx)
+ traction_z_t0 = lambdal_relaxed*dxUx + (lambdal_relaxed+2*mul_relaxed)*dzUz
+ else
+ veloc_horiz=v0x_bot(count_bottom)
+ veloc_vert=v0z_bot(count_bottom)
+ traction_x_t0=t0x_bot(count_bottom)
+ traction_z_t0=t0z_bot(count_bottom)
+ count_bottom=count_bottom+1
+ end if
+ else
+ veloc_horiz = 0
+ veloc_vert = 0
+ traction_x_t0 = 0
+ traction_z_t0 = 0
+ endif
+
+ ! 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_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ 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)
+
+ ! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob) - veloc_horiz
+ vy = veloc_elastic(2,iglob)
+ vz = veloc_elastic(3,iglob) - veloc_vert
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ ty = rho_vs*vy
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz + traction_z_t0)*weight
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ if(p_sv)then !P-SV waves
+ b_absorb_elastic_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
+ b_absorb_elastic_bottom(3,i,ib_bottom(ispecabs),it) = tz*weight
+ else!SH (membrane) waves
+ b_absorb_elastic_bottom(2,i,ib_bottom(ispecabs),it) = ty*weight
+ endif
+ elseif(SIMULATION_TYPE == 2) then
+ if(p_sv)then !P-SV waves
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
+ b_absorb_elastic_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
+ b_absorb_elastic_bottom(3,i,ib_bottom(ispecabs),NSTEP-it+1)
+ else!SH (membrane) waves
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
+ b_absorb_elastic_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of bottom absorbing boundary
+
+ !--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+
+ j = NGLLZ
+
+ ! exclude corners to make sure there is no contradiction on the normal
+ ibegin = 1
+ iend = NGLLX
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+ ! 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, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = mul_relaxed*(dxUz + dzUx)
+ traction_z_t0 = lambdal_relaxed*dxUx + (lambdal_relaxed+2*mul_relaxed)*dzUz
+ else
+ veloc_horiz = 0
+ veloc_vert = 0
+ traction_x_t0 = 0
+ traction_z_t0 = 0
+ endif
+
+ ! 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_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ 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)
+
+ ! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob) - veloc_horiz
+ vy = veloc_elastic(2,iglob)
+ vz = veloc_elastic(3,iglob) - veloc_vert
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ ty = rho_vs*vy
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz - traction_z_t0)*weight
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ if(p_sv)then !P-SV waves
+ b_absorb_elastic_top(1,i,ib_top(ispecabs),it) = tx*weight
+ b_absorb_elastic_top(3,i,ib_top(ispecabs),it) = tz*weight
+ else!SH (membrane) waves
+ b_absorb_elastic_top(2,i,ib_top(ispecabs),it) = ty*weight
+ endif
+ elseif(SIMULATION_TYPE == 2) then
+ if(p_sv)then !P-SV waves
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_top(1,i,ib_top(ispecabs),NSTEP-it+1)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - b_absorb_elastic_top(3,i,ib_top(ispecabs),NSTEP-it+1)
+ else!SH (membrane) waves
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_top(2,i,ib_top(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of top absorbing boundary
+
+ enddo
+
+ endif ! end of absorbing boundaries
+
+ ! --- add the source if it is a moment tensor
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCES
+ ! 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
+
+ ! moment tensor
+ if(source_type(i_source) == 2) then
+
+ if(.not.p_sv) call exit_MPI('cannot have moment tensor source in SH (membrane) waves calculation')
+
+ if(SIMULATION_TYPE == 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(1,iglob) = accel_elastic(1,iglob) + &
+ sourcearray(i_source,1,i,j)*source_time_function(i_source,it)
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) + &
+ sourcearray(i_source,2,i,j)*source_time_function(i_source,it)
+ enddo
+ enddo
+ else ! backward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + &
+ sourcearray(i_source,1,i,j)*source_time_function(i_source,NSTEP-it+1)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) + &
+ sourcearray(i_source,2,i,j)*source_time_function(i_source,NSTEP-it+1)
+ enddo
+ enddo
+ endif !endif SIMULATION_TYPE == 1
+
+ endif !if(source_type(i_source) == 2)
+
+ endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCES
+
+ if(SIMULATION_TYPE == 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
+
+ irec_local = irec_local + 1
+ if(elastic(ispec_selected_rec(irec))) then
+ ! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ if(p_sv)then !P-SH waves
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
+ else !SH (membrane) waves
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,2,i,j)
+ endif
+ enddo
+ enddo
+ endif ! if element is elastic
+
+ endif ! if this processor carries the adjoint source and the source element is elastic
+ enddo ! irec = 1,nrec
+
+ endif ! if SIMULATION_TYPE == 2 adjoint wavefield
+
+ endif ! if not using an initial field
+
+ ! implement attenuation
+ if(TURN_ATTENUATION_ON) then
+
+ ! compute Grad(displ_elastic) at time step n+1 for attenuation
+ call compute_gradient_attenuation(displ_elastic,dux_dxl_np1,duz_dxl_np1, &
+ dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
+
+ ! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+ ! loop over spectral elements
+ do ispec = 1,nspec
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
+ theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
+
+ ! 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,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,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,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) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e11(i,j,ispec,i_sls) = Unp1
+
+ ! evolution e13
+ Un = e13(i,j,ispec,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,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) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e13(i,j,ispec,i_sls) = Unp1
+
+ enddo
+
+ enddo
+ enddo
+ enddo
+
+ endif ! end of test on attenuation
+
+end subroutine compute_forces_viscoelastic
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_gradient_attenuation.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_gradient_attenuation.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_gradient_attenuation.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_gradient_attenuation.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,126 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_gradient_attenuation(displ_elastic,dux_dxl,duz_dxl,dux_dzl,duz_dzl, &
+ xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
+
+! compute Grad(displ_elastic) for attenuation
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,npoin
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ logical, dimension(nspec) :: elastic
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(3,npoin) :: displ_elastic
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local variables
+ integer :: i,j,k,ispec
+
+! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+
+! jacobian
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+!---
+!--- elastic spectral element
+!---
+ if(elastic(ispec)) then
+
+! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,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(3,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of displacement
+ dux_dxl(i,j,ispec) = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl(i,j,ispec) = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl(i,j,ispec) = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl(i,j,ispec) = duz_dxi*xizl + duz_dgamma*gammazl
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+ end subroutine compute_gradient_attenuation
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_normal_vector.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_normal_vector.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_normal_vector.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_normal_vector.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,122 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine compute_normal_vector( 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)
+
+ ! a sum is needed here because in the case of a source force vector
+ ! users can give an angle with respect to the normal to the topography surface,
+ ! in which case we must compute the normal to the topography
+ ! and add it the existing rotation angle
+ angle = angle + (theta1 + theta2 + theta3) / 3.d0 + PI/2.d0
+
+ end subroutine compute_normal_vector
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine tri_quad(n, n1, nnodes)
+
+ implicit none
+
+ integer :: n1, nnodes
+ integer, dimension(4) :: n
+
+
+ n(2) = n1
+
+ if ( n1 == 1 ) then
+ n(1) = nnodes
+ else
+ n(1) = n1-1
+ endif
+
+ if ( n1 == nnodes ) then
+ n(3) = 1
+ else
+ n(3) = n1+1
+ endif
+
+ if ( n(3) == nnodes ) then
+ n(4) = 1
+ else
+ n(4) = n(3)+1
+ endif
+
+
+ end subroutine tri_quad
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_pressure.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_pressure.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_pressure.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_pressure.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,493 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ 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,npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,e1,e11, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
+
+! compute pressure in acoustic elements and in elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,npoin,numat
+
+
+ integer, dimension(nspec) :: kmato
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
+
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(6,numat) :: anisotropy
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ logical, dimension(nspec) :: elastic,poroelastic,anisotropic
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_dot_dot_acoustic
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
+
+ double precision, dimension(3,npoin) :: vector_field_display
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ logical :: assign_external_model,TURN_ATTENUATION_ON
+
+ integer :: N_SLS
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
+
+! local variables
+ integer :: i,j,ispec,iglob
+
+! pressure in this element
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+! compute pressure in this element
+ 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_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
+
+! use vector_field_display as temporary storage, store pressure in its second component
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_display(3,iglob) = pressure_element(i,j)
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine compute_pressure_whole_medium
+
+!
+!=====================================================================
+!
+
+ 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_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
+
+! compute pressure in acoustic elements and in elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,numat,ispec
+
+ integer, dimension(nspec) :: kmato
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
+
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(6,numat) :: anisotropy
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+! pressure in this element
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
+
+ logical, dimension(nspec) :: elastic,poroelastic,anisotropic
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_dot_dot_acoustic
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ logical :: assign_external_model,TURN_ATTENUATION_ON
+
+ 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, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
+ integer :: i_sls
+
+! local variables
+ integer :: i,j,k,iglob
+
+! jacobian
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
+
+! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_zz,sigmap
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dzl
+
+! material properties of the elastic medium
+ real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,denst
+ real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed,cpl,csl
+
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
+ real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
+
+! for anisotropy
+ double precision :: c11,c15,c13,c33,c35,c55
+
+! if elastic element
+!
+! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction,
+! J. Engrg. Mech., vol. 132(11), p. 1205-1214 (2006), below equation (5):
+! for a 3D isotropic solid, pressure is defined in terms of the trace of the stress tensor as
+! p = -1/3 (t11 + t22 + t33) where t is the Cauchy stress tensor.
+
+! to compute pressure in 3D in an elastic solid, one uses pressure = - trace(sigma) / 3
+! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
+! = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_ij
+! sigma_xx = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_xx
+! sigma_yy = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_yy
+! sigma_zz = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_zz
+! pressure = - trace(sigma) / 3 = - (lambda + 2/3 mu) trace(epsilon) = - kappa * trace(epsilon)
+!
+! to compute pressure in 2D in an elastic solid, one uses pressure = - trace(sigma) / 2
+! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
+! = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_ij
+! sigma_xx = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_xx
+! sigma_yy = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_yy
+! pressure = - trace(sigma) / 2 = - (lambda + mu) trace(epsilon)
+!
+
+
+ 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))
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ !--- if external medium, get elastic parameters of current grid point
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ mul_relaxed = denst*csl*csl
+ lambdal_relaxed = denst*cpl*cpl - TWO*mul_relaxed
+ endif
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,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(3,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+! compute diagonal components of the stress tensor (include attenuation or anisotropy if needed)
+
+ if(TURN_ATTENUATION_ON) then
+
+! attenuation is implemented following the memory variable formulation of
+! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993). More details can be found in
+! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+ ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(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)
+ sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
+
+ ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
+ ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
+ e1_sum = 0._CUSTOM_REAL
+ e11_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_SLS
+ e1_sum = e1_sum + e1(i,j,ispec,i_sls)
+ e11_sum = e11_sum + e11(i,j,ispec,i_sls)
+ enddo
+
+ sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum &
+ + TWO * mul_relaxed * e11_sum
+ sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum &
+ - TWO * mul_relaxed * e11_sum
+
+ else
+
+ ! no attenuation
+ sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
+ sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+
+ endif
+
+ ! full anisotropy
+ if(anisotropic(ispec)) then
+ if(assign_external_model) then
+ c11 = c11ext(i,j,ispec)
+ c15 = c15ext(i,j,ispec)
+ c13 = c13ext(i,j,ispec)
+ c33 = c33ext(i,j,ispec)
+ c35 = c35ext(i,j,ispec)
+ c55 = c55ext(i,j,ispec)
+ else
+ c11 = anisotropy(1,kmato(ispec))
+ c13 = anisotropy(2,kmato(ispec))
+ c15 = anisotropy(3,kmato(ispec))
+ c33 = anisotropy(4,kmato(ispec))
+ c35 = anisotropy(5,kmato(ispec))
+ c55 = anisotropy(6,kmato(ispec))
+ endif
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ ! implement anisotropy in 2D
+ sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
+ sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
+
+ endif
+
+ ! store pressure
+ pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
+
+ enddo
+ enddo
+
+ elseif(poroelastic(ispec)) then
+
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+
+ ! get poroelastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ !solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+ !fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ !frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+ !Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
+ + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ !where T = G:grad u_s + C div w I
+ !and T_f = C div u_s I + M div w I
+ !we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
+ mul_G = mul_fr
+ lambdal_G = H_biot - TWO*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+! compute diagonal components of the stress tensor (include attenuation if needed)
+
+ if(TURN_ATTENUATION_ON) then
+!-------------------- ATTENTION TO BE DEFINED ------------------------------!
+
+! attenuation is implemented following the memory variable formulation of
+! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993). More details can be found in
+! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+ ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(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)
+ sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
+
+ ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
+ ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
+ e1_sum = 0._CUSTOM_REAL
+ e11_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_SLS
+ e1_sum = e1_sum + e1(i,j,ispec,i_sls)
+ e11_sum = e11_sum + e11(i,j,ispec,i_sls)
+ enddo
+
+ sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum &
+ + TWO * mul_relaxed * e11_sum
+ sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum &
+ - TWO * mul_relaxed * e11_sum
+
+ else
+
+ ! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+ endif
+
+ ! store pressure
+ pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
+! pressure_element2(i,j) = - sigmap
+ enddo
+ enddo
+
+! pressure = - Chi_dot_dot if acoustic element
+ else
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ ! store pressure
+ pressure_element(i,j) = - potential_dot_dot_acoustic(iglob)
+
+ enddo
+ enddo
+
+ endif ! end of test if acoustic or elastic element
+
+ end subroutine compute_pressure_one_element
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_vector_field.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/compute_vector_field.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_vector_field.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/compute_vector_field.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,235 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+! compute Grad(potential) in acoustic elements
+! and combine with existing velocity vector field in elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ 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
+
+ logical, dimension(nspec) :: elastic,poroelastic
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: veloc_elastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: velocs_poroelastic
+
+ double precision, dimension(3,npoin) :: vector_field_display
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local variables
+ integer i,j,ispec,iglob
+
+! vector field in this element
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
+
+! loop over spectral elements
+ 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_acoustic,npoin_elastic,npoin_poroelastic, &
+ ispec,numat,kmato,density,rhoext,assign_external_model)
+
+! store the result
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_display(:,iglob) = vector_field_element(:,i,j)
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine compute_vector_whole_medium
+
+!
+!=====================================================================
+!
+
+ 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_acoustic,npoin_elastic,npoin_poroelastic, &
+ ispec,numat,kmato,density,rhoext,assign_external_model)
+
+! compute Grad(potential) if acoustic element or copy existing vector if elastic element
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,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
+
+! vector field in this element
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
+
+ logical, dimension(nspec) :: elastic,poroelastic
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: veloc_elastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: velocs_poroelastic
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local variables
+ integer i,j,k,iglob
+
+! space derivatives
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l
+ real(kind=CUSTOM_REAL) hp1,hp2
+
+! 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
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_element(1,i,j) = veloc_elastic(1,iglob)
+ vector_field_element(2,i,j) = veloc_elastic(2,iglob)
+ vector_field_element(3,i,j) = veloc_elastic(3,iglob)
+ enddo
+ enddo
+
+ elseif(poroelastic(ispec)) then
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_element(1,i,j) = velocs_poroelastic(1,iglob)
+ vector_field_element(2,i,j) = 0._CUSTOM_REAL
+ vector_field_element(3,i,j) = velocs_poroelastic(2,iglob)
+ enddo
+ enddo
+
+! compute gradient of potential to calculate vector if acoustic element
+! we then need to divide by density because the potential is a potential of (density * displacement)
+ else
+
+ rhol = density(1,kmato(ispec))
+
+! double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x
+ tempx1l = 0._CUSTOM_REAL
+ do k = 1,NGLLX
+ hp1 = hprime_xx(i,k)
+ iglob = ibool(k,j,ispec)
+ tempx1l = tempx1l + potential_acoustic(iglob)*hp1
+ enddo
+
+! derivative along z
+ tempx2l = 0._CUSTOM_REAL
+ do k = 1,NGLLZ
+ hp2 = hprime_zz(j,k)
+ iglob = ibool(i,k,ispec)
+ tempx2l = tempx2l + potential_acoustic(iglob)*hp2
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ if(assign_external_model) rhol = rhoext(i,j,ispec)
+
+! derivatives of potential
+ vector_field_element(1,i,j) = (tempx1l*xixl + tempx2l*gammaxl) / rhol
+ vector_field_element(2,i,j) = 0._CUSTOM_REAL
+ vector_field_element(3,i,j) = (tempx1l*xizl + tempx2l*gammazl) / rhol
+
+ enddo
+ enddo
+
+ endif ! end of test if acoustic or elastic element
+
+ end subroutine compute_vector_one_element
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/construct_acoustic_surface.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/construct_acoustic_surface.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/construct_acoustic_surface.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/construct_acoustic_surface.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,194 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! From array 'surface' (element, type : node/edge, node(s) ) that describes the
+! acoustic free surface, determines the points (ixmin, ixmax, izmin and izmax) on the surface
+! for each element.
+! We chose to have ixmin <= ixmax and izmin <= izmax, so as to be able to have DO loops on it with
+! an increment of +1.
+!
+subroutine construct_acoustic_surface ( nspec, ngnod, knods, nsurface, surface, tab_surface )
+
+ implicit none
+
+ integer, intent(in) :: nspec
+ integer, intent(in) :: ngnod
+ integer, dimension(ngnod,nspec), intent(in) :: knods
+ integer, intent(in) :: nsurface
+ integer, dimension(4,nsurface), intent(in) :: surface
+ integer, dimension(5,nsurface), intent(out) :: tab_surface
+
+ integer :: i, k
+ integer :: ixmin, ixmax
+ integer :: izmin, izmax
+ integer, dimension(ngnod) :: n
+ integer :: e1, e2
+ integer :: type
+
+ do i = 1, nsurface
+ tab_surface(1,i) = surface(1,i)
+ type = surface(2,i)
+ e1 = surface(3,i)
+ e2 = surface(4,i)
+ do k = 1, ngnod
+ n(k) = knods(k,tab_surface(1,i))
+ enddo
+
+ call get_acoustic_edge ( ngnod, n, type, e1, e2, ixmin, ixmax, izmin, izmax )
+
+ tab_surface(2,i) = ixmin
+ tab_surface(3,i) = ixmax
+ tab_surface(4,i) = izmin
+ tab_surface(5,i) = izmax
+
+ enddo
+
+end subroutine construct_acoustic_surface
+
+
+!-----------------------------------------------
+! Get the points (ixmin, ixmax, izmin and izmax) on an node/edge for one element.
+!-----------------------------------------------
+subroutine get_acoustic_edge ( ngnod, n, type, e1, e2, ixmin, ixmax, izmin, izmax )
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: ngnod
+ integer, dimension(ngnod), intent(in) :: n
+ integer, intent(in) :: type, e1, e2
+ integer, intent(out) :: ixmin, ixmax, izmin, izmax
+
+
+ if ( type == 1 ) then
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ ixmax = 1
+ izmin = 1
+ izmax = 1
+ endif
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ izmin = 1
+ izmax = 1
+ endif
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ izmin = NGLLZ
+ izmax = NGLLZ
+ endif
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ ixmax = 1
+ izmin = NGLLZ
+ izmax = NGLLZ
+ endif
+
+ else
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ izmin = 1
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ izmax = 1
+
+ endif
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ izmax = NGLLZ
+
+ endif
+ endif
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ izmin = 1
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ izmax = NGLLZ
+
+ endif
+ if ( e2 == n(1) ) then
+ ixmax = ixmin
+ ixmin = 1
+ izmax = 1
+
+ endif
+ endif
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ izmin = NGLLZ
+ if ( e2 == n(4) ) then
+ ixmax = ixmin
+ ixmin = 1
+ izmax = NGLLZ
+
+ endif
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ izmax = izmin
+ izmin = 1
+
+ endif
+ endif
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ izmin = NGLLZ
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ izmax = izmin
+ izmin = 1
+
+ endif
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ izmax = NGLLZ
+
+ endif
+ endif
+ endif
+
+end subroutine get_acoustic_edge
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/convert_time.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/convert_time.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/convert_time.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/convert_time.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,235 @@
+
+! open-source subroutines taken from the World Ocean Circulation Experiment (WOCE)
+! web site at http://www.coaps.fsu.edu/woce/html/wcdtools.htm
+
+! converted to Fortran90 by Dimitri Komatitsch,
+! University of Pau, France, January 2008.
+! Also converted "convtime" from a function to a subroutine.
+! Also used a more complete test to detect leap years (the original version was incomplete).
+
+ subroutine convtime(timestamp,yr,mon,day,hr,min)
+
+! Originally written by Shawn Smith (ssmith AT coaps.fsu.edu)
+! Updated Spring 1999 for Y2K compliance by Anthony Arguez (anthony AT coaps.fsu.edu).
+
+! This subroutine will convert a given year, month, day, hour, and
+! minutes to a minutes from 01 Jan 1980 00:00 time stamp.
+
+ implicit none
+
+ integer, intent(out) :: timestamp
+
+ integer, intent(in) :: yr,mon,day,hr,min
+
+ integer :: year(1980:2020),month(12),leap_mon(12)
+
+ integer :: min_day,min_hr
+
+! function to determine if year is a leap year
+ logical, external :: is_leap_year
+
+ data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
+ 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
+ 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
+ 9993600, 10519200, 11046240, 11571840, 12097440, &
+ 12623040, 13150080, 13675680, 14201280, 14726880, &
+ 15253920, 15779520, 16305120, 16830720, 17357760, &
+ 17883360, 18408960, 18934560, 19461600, 19987200, &
+ 20512800, 21038400/
+
+ data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
+ 305280, 349920, 393120, 437760, 480960/
+
+ data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
+ 306720, 351360, 394560, 439200, 482400/
+
+ data min_day, min_hr /1440, 60/
+
+! Test values to see if they fit valid ranges
+ if (yr < 1980 .or. yr > 2020) stop 'Error in convtime: year out of range (1980-2020)'
+
+ if (mon < 1 .or. mon > 12) stop 'Error in convtime: month out of range (1-12)'
+
+ if (mon == 2) then
+ if (is_leap_year(yr) .and. (day < 1 .or. day > 29)) then
+ stop 'Error in convtime: February day out of range (1-29)'
+ elseif (.not. is_leap_year(yr) .and. (day < 1 .or. day > 28)) then
+ stop 'Error in convtime: February day out of range (1-28)'
+ endif
+ elseif (mon == 4 .or. mon == 6 .or. mon == 9 .or. mon == 11) then
+ if (day < 1 .or. day > 30) stop 'Error in convtime: day out of range (1-30)'
+ else
+ if (day < 1 .or. day > 31) stop 'Error in convtime: day out of range (1-31)'
+ endif
+
+ if (hr < 0 .or. hr > 23) stop 'Error in convtime: hour out of range (0-23)'
+
+ if (min < 0 .or. min > 60) stop 'Error in convtime: minute out of range (0-60)'
+
+! convert time (test if leap year)
+ if (is_leap_year(yr)) then
+ timestamp = year(yr)+leap_mon(mon)+((day-1)*min_day)+(hr*min_hr)+min
+ else
+ timestamp = year(yr)+month(mon)+((day-1)*min_day)+(hr*min_hr)+min
+ endif
+
+ end subroutine convtime
+
+!
+!----
+!
+
+ subroutine invtime(timestamp,yr,mon,day,hr,min)
+
+! This subroutine will convert a minutes timestamp to a year/month
+! date. Based on the function convtime by Shawn Smith (COAPS).
+!
+! Written the spring of 1995, several iterations.
+! James N. Stricherz (stricherz AT coaps.fsu.edu)
+!
+! Updated for Y2K compliance in July 1999.
+! Shyam Lakshmin (lakshmin AT coaps.fsu.edu)
+!
+! This code returns correct results for the range of 01 Jan 1980 00:00
+! thru 31 Dec 2020 23:59. I know it does, because I tried each minute of that range.
+
+ implicit none
+
+ integer, intent(in) :: timestamp
+
+ integer, intent(out) :: yr,mon,day,hr,min
+
+ integer :: year(1980:2021),month(13),leap_mon(13)
+
+ integer :: min_day,min_hr,itime,tmon,ttime,thour,iyr,imon,iday,ihour
+
+! function to determine if year is a leap year
+ logical, external :: is_leap_year
+
+ data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
+ 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
+ 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
+ 9993600, 10519200, 11046240, 11571840, 12097440, &
+ 12623040, 13150080, 13675680, 14201280, 14726880, &
+ 15253920, 15779520, 16305120, 16830720, 17357760, &
+ 17883360, 18408960, 18934560, 19461600, 19987200, &
+ 20512800, 21038400, 21565440/
+
+ data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
+ 305280, 349920, 393120, 437760, 480960,525600/
+
+ data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
+ 306720, 351360, 394560, 439200, 482400,527040/
+
+ data min_day, min_hr /1440, 60/
+
+! ok, let us invert the effects of the years: subtract off the
+! number of minutes per year until it goes negative
+! iyr then gives the year that the time (in minutes) occurs
+ if (timestamp >= year(2021)) stop 'year too high in invtime'
+
+ iyr=1979
+ itime=timestamp
+
+ 10 iyr=iyr+1
+ ttime=itime-year(iyr)
+ if (ttime <= 0) then
+ if (iyr == 1980) iyr=iyr+1
+ iyr=iyr-1
+ itime=itime-year(iyr)
+ else
+ goto 10
+ endif
+
+! assign the return variable
+ yr=iyr
+
+! ok, the remaining time is less than one full year, so convert
+! by the same method as above into months
+ imon=0
+
+! if not leap year
+ if (.not. is_leap_year(iyr)) then
+
+! increment the month, and subtract off the minutes from the
+! remaining time for a non-leap year
+ 20 imon=imon+1
+ tmon=itime-month(imon)
+ if (tmon > 0) then
+ goto 20
+ else if (tmon < 0) then
+ imon=imon-1
+ itime=itime-month(imon)
+ else
+ if (imon > 12) then
+ imon=imon-12
+ yr=yr+1
+ endif
+ mon=imon
+ day=1
+ hr=0
+ min=0
+ return
+ endif
+
+! if leap year
+ else
+
+! same thing, same code, but for a leap year
+ 30 imon=imon+1
+ tmon=itime-leap_mon(imon)
+ if (tmon > 0) then
+ goto 30
+ elseif (tmon < 0) then
+ imon=imon-1
+ itime=itime-month(imon)
+ else
+ if (imon > 12) then
+ imon=imon-12
+ yr=yr+1
+ endif
+ mon=imon
+ day=1
+ hr=0
+ min=0
+ return
+ endif
+ endif
+
+! assign the return variable
+ mon=imon
+
+! any remaining minutes will belong to day/hour/minutes
+! ok, let us get the days
+ iday=0
+ 40 iday=iday+1
+ ttime=itime-min_day
+ if (ttime >= 0) then
+ itime=ttime
+ goto 40
+ endif
+
+! assign the return variable
+ if (is_leap_year(iyr) .and. mon > 2) then
+ day=iday-1
+ else
+ day=iday
+ endif
+
+! pick off the hours of the days...remember, hours can be 0, so we start at -1
+ ihour=-1
+ 50 ihour=ihour+1
+ thour=itime-min_hr
+ if (thour >= 0) then
+ itime=thour
+ goto 50
+ endif
+
+! assign the return variables
+ hr=ihour
+
+! the remainder at this point is the minutes, so return them directly
+ min=itime
+
+ end subroutine invtime
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/create_color_image.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/create_color_image.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/create_color_image.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/create_color_image.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,267 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine create_color_image(color_image_2D_data,iglob_image_color_2D, &
+ NX,NY,it,cutsnaps,image_color_vp_display)
+
+! display a given field as a red and blue color image
+
+! to display the snapshots : display image*.gif
+
+! when compiling with Intel ifort, use " -assume byterecl " option to create binary PNM images
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NX,NY,it
+
+ double precision :: cutsnaps
+
+ integer, dimension(NX,NY) :: iglob_image_color_2D
+
+ double precision, dimension(NX,NY) :: color_image_2D_data
+ double precision, dimension(NX,NY) :: image_color_vp_display
+
+ integer :: ix,iy,R,G,B,tenthousands,thousands,hundreds,tens,units,remainder,current_rec
+
+ double precision :: amplitude_max,normalized_value,vpmin,vpmax,x1
+
+ character(len=100) :: file_name,system_command
+
+! create temporary image files in binary PNM P6 format (smaller) or ASCII PNM P3 format (easier to edit)
+ logical, parameter :: BINARY_FILE = .true.
+
+! ASCII code of character '0' and of carriage return character
+ integer, parameter :: ascii_code_of_zero = 48, ascii_code_of_carriage_return = 10
+
+! open the image file
+ write(file_name,"('OUTPUT_FILES/image',i7.7,'.pnm')") it
+
+ if(BINARY_FILE) then
+
+ open(unit=27,file=file_name,status='unknown',access='direct',recl=1)
+ write(27,rec=1) 'P'
+ write(27,rec=2) '6' ! write P6 = binary PNM image format
+ write(27,rec=3) char(ascii_code_of_carriage_return)
+
+! compute and write horizontal size
+ remainder = NX
+
+ tenthousands = remainder / 10000
+ remainder = remainder - 10000 * tenthousands
+
+ thousands = remainder / 1000
+ remainder = remainder - 1000 * thousands
+
+ hundreds = remainder / 100
+ remainder = remainder - 100 * hundreds
+
+ tens = remainder / 10
+ remainder = remainder - 10 * tens
+
+ units = remainder
+
+ write(27,rec=4) char(tenthousands + ascii_code_of_zero)
+ write(27,rec=5) char(thousands + ascii_code_of_zero)
+ write(27,rec=6) char(hundreds + ascii_code_of_zero)
+ write(27,rec=7) char(tens + ascii_code_of_zero)
+ write(27,rec=8) char(units + ascii_code_of_zero)
+ write(27,rec=9) ' '
+
+! compute and write vertical size
+ remainder = NY
+
+ tenthousands = remainder / 10000
+ remainder = remainder - 10000 * tenthousands
+
+ thousands = remainder / 1000
+ remainder = remainder - 1000 * thousands
+
+ hundreds = remainder / 100
+ remainder = remainder - 100 * hundreds
+
+ tens = remainder / 10
+ remainder = remainder - 10 * tens
+
+ units = remainder
+
+ write(27,rec=10) char(tenthousands + ascii_code_of_zero)
+ write(27,rec=11) char(thousands + ascii_code_of_zero)
+ write(27,rec=12) char(hundreds + ascii_code_of_zero)
+ write(27,rec=13) char(tens + ascii_code_of_zero)
+ write(27,rec=14) char(units + ascii_code_of_zero)
+ write(27,rec=15) char(ascii_code_of_carriage_return)
+
+! number of shades
+ write(27,rec=16) '2'
+ write(27,rec=17) '5'
+ write(27,rec=18) '5'
+ write(27,rec=19) char(ascii_code_of_carriage_return)
+
+! block of image data starts at sixteenth character
+ current_rec = 20
+
+ else
+
+ open(unit=27,file=file_name,status='unknown')
+ write(27,"('P3')") ! write P3 = ASCII PNM image format
+ write(27,*) NX,NY ! write image size
+ write(27,*) '255' ! number of shades
+
+ endif
+
+! compute maximum amplitude
+ amplitude_max = maxval(abs(color_image_2D_data))
+ vpmin = HUGEVAL
+ vpmax = TINYVAL
+ do iy=1,NY
+ do ix=1,NX
+ if ( iglob_image_color_2D(ix,iy) > -1 ) then
+ vpmin = min(vpmin,image_color_vp_display(ix,iy))
+ vpmax = max(vpmax,image_color_vp_display(ix,iy))
+ endif
+
+ enddo
+ enddo
+
+! in the PNM format, the image starts in the upper-left corner
+ do iy=NY,1,-1
+ do ix=1,NX
+
+! check if pixel is defined or not (can be above topography for instance)
+ if(iglob_image_color_2D(ix,iy) == -1) then
+
+! use light blue to display undefined region above topography
+ R = 204
+ G = 255
+ B = 255
+
+! suppress small amplitudes considered as noise
+ else if (abs(color_image_2D_data(ix,iy)) < amplitude_max * cutsnaps) then
+
+! use P velocity model as background where amplitude is negligible
+ if((vpmax-vpmin)/vpmin > 0.02d0) then
+ x1 = (image_color_vp_display(ix,iy)-vpmin)/(vpmax-vpmin)
+ else
+ x1 = 0.5d0
+ endif
+
+! rescale to avoid very dark gray levels
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+! invert scale: white = vpmin, dark gray = vpmax
+ x1 = 1.d0 - x1
+
+! map to [0,255]
+ x1 = x1 * 255.d0
+
+ R = nint(x1)
+ if(R < 0) R = 0
+ if(R > 255) R = 255
+ G = R
+ B = R
+
+ else
+
+! define normalized image data in [-1:1] and convert to nearest integer
+! keeping in mind that data values can be negative
+ normalized_value = color_image_2D_data(ix,iy) / amplitude_max
+
+! suppress values outside of [-1:+1]
+ if(normalized_value < -1.d0) normalized_value = -1.d0
+ if(normalized_value > 1.d0) normalized_value = 1.d0
+
+! use red if positive value, blue if negative, no green
+ if(normalized_value >= 0.d0) then
+ R = nint(255.d0*normalized_value**POWER_DISPLAY_COLOR)
+ G = 0
+ B = 0
+ else
+ R = 0
+ G = 0
+ B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY_COLOR)
+ endif
+
+ endif
+
+! write color image
+ if(BINARY_FILE) then
+
+! first write red
+ write(27,rec=current_rec) char(R)
+ current_rec = current_rec + 1
+
+! then write green
+ write(27,rec=current_rec) char(G)
+ current_rec = current_rec + 1
+
+! then write blue
+ write(27,rec=current_rec) char(B)
+ current_rec = current_rec + 1
+
+ else
+
+ write(27,"(i3,' ',i3,' ',i3)") R,G,B
+
+ endif
+
+ enddo
+ enddo
+
+! close the file
+ close(27)
+
+! open image file and create system command to convert image to more convenient format
+! use the "convert" command from ImageMagick http://www.imagemagick.org
+ write(system_command,"('cd OUTPUT_FILES ; convert image',i7.7,'.pnm image',i7.7,'.gif ; rm -f image',i7.7,'.pnm')") it,it,it
+
+! call the system to convert image to GIF
+! this line can be safely commented out if your compiler does not implement "system()" for system calls;
+! in such a case you will simply get images in PNM format in directory OUTPUT_FILES instead of GIF format
+ call system(system_command)
+
+ end subroutine create_color_image
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/createnum_fast.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/createnum_fast.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/createnum_fast.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/createnum_fast.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,343 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
+
+! same as subroutine "createnum_slow" but with a faster algorithm
+
+ implicit none
+
+ include "constants.h"
+
+ 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)
+
+ integer i,j
+
+! additional arrays needed for this fast version
+ integer, dimension(:), allocatable :: loc,ind,ninseg,iglob,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: xp,yp,work
+
+ integer ie,nseg,ioff,iseg,ig
+ integer nxyz,ntot,ispec,ieoff,ilocnum,iy,ix,in,nnum
+
+ double precision xmaxval,xminval,ymaxval,yminval,xtol,xtypdist
+ double precision xcor,ycor
+
+
+!---- create global mesh numbering
+ 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
+
+ allocate(loc(ntot))
+ allocate(ind(ntot))
+ allocate(ninseg(ntot))
+ allocate(iglob(ntot))
+ allocate(ifseg(ntot))
+ allocate(xp(ntot))
+ allocate(yp(ntot))
+ allocate(work(ntot))
+ allocate(iwork(ntot))
+
+! compute coordinates of the grid points
+ do ispec=1,nspec
+ ieoff = nxyz*(ispec - 1)
+ ilocnum = 0
+
+ do iy = 1,NGLLX
+ do ix = 1,NGLLX
+
+ ilocnum = ilocnum + 1
+
+ xcor = zero
+ ycor = zero
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xcor = xcor + shape(in,ix,iy)*coorg(1,nnum)
+ ycor = ycor + shape(in,ix,iy)*coorg(2,nnum)
+ enddo
+
+ xp(ilocnum + ieoff) = xcor
+ yp(ilocnum + ieoff) = ycor
+
+ enddo
+ enddo
+
+ enddo
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+! Establish initial pointers
+ do ie=1,nspec
+ ieoff = nxyz*(ie -1)
+ do ix=1,nxyz
+ loc (ix+ieoff) = ix+ieoff
+ enddo
+ enddo
+
+! set up local geometric tolerances
+
+ xtypdist=+HUGEVAL
+
+ do ie=1,nspec
+
+ xminval=+HUGEVAL
+ yminval=+HUGEVAL
+ xmaxval=-HUGEVAL
+ ymaxval=-HUGEVAL
+ ieoff=nxyz*(ie-1)
+ do ilocnum=1,nxyz
+ xmaxval=max(xp(ieoff+ilocnum),xmaxval)
+ xminval=min(xp(ieoff+ilocnum),xminval)
+ ymaxval=max(yp(ieoff+ilocnum),ymaxval)
+ yminval=min(yp(ieoff+ilocnum),yminval)
+ enddo
+
+! compute the minimum typical "size" of an element in the mesh
+ xtypdist = min(xtypdist,xmaxval-xminval)
+ xtypdist = min(xtypdist,ymaxval-yminval)
+
+ enddo
+
+! define a tolerance, small with respect to the minimum size
+ xtol = SMALLVALTOL * xtypdist
+
+ ifseg(:) = .false.
+ nseg = 1
+ ifseg(1) = .true.
+ ninseg(1) = ntot
+
+ do j=1,NDIM
+! Sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+ call rank (xp(ioff),ind,ninseg(iseg))
+ else
+ call rank (yp(ioff),ind,ninseg(iseg))
+ endif
+ call swap(xp(ioff),work,ind,ninseg(iseg))
+ call swap(yp(ioff),work,ind,ninseg(iseg))
+ call iswap(loc(ioff),iwork,ind,ninseg(iseg))
+ ioff=ioff+ninseg(iseg)
+ enddo
+! Check for jumps in current coordinate
+ if (j == 1) then
+ do i=2,ntot
+ if (abs(xp(i)-xp(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else
+ do i=2,ntot
+ if (abs(yp(i)-yp(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ endif
+! Count up number of different segments
+ nseg = 0
+ do i=1,ntot
+ if (ifseg(i)) then
+ nseg = nseg+1
+ ninseg(nseg) = 1
+ else
+ ninseg(nseg) = ninseg(nseg) + 1
+ endif
+ enddo
+ enddo
+!
+! Assign global node numbers (now sorted lexicographically!)
+!
+ ig = 0
+ do i=1,ntot
+ if (ifseg(i)) ig=ig+1
+ iglob(loc(i)) = ig
+ enddo
+
+ npoin = ig
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+! get result in my format
+ do ispec=1,nspec
+ ieoff = nxyz*(ispec - 1)
+ ilocnum = 0
+ do iy = 1,NGLLX
+ do ix = 1,NGLLX
+ ilocnum = ilocnum + 1
+ ibool(ix,iy,ispec) = iglob(ilocnum + ieoff)
+ enddo
+ enddo
+ enddo
+
+ deallocate(loc)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(ifseg)
+ deallocate(xp)
+ deallocate(yp)
+ deallocate(work)
+ deallocate(iwork)
+
+! 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
+
+ end subroutine createnum_fast
+
+
+!-----------------------------------------------------------------------
+
+ subroutine rank(A,IND,N)
+!
+! Use Heap Sort (p 233 Numerical Recipes)
+!
+ implicit none
+
+ integer N
+ double precision A(N)
+ integer IND(N)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do J=1,N
+ IND(j)=j
+ enddo
+
+ if(n == 1) return
+ L=n/2+1
+ ir=n
+ 100 continue
+ IF(l > 1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if(ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 continue
+ IF(J <= IR) THEN
+ IF(J < IR) THEN
+ IF(A(IND(j)) < A(IND(j+1))) j=j+1
+ ENDIF
+ IF(q < A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ GOTO 200
+ ENDIF
+ IND(I)=INDX
+ GOTO 100
+
+ end subroutine rank
+
+!-----------------------------------------------------------------------
+
+ subroutine swap(a,w,ind,n)
+!
+! Use IND to sort array A (p 233 Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(N),W(N)
+ integer IND(N)
+
+ integer j
+
+ W(:) = A(:)
+
+ do J=1,N
+ A(j) = W(ind(j))
+ enddo
+
+ end subroutine swap
+
+!-----------------------------------------------------------------------
+
+ subroutine iswap(a,w,ind,n)
+!
+! Use IND to sort array A
+!
+ implicit none
+
+ integer n
+ integer A(N),W(N),IND(N)
+
+ integer j
+
+ W(:) = A(:)
+
+ do J=1,N
+ A(j) = W(ind(j))
+ enddo
+
+ end subroutine iswap
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/createnum_slow.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/createnum_slow.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/createnum_slow.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/createnum_slow.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,324 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
+
+! generate the global numbering
+
+ implicit none
+
+ include "constants.h"
+
+ integer npoin,nspec,ngnod,myrank,ipass
+
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
+
+ integer i,j,num2,i2,j2,ipos,ipos2,iloc,jloc,kloc
+ integer ngnodloc,ngnodother,nedgeloc,nedgeother,npedge,numelem,npcorn
+
+ logical alreadyexist
+
+ integer, dimension(NEDGES) :: ngnod_begin,ngnod_end
+
+
+!---- create global mesh numbering
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Generating global mesh numbering (slow version)...'
+ write(IOUT,*)
+ endif
+
+ npoin = 0
+ npedge = 0
+ npcorn = 0
+
+! define edges from the four control points
+
+! --- edge 1 linking point 1 to point 2
+ ngnod_begin(1)= 1
+ ngnod_end(1)= 2
+
+! --- edge 2 linking point 2 to point 3
+ ngnod_begin(2)= 2
+ ngnod_end(2)= 3
+
+! --- edge 3 linking point 3 to point 4
+ ngnod_begin(3)= 3
+ ngnod_end(3)= 4
+
+! --- edge 4 linking point 4 to point 1
+ ngnod_begin(4)= 4
+ ngnod_end(4)= 1
+
+! initialisation du tableau de numerotation globale
+ ibool(:,:,:) = 0
+
+ do numelem = 1,nspec
+ do i=1,NGLLX
+ do j=1,NGLLZ
+
+! verifier que le point n'a pas deja ete genere
+
+ if(ibool(i,j,numelem) == 0) then
+
+!
+!---- point interieur a un element, donc forcement unique
+!
+ if(i /= 1 .and. i /= NGLLX .and. j /= 1 .and. j /= NGLLZ) then
+
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+
+!
+!---- point au coin d'un element, rechercher les coins des autres elements
+!
+ else if((i == 1 .and. j == 1) .or. (i == 1 .and. j == NGLLZ) .or. &
+ (i == NGLLX .and. j == 1) .or. (i == NGLLX .and. j == NGLLZ)) then
+
+! trouver numero local du coin
+ if(i == 1 .and. j == 1) then
+ ngnodloc = 1
+ else if(i == NGLLX .and. j == 1) then
+ ngnodloc = 2
+ else if(i == NGLLX .and. j == NGLLZ) then
+ ngnodloc = 3
+ else if(i == 1 .and. j == NGLLZ) then
+ ngnodloc = 4
+ endif
+
+! rechercher si existe deja, forcement dans un element precedent
+
+ alreadyexist = .false.
+
+ if(numelem > 1) then
+
+ do num2=1,numelem-1
+
+! ne rechercher que sur les 4 premiers points de controle et non sur ngnod
+ do ngnodother=1,4
+
+! voir si ce coin a deja ete genere
+ if(knods(ngnodother,num2) == knods(ngnodloc,numelem)) then
+ alreadyexist = .true.
+
+! obtenir la numerotation dans l'autre element
+ if(ngnodother == 1) then
+ i2 = 1
+ j2 = 1
+ else if(ngnodother == 2) then
+ i2 = NGLLX
+ j2 = 1
+ else if(ngnodother == 3) then
+ i2 = NGLLX
+ j2 = NGLLZ
+ else if(ngnodother == 4) then
+ i2 = 1
+ j2 = NGLLZ
+ else
+ call exit_MPI('bad corner')
+ endif
+
+! affecter le meme numero
+ ibool(i,j,numelem) = ibool(i2,j2,num2)
+
+! sortir de la recherche
+ goto 134
+
+ endif
+ enddo
+ enddo
+
+ 134 continue
+
+ endif
+
+! si un ancien point n'a pas ete trouve, en generer un nouveau
+ if(.not. alreadyexist) then
+ npcorn = npcorn + 1
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+ endif
+
+!
+!---- point a l'interieur d'une arete, rechercher si autre arete correspondante
+!
+ else
+
+! trouver numero local de l'arete
+ if(j == 1) then
+ nedgeloc = 1
+ else if(i == NGLLX) then
+ nedgeloc = 2
+ else if(j == NGLLZ) then
+ nedgeloc = 3
+ else if(i == 1) then
+ nedgeloc = 4
+ endif
+
+! rechercher si existe deja, forcement dans un element precedent
+
+ alreadyexist = .false.
+
+ if(numelem > 1) then
+
+ do num2=1,numelem-1
+
+! rechercher sur les 4 aretes
+ do nedgeother=1,4
+
+!--- detecter un eventuel defaut dans la structure topologique du maillage
+
+ if((knods(ngnod_begin(nedgeother),num2) == knods(ngnod_begin(nedgeloc),numelem)) &
+ .and. &
+ (knods(ngnod_end(nedgeother),num2) == knods(ngnod_end(nedgeloc),numelem))) then
+ call exit_MPI('Improper topology of the input mesh detected')
+
+!--- sinon voir si cette arete a deja ete generee
+
+ else if((knods(ngnod_begin(nedgeother),num2) == knods(ngnod_end(nedgeloc),numelem)) &
+ .and. &
+ (knods(ngnod_end(nedgeother),num2) == knods(ngnod_begin(nedgeloc),numelem))) then
+
+ alreadyexist = .true.
+
+! obtenir la numerotation dans l'autre element
+! maillage conforme donc on doit supposer que NGLLX == NGLLZ
+
+! generer toute l'arete pour eviter des recherches superflues
+ do kloc = 2,NGLLX-1
+
+! calculer l'abscisse le long de l'arete de depart
+ if(nedgeloc == 1) then
+ iloc = kloc
+ jloc = 1
+ ipos = iloc
+ else if(nedgeloc == 2) then
+ iloc = NGLLX
+ jloc = kloc
+ ipos = jloc
+ else if(nedgeloc == 3) then
+ iloc = kloc
+ jloc = NGLLZ
+ ipos = NGLLX - iloc + 1
+ else if(nedgeloc == 4) then
+ iloc = 1
+ jloc = kloc
+ ipos = NGLLZ - jloc + 1
+ else
+ call exit_MPI('bad nedgeloc')
+ endif
+
+! calculer l'abscisse le long de l'arete d'arrivee
+! topologie du maillage coherente, donc sens de parcours des aretes opposes
+
+ ipos2 = NGLLX - ipos + 1
+
+! calculer les coordonnees reelles dans l'element d'arrivee
+ if(nedgeother == 1) then
+ i2 = ipos2
+ j2 = 1
+ else if(nedgeother == 2) then
+ i2 = NGLLX
+ j2 = ipos2
+ else if(nedgeother == 3) then
+ i2 = NGLLX - ipos2 + 1
+ j2 = NGLLZ
+ else if(nedgeother == 4) then
+ i2 = 1
+ j2 = NGLLZ - ipos2 + 1
+ else
+ call exit_MPI('bad nedgeother')
+ endif
+
+! verifier que le point de depart n'existe pas deja
+ 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) call exit_MPI('unknown point in the mesh')
+
+! affecter le meme numero
+ ibool(iloc,jloc,numelem) = ibool(i2,j2,num2)
+
+ enddo
+
+! sortir de la recherche
+ goto 135
+
+ endif
+ enddo
+ enddo
+
+ 135 continue
+
+ endif
+
+! si un ancien point n'a pas ete trouve, en generer un nouveau
+ if(.not. alreadyexist) then
+ npedge = npedge + 1
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+ endif
+
+ endif
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! verification de la coherence de la numerotation generee
+ 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
+
+ end subroutine createnum_slow
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/datim.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/datim.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/datim.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/datim.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,72 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine datim(string_input)
+
+! get date and time
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=50) string_input
+ character(len=8) datein
+ character(len=10) timein
+ character(len=16) dateprint
+ character(len=8) timeprint
+
+ datein = ' '
+ timein = ' '
+
+ call date_and_time(datein,timein)
+
+ dateprint = datein(7:8)//' - '//datein(5:6)//' - '//datein(1:4)
+ timeprint = timein(1:2)//':'//timein(3:4)//':'//timein(5:6)
+
+ write(iout,"(//1x,79('-')/1x,79('-')/1x,'Program SPECFEM2D: ')")
+ write(iout,"(1x,79('-')/1x,79('-')/1x,a50)") string_input
+ write(iout,"(1x,79('-')/,1x,79('-')/' D a t e : ',a16,30x,' T i m e : ',a8/1x,79('-'),/1x,79('-'))") dateprint,timeprint
+
+ end subroutine datim
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_derivation_matrices.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/define_derivation_matrices.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_derivation_matrices.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_derivation_matrices.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,94 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
+
+ implicit none
+
+ include "constants.h"
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+! weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+! array with 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
+
+! function for calculating derivatives of Lagrange polynomials
+ double precision, external :: lagrange_deriv_GLL
+
+ integer i1,i2,k1,k2
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly zero
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! calculate derivatives of the Lagrange polynomials
+! and precalculate some products in double precision
+! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
+ do i1=1,NGLLX
+ do i2=1,NGLLX
+ hprime_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)
+ hprimewgll_xx(i2,i1) = wxgll(i2) * hprime_xx(i2,i1)
+ enddo
+ enddo
+
+ do k1=1,NGLLZ
+ do k2=1,NGLLZ
+ hprime_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)
+ hprimewgll_zz(k2,k1) = wzgll(k2) * hprime_zz(k2,k1)
+ enddo
+ enddo
+
+ end subroutine define_derivation_matrices
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_external_model.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/define_external_model.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_external_model.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_external_model.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,91 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine define_external_model(x,y,iflag_element,myrank,rho,vp,vs,Qp_attenuation,&
+ Qs_attenuation,c11,c13,c15,c33,c35,c55 )
+
+ implicit none
+
+ include "constants.h"
+
+! user can modify this routine to assign any different external Earth model (rho, vp, vs)
+! based on the x and y coordinates of that grid point and the flag of the region it belongs to
+
+ integer, intent(in) :: iflag_element,myrank
+
+ double precision, intent(in) :: x,y
+
+ double precision, intent(out) :: rho,vp,vs
+ double precision, intent(out) :: Qp_attenuation,Qs_attenuation
+ double precision, intent(out) :: c11,c15,c13,c33,c35,c55
+
+! dummy routine here, just to demonstrate how the model can be assigned
+ if(myrank == 0 .and. iflag_element == 1 .or. x < 1700.d0 .or. y >= 2300.d0) then
+ rho = 2000.d0
+ vp = 3000.d0
+ vs = vp / sqrt(3.d0)
+ Qp_attenuation = 0
+ Qs_attenuation = 0
+ c11 = 169.d9
+ c13 = 122.d9
+ c15 = 0.d0
+ c33 = c11
+ c35 = 0.d0
+ c55 = 75.3d9
+ else
+ rho = 2500.d0
+ vp = 3600.d0
+ vs = vp / 2.d0
+ Qp_attenuation = 60
+ Qs_attenuation = 60
+ c11 = 0.d0
+ c13 = 0.d0
+ c15 = 0.d0
+ c33 = 0.d0
+ c35 = 0.d0
+ c55 = 0.d0
+ endif
+
+ end subroutine define_external_model
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_shape_functions.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/define_shape_functions.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_shape_functions.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/define_shape_functions.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,170 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)
+
+!=======================================================================
+!
+! Set up the shape functions for the subparametric transformation.
+! The routine can handle 4 or 9 control nodes defined as follows:
+!
+! 4 . . . . 7 . . . . 3
+! . .
+! . t .
+! . .
+! 8 9 s 6
+! . .
+! . .
+! . .
+! 1 . . . . 5 . . . . 2
+!
+! Local coordinate system : s,t
+!
+!=======================================================================
+
+ implicit none
+
+ include "constants.h"
+
+ integer ngnod
+
+ double precision shape2D(ngnod)
+ double precision dershape2D(NDIM,ngnod)
+ double precision xi,gamma
+
+ double precision s,t,sp,sm,tp,tm,s2,t2,ss,tt,st
+
+!
+!---- set up the shape functions and their local derivatives
+!
+ s = xi
+ t = gamma
+
+!---- 4-node element
+ if(ngnod == 4) then
+ sp = s + ONE
+ sm = s - ONE
+ tp = t + ONE
+ tm = t - ONE
+
+!---- corner nodes
+ shape2D(1) = QUART * sm * tm
+ shape2D(2) = - QUART * sp * tm
+ shape2D(3) = QUART * sp * tp
+ shape2D(4) = - QUART * sm * tp
+
+ dershape2D(1,1) = QUART * tm
+ dershape2D(1,2) = - QUART * tm
+ dershape2D(1,3) = QUART * tp
+ dershape2D(1,4) = - QUART * tp
+
+ dershape2D(2,1) = QUART * sm
+ dershape2D(2,2) = - QUART * sp
+ dershape2D(2,3) = QUART * sp
+ dershape2D(2,4) = - QUART * sm
+
+!---- 9-node element
+ else if(ngnod == 9) then
+
+ sp = s + ONE
+ sm = s - ONE
+ tp = t + ONE
+ tm = t - ONE
+ s2 = s * TWO
+ t2 = t * TWO
+ ss = s * s
+ tt = t * t
+ st = s * t
+
+!---- corner nodes
+ shape2D(1) = QUART * sm * st * tm
+ shape2D(2) = QUART * sp * st * tm
+ shape2D(3) = QUART * sp * st * tp
+ shape2D(4) = QUART * sm * st * tp
+
+ dershape2D(1,1) = QUART * tm * t * (s2 - ONE)
+ dershape2D(1,2) = QUART * tm * t * (s2 + ONE)
+ dershape2D(1,3) = QUART * tp * t * (s2 + ONE)
+ dershape2D(1,4) = QUART * tp * t * (s2 - ONE)
+
+ dershape2D(2,1) = QUART * sm * s * (t2 - ONE)
+ dershape2D(2,2) = QUART * sp * s * (t2 - ONE)
+ dershape2D(2,3) = QUART * sp * s * (t2 + ONE)
+ dershape2D(2,4) = QUART * sm * s * (t2 + ONE)
+
+!---- midside nodes
+ shape2D(5) = HALF * tm * t * (ONE - ss)
+ shape2D(6) = HALF * sp * s * (ONE - tt)
+ shape2D(7) = HALF * tp * t * (ONE - ss)
+ shape2D(8) = HALF * sm * s * (ONE - tt)
+
+ dershape2D(1,5) = -ONE * st * tm
+ dershape2D(1,6) = HALF * (ONE - tt) * (s2 + ONE)
+ dershape2D(1,7) = -ONE * st * tp
+ dershape2D(1,8) = HALF * (ONE - tt) * (s2 - ONE)
+
+ dershape2D(2,5) = HALF * (ONE - ss) * (t2 - ONE)
+ dershape2D(2,6) = -ONE * st * sp
+ dershape2D(2,7) = HALF * (ONE - ss) * (t2 + ONE)
+ dershape2D(2,8) = -ONE * st * sm
+
+!---- center node
+ shape2D(9) = (ONE - ss) * (ONE - tt)
+
+ dershape2D(1,9) = -ONE * s2 * (ONE - tt)
+ dershape2D(2,9) = -ONE * t2 * (ONE - ss)
+
+ else
+ call exit_MPI('Error: wrong number of control nodes')
+ endif
+
+!--- check the shape functions and their derivatives
+! sum of shape functions should be one
+! sum of derivaticves of shape functions should be zero
+ if(abs(sum(shape2D)-ONE) > TINYVAL) call exit_MPI('error shape functions')
+ if(abs(sum(dershape2D(1,:))) > TINYVAL) call exit_MPI('error deriv xi shape functions')
+ if(abs(sum(dershape2D(2,:))) > TINYVAL) call exit_MPI('error deriv gamma shape functions')
+
+ end subroutine define_shape_functions
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/enforce_acoustic_free_surface.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/enforce_acoustic_free_surface.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/enforce_acoustic_free_surface.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/enforce_acoustic_free_surface.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,88 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+
+! free surface for an acoustic medium
+! if acoustic, the free surface condition is a Dirichlet condition for the potential,
+! not Neumann, in order to impose zero pressure at the surface
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nelem_acoustic_surface,npoin,nspec
+
+ integer, dimension(5,nelem_acoustic_surface) :: acoustic_surface
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(npoin) :: &
+ potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
+
+!---
+!--- local variables
+!---
+
+ integer :: ispec_acoustic_surface,ispec,i,j,iglob
+
+ do ispec_acoustic_surface = 1, nelem_acoustic_surface
+
+ ispec = acoustic_surface(1,ispec_acoustic_surface)
+
+ do j = acoustic_surface(4,ispec_acoustic_surface), acoustic_surface(5,ispec_acoustic_surface)
+ do i = acoustic_surface(2,ispec_acoustic_surface), acoustic_surface(3,ispec_acoustic_surface)
+ iglob = ibool(i,j,ispec)
+ potential_acoustic(iglob) = ZERO
+ potential_dot_acoustic(iglob) = ZERO
+ potential_dot_dot_acoustic(iglob) = ZERO
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine enforce_acoustic_free_surface
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/exit_mpi.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/exit_mpi.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/exit_mpi.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/exit_mpi.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,75 @@
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!-----------------------------------------------
+! subroutine to stop the code whether sequential or parallel.
+!-----------------------------------------------
+subroutine exit_MPI(error_msg)
+
+ implicit none
+#ifdef USE_MPI
+ ! standard include of the MPI library
+ include "mpif.h"
+#endif
+
+ ! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ character(len=*) error_msg
+
+ integer ier
+
+ ier = 0
+
+ ! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc '
+
+ ! stop all the MPI processes, and exit
+#ifdef USE_MPI
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+#endif
+
+ stop 'error, program ended in exit_MPI'
+
+end subroutine exit_MPI
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_MPI.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/get_MPI.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_MPI.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_MPI.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,326 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+#ifdef USE_MPI
+
+ subroutine get_MPI(nspec,ibool,knods,ngnod,npoin,elastic,poroelastic, &
+ ninterface, max_interface_size, &
+ my_nelmnts_neighbours,my_interfaces,my_neighbours, &
+ 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, &
+ myrank,ipass,coord)
+
+! sets up the MPI interface for communication between partitions
+
+ implicit none
+
+ include "constants.h"
+ include 'mpif.h'
+
+ integer, intent(in) :: nspec, npoin, ngnod
+ logical, dimension(nspec), intent(in) :: elastic, poroelastic
+ integer, dimension(ngnod,nspec), intent(in) :: knods
+ integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
+
+ integer :: ninterface
+ integer :: max_interface_size
+ integer, dimension(ninterface) :: my_nelmnts_neighbours,my_neighbours
+ integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
+
+ integer, dimension(NGLLX*max_interface_size,ninterface) :: &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(ninterface) :: &
+ nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(out) :: &
+ inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
+ integer, intent(out) :: ninterface_acoustic, ninterface_elastic, ninterface_poroelastic
+
+ logical, dimension(nspec), intent(inout) :: mask_ispec_inner_outer
+
+ integer :: myrank,ipass
+ double precision, dimension(NDIM,npoin) :: coord
+
+ !local parameters
+ double precision, dimension(:), allocatable :: xp,zp
+ double precision, dimension(:), allocatable :: work
+ integer, dimension(:), allocatable :: locval
+ integer, dimension(:), allocatable :: nibool_interfaces_true
+ ! for MPI buffers
+ integer, dimension(:), allocatable :: reorder_interface,ind,ninseg,iwork
+ integer, dimension(:), allocatable :: ibool_dummy
+! integer, dimension(:,:), allocatable :: ibool_interfaces_dummy
+ logical, dimension(:), allocatable :: ifseg
+ integer :: iinterface,ilocnum
+ integer :: num_points1, num_points2
+ ! assembly test
+ integer :: i,j,ispec,iglob,count,inum,ier,idomain
+ integer :: max_nibool_interfaces,num_nibool,num_interface
+ real(kind=CUSTOM_REAL), dimension(:),allocatable :: test_flag_cr
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_ac
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_ac
+ integer, dimension(:), allocatable :: tab_requests_send_recv_acoustic
+
+ ! gets global indices for points on MPI interfaces
+ ! (defined by my_interfaces) between different partitions
+ ! and stores them in ibool_interfaces*** & nibool_interfaces*** (number of total points)
+ 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 )
+
+
+ ! sorts ibool comm buffers lexicographically for all MPI interfaces
+ num_points1 = 0
+ num_points2 = 0
+ allocate(nibool_interfaces_true(ninterface))
+
+ do idomain = 1,3
+
+ ! checks number of interface in this domain
+ num_interface = 0
+ if( idomain == 1 ) then
+ num_interface = ninterface_acoustic
+ elseif( idomain == 2 ) then
+ num_interface = ninterface_elastic
+ elseif( idomain == 3 ) then
+ num_interface = ninterface_poroelastic
+ endif
+ if( num_interface == 0 ) cycle
+
+ ! loops over interfaces
+ do iinterface = 1, ninterface
+
+ ! number of global points in this interface
+ num_nibool = 0
+ if( idomain == 1 ) then
+ num_nibool = nibool_interfaces_acoustic(iinterface)
+ elseif( idomain == 2 ) then
+ num_nibool = nibool_interfaces_elastic(iinterface)
+ elseif( idomain == 3 ) then
+ num_nibool = nibool_interfaces_poroelastic(iinterface)
+ endif
+ ! checks if anything to sort
+ if( num_nibool == 0 ) cycle
+
+ allocate(xp(num_nibool))
+ allocate(zp(num_nibool))
+ allocate(locval(num_nibool))
+ allocate(ifseg(num_nibool))
+ allocate(reorder_interface(num_nibool))
+ allocate(ibool_dummy(num_nibool))
+ allocate(ind(num_nibool))
+ allocate(ninseg(num_nibool))
+ allocate(iwork(num_nibool))
+ allocate(work(num_nibool))
+
+ ! works with a copy of ibool array
+ if( idomain == 1 ) then
+ ibool_dummy(:) = ibool_interfaces_acoustic(1:num_nibool,iinterface)
+ elseif( idomain == 2 ) then
+ ibool_dummy(:) = ibool_interfaces_elastic(1:num_nibool,iinterface)
+ elseif( idomain == 3 ) then
+ ibool_dummy(:) = ibool_interfaces_poroelastic(1:num_nibool,iinterface)
+ endif
+
+ ! gets x,y,z coordinates of global points on MPI interface
+ do ilocnum = 1, num_nibool
+ iglob = ibool_dummy(ilocnum)
+ xp(ilocnum) = coord(1,iglob)
+ zp(ilocnum) = coord(2,iglob)
+ enddo
+
+ ! sorts (lexicographically?) ibool_interfaces and updates value
+ ! of total number of points nibool_interfaces_true(iinterface)
+ call sort_array_coordinates(num_nibool,xp,zp, &
+ ibool_dummy, &
+ reorder_interface,locval,ifseg, &
+ nibool_interfaces_true(iinterface), &
+ ind,ninseg,iwork,work)
+
+ ! checks that number of MPI points are still the same
+ num_points1 = num_points1 + num_nibool
+ num_points2 = num_points2 + nibool_interfaces_true(iinterface)
+ if( num_points1 /= num_points2 ) then
+ write(IOUT,*) 'error sorting MPI interface points:',myrank
+ write(IOUT,*) ' domain:',idomain
+ write(IOUT,*) ' interface:',iinterface,num_points1,num_points2
+ call exit_MPI('error sorting MPI interface')
+ endif
+
+ ! stores new order of ibool array
+ if( idomain == 1 ) then
+ ibool_interfaces_acoustic(1:num_nibool,iinterface) = ibool_dummy(:)
+ elseif( idomain == 2 ) then
+ ibool_interfaces_elastic(1:num_nibool,iinterface) = ibool_dummy(:)
+ elseif( idomain == 3 ) then
+ ibool_interfaces_poroelastic(1:num_nibool,iinterface) = ibool_dummy(:)
+ endif
+
+ ! cleanup temporary arrays
+ deallocate(xp)
+ deallocate(zp)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(reorder_interface)
+ deallocate(ibool_dummy)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iwork)
+ deallocate(work)
+ enddo
+ enddo
+
+ ! cleanup
+ deallocate(nibool_interfaces_true)
+
+ ! outputs total number of MPI interface points
+ call MPI_REDUCE(num_points2, num_points1, 1, MPI_INTEGER, &
+ MPI_SUM, 0, MPI_COMM_WORLD, ier)
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) 'total MPI interface points: ',num_points1
+ endif
+
+ ! checks interfaces in acoustic domains
+ inum = 0
+ count = 0
+ if ( ninterface_acoustic > 0) then
+
+ ! checks with assembly of test fields
+ allocate(test_flag_cr(npoin))
+ test_flag_cr(:) = 0._CUSTOM_REAL
+ count = 0
+ do ispec = 1, nspec
+ ! sets flags on global points
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ ! global index
+ iglob = ibool(i,j,ispec)
+
+ ! counts number of unique global points to set
+ if( nint(test_flag_cr(iglob)) == 0 ) count = count+1
+
+ ! sets identifier
+ test_flag_cr(iglob) = myrank + 1.0
+ enddo
+ enddo
+ enddo
+
+ max_nibool_interfaces = maxval(nibool_interfaces_acoustic(:))
+
+ allocate(tab_requests_send_recv_acoustic(ninterface_acoustic*2))
+ allocate(buffer_send_faces_vector_ac(max_nibool_interfaces,ninterface_acoustic))
+ allocate(buffer_recv_faces_vector_ac(max_nibool_interfaces,ninterface_acoustic))
+ inum = 0
+ do iinterface = 1, ninterface
+ inum = inum + nibool_interfaces_acoustic(iinterface)
+ enddo
+ endif
+
+ ! note: this mpi reduction awaits information from all processes.
+ ! thus, avoid an mpi deadlock in case some of the paritions have no acoustic interface
+ call MPI_REDUCE(inum, num_points1, 1, MPI_INTEGER, &
+ MPI_SUM, 0, MPI_COMM_WORLD, ier)
+
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) ' acoustic interface points: ',num_points1
+ endif
+
+ ! checks if assembly works
+ inum = 0
+ if( ninterface_acoustic > 0 ) then
+ ! adds contributions from different partitions to flag arrays
+ ! custom_real arrays
+ call assemble_MPI_vector_ac(test_flag_cr,npoin, &
+ ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
+ max_interface_size, max_nibool_interfaces,&
+ ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
+ tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
+ buffer_recv_faces_vector_ac, my_neighbours)
+
+ ! checks number of interface points
+ inum = 0
+ do iglob=1,npoin
+ ! only counts flags with MPI contributions
+ if( nint(test_flag_cr(iglob)) > myrank+1 ) inum = inum + 1
+ enddo
+
+ deallocate(tab_requests_send_recv_acoustic)
+ deallocate(buffer_send_faces_vector_ac)
+ deallocate(buffer_recv_faces_vector_ac)
+ deallocate(test_flag_cr)
+ endif
+
+ ! note: this mpi reduction awaits information from all processes.
+ call MPI_REDUCE(inum, num_points2, 1, MPI_INTEGER, &
+ MPI_SUM, 0, MPI_COMM_WORLD, ier)
+
+ if( myrank == 0 ) then
+ if( ipass == 1 ) then
+ write(IOUT,*) ' assembly acoustic MPI interface points:',num_points2
+ endif
+
+ ! they don't need to fit, somehow..
+ !if( num_points2 /= num_points1 ) then
+ ! print*,'error acoustic assembly:' !,myrank
+ ! print*,' total = ',num_points1,' not equal to assembled ',num_points2
+ ! call exit_MPI('error acoustic MPI assembly')
+ !endif
+ endif
+
+ end subroutine get_MPI
+
+#endif
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_perm_cuthill_mckee.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/get_perm_cuthill_mckee.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_perm_cuthill_mckee.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_perm_cuthill_mckee.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,806 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! implement reverse Cuthill-McKee (1969) ordering, introduced in
+! E. Cuthill and J. McKee. Reducing the bandwidth of sparse symmetric matrices.
+! In Proceedings of the 1969 24th national conference, pages 157-172,
+! New-York, New-York, USA, 1969. ACM Press.
+! see for instance http://en.wikipedia.org/wiki/Cuthill%E2%80%93McKee_algorithm
+
+ subroutine get_perm(ibool,perm,limit,nspec,nglob)
+
+ implicit none
+
+ include "constants.h"
+
+! local variables
+ integer nspec,nglob_GLL_full
+ integer nglob_four_corners_only,nglob
+
+! maximum number of neighbors of a spectral element (in principle, it could be any value)
+ integer, parameter :: MAX_NUMBER_OF_NEIGHBORS = 50
+
+! input
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! output
+ integer, dimension(nspec) :: perm
+
+! global corner numbers that need to be created
+ integer, dimension(nglob) :: global_corner_number
+
+ integer mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
+ integer, dimension(:), allocatable :: ne,np,adj
+ integer xadj(nspec+1)
+
+! arrays to store the permutation and inverse permutation of the Cuthill-McKee algorithm
+ integer, dimension(nspec) :: invperm
+
+ logical maskel(nspec)
+
+ integer i,istart,istop,number_of_neighbors
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne,total_size_adj,limit
+
+!
+!-----------------------------------------------------------------------
+!
+ if(PERFORM_CUTHILL_MCKEE) then
+
+ ! total number of points in the mesh
+ nglob_GLL_full = nglob
+
+ !---- call Charbel Farhat's routines
+ call form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,nglob_GLL_full,ibool,nglob_four_corners_only)
+ do i=1,nspec
+ istart = mp(i)
+ istop = mp(i+1) - 1
+ enddo
+
+ allocate(np(nglob_four_corners_only+1))
+ count_only = .true.
+ total_size_ne = 1
+ allocate(ne(total_size_ne))
+ call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only,nspec,count_only,total_size_ne)
+ deallocate(ne)
+ allocate(ne(total_size_ne))
+ count_only = .false.
+ call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only,nspec,count_only,total_size_ne)
+ do i=1,nglob_four_corners_only
+ istart = np(i)
+ istop = np(i+1) - 1
+ enddo
+
+ count_only = .true.
+ total_size_adj = 1
+ allocate(adj(total_size_adj))
+ call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_four_corners_only,&
+ count_only,total_size_ne,total_size_adj)
+ deallocate(adj)
+ allocate(adj(total_size_adj))
+ count_only = .false.
+ call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_four_corners_only,&
+ count_only,total_size_ne,total_size_adj)
+ do i=1,nspec
+ istart = xadj(i)
+ istop = xadj(i+1) - 1
+ number_of_neighbors = istop-istart+1
+ if(number_of_neighbors < 1) stop 'error: your mesh seems to have at least one element not connected to any other'
+ if(number_of_neighbors > MAX_NUMBER_OF_NEIGHBORS) stop 'error: your mesh seems to have an unlikely high valence'
+ enddo
+ deallocate(ne,np)
+
+! call the Cuthill-McKee sorting algorithm
+ call cuthill_mckee(adj,xadj,perm,invperm,nspec,total_size_adj,limit)
+ deallocate(adj)
+ else
+! create identity permutation in order to do nothing
+ do i=1,nspec
+ perm(i) = i
+ enddo
+ endif
+
+ end subroutine get_perm
+
+!=======================================================================
+!
+! Charbel Farhat's FEM topology routines
+!
+! Dimitri Komatitsch, February 1996 - Code based on Farhat's original version
+! described in his technical report from 1987
+!
+! modified and adapted by Dimitri Komatitsch, May 2006
+!
+!=======================================================================
+
+ subroutine form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number, &
+ nglob_GLL_full,ibool,nglob_four_corners_only)
+
+!-----------------------------------------------------------------------
+!
+! Forms the MN and MP arrays
+!
+! Input :
+! -------
+! ibool Array needed to build the element connectivity table
+! nspec Number of elements in the domain
+! NGNOD_QUADRANGLE number of nodes per hexahedron (brick with 8 corners)
+!
+! Output :
+! --------
+! MN, MP This is the element connectivity array pair.
+! Array MN contains the list of the element
+! connectivity, that is, the nodes contained in each
+! element. They are stored in a stacked fashion.
+!
+! Pointer array MP stores the location of each
+! element list. Its length is equal to the number
+! of elements plus one.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,nglob_GLL_full
+
+! arrays with mesh parameters per slice
+ integer, intent(in), dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! global corner numbers that need to be created
+ integer, intent(out), dimension(nglob_GLL_full) :: global_corner_number
+ integer, intent(out) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
+ integer, intent(out) :: nglob_four_corners_only
+
+ integer ninter,nsum,ispec,node,k,inumcorner,ix,iy
+
+ ninter = 1
+ nsum = 1
+ mp(1) = 1
+
+!---- define topology of the elements in the mesh
+!---- we need to define adjacent numbers from the sub-mesh consisting of the corners only
+ nglob_four_corners_only = 0
+ global_corner_number(:) = -1
+
+ do ispec=1,nspec
+
+ inumcorner = 0
+ do iy = 1,NGLLZ,NGLLZ-1
+ do ix = 1,NGLLX,NGLLX-1
+
+ inumcorner = inumcorner + 1
+ if(inumcorner > NGNOD_QUADRANGLE) stop 'corner number too large'
+
+! check if this point was already assigned a number previously, otherwise create one and store it
+ if(global_corner_number(ibool(ix,iy,ispec)) == -1) then
+ nglob_four_corners_only = nglob_four_corners_only + 1
+ global_corner_number(ibool(ix,iy,ispec)) = nglob_four_corners_only
+ endif
+
+ node = global_corner_number(ibool(ix,iy,ispec))
+ do k=nsum,ninter-1
+ if(node == mn(k)) goto 200
+ enddo
+
+ mn(ninter) = node
+ ninter = ninter + 1
+ 200 continue
+
+ enddo
+ enddo
+
+ nsum = ninter
+ mp(ispec + 1) = nsum
+
+ enddo
+
+ end subroutine form_elt_connectivity_foelco
+
+!
+!----------------------------------------------------
+!
+
+ subroutine form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only, &
+ nspec,count_only,total_size_ne)
+
+!-----------------------------------------------------------------------
+!
+! Forms the NE and NP arrays
+!
+! Input :
+! -------
+! MN, MP, nspec
+! nglob_four_corners_only Number of nodes in the domain
+!
+! Output :
+! --------
+! NE, NP This is the node-connected element array pair.
+! Integer array NE contains a list of the
+! elements connected to each node, stored in stacked fashion.
+!
+! Array NP is the pointer array for the
+! location of a node's element list in the NE array.
+! Its length is equal to the number of points plus one.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne
+
+ integer nglob_four_corners_only,nspec
+
+ integer, intent(in) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
+
+ integer, intent(out) :: ne(total_size_ne),np(nglob_four_corners_only+1)
+
+ integer nsum,inode,ispec,j
+
+ nsum = 1
+ np(1) = 1
+
+ do inode=1,nglob_four_corners_only
+ do 200 ispec=1,nspec
+
+ do j=mp(ispec),mp(ispec + 1) - 1
+ if (mn(j) == inode) then
+ if(count_only) then
+ total_size_ne = nsum
+ else
+ ne(nsum) = ispec
+ endif
+ nsum = nsum + 1
+ goto 200
+ endif
+ enddo
+ 200 continue
+
+ np(inode + 1) = nsum
+
+ enddo
+
+ end subroutine form_node_connectivity_fonoco
+
+!
+!----------------------------------------------------
+!
+
+ subroutine create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec, &
+ nglob_four_corners_only,count_only,total_size_ne,total_size_adj)
+
+!-----------------------------------------------------------------------
+!
+! Establishes the element adjacency information of the mesh
+! Two elements are considered adjacent if they share a face.
+!
+! Input :
+! -------
+! MN, MP, NE, NP, nspec
+! MASKEL logical mask (length = nspec)
+!
+! Output :
+! --------
+! ADJ, XADJ This is the element adjacency array pair. Array
+! ADJ contains the list of the elements adjacent to
+! element i. They are stored in a stacked fashion.
+! Pointer array XADJ stores the location of each element list.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne,total_size_adj
+
+ integer nglob_four_corners_only
+
+ integer nspec,iad,ispec,istart,istop,ino,node,jstart,jstop,nelem,jel
+
+ integer, intent(in) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1),ne(total_size_ne),np(nglob_four_corners_only+1)
+
+ integer, intent(out) :: adj(total_size_adj),xadj(nspec+1)
+
+ logical maskel(nspec)
+ integer countel(nspec)
+
+ xadj(1) = 1
+ iad = 1
+
+ do ispec=1,nspec
+
+! reset mask
+ maskel(:) = .false.
+
+! mask current element
+ maskel(ispec) = .true.
+ if (FACE) countel(:) = 0
+
+ istart = mp(ispec)
+ istop = mp(ispec+1) - 1
+ do ino=istart,istop
+ node = mn(ino)
+ jstart = np(node)
+ jstop = np(node + 1) - 1
+ do 120 jel=jstart,jstop
+ nelem = ne(jel)
+ if(maskel(nelem)) goto 120
+ if (FACE) then
+!! DK DK this below implemented by David Michea in 3D, but not true anymore in 2D: should be
+!! DK DK two corners instead of three. But does not matter because FACE is always .false.
+!! DK DK and therefore this part of the routine is currently never used.
+!! DK DK Let me add a stop statement just in case.
+ stop 'FACE = .true. not implemented, check the above comment in the source code'
+!! DK DK End of the stop statement added.
+ ! if 2 elements share at least 3 corners, therefore they share a face
+ countel(nelem) = countel(nelem) + 1
+ if (countel(nelem)>=3) then
+ if(count_only) then
+ total_size_adj = iad
+ else
+ adj(iad) = nelem
+ endif
+ maskel(nelem) = .true.
+ iad = iad + 1
+ endif
+ else
+ if(count_only) then
+ total_size_adj = iad
+ else
+ adj(iad) = nelem
+ endif
+ maskel(nelem) = .true.
+ iad = iad + 1
+ endif
+ 120 continue
+ enddo
+
+ xadj(ispec+1) = iad
+
+ enddo
+
+ end subroutine create_adjacency_table_adjncy
+
+!
+!----------------------------------------------------
+!
+
+ subroutine cuthill_mckee(adj,xadj,mask,invperm_all,nspec,total_size_adj,limit)
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: nspec,total_size_adj, limit
+ integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
+
+ integer, intent(out), dimension(nspec) :: mask,invperm_all
+ integer, dimension(nspec) :: invperm_sub
+ integer ispec,gsize,counter,nspec_sub,root,total_ordered_elts, next_root
+
+! fill the mask with ones
+ mask(:) = 1
+ invperm_all(:) = 0
+ counter = 0
+ nspec_sub = limit
+ root = 1
+ total_ordered_elts = 0
+
+ do while(total_ordered_elts < nspec)
+ ! creation of a sublist of sorted elements which fit in the cache (the criterion of size is limit)
+ ! limit = nb of elements that can fit in the L2 cache
+ call Cut_McK( root, nspec, total_size_adj, xadj, adj, mask, gsize, invperm_sub, limit, nspec_sub, next_root)
+ ! add the sublist in the main permutation list
+ invperm_all(total_ordered_elts+1:total_ordered_elts+nspec_sub) = invperm_sub(1:nspec_sub)
+ total_ordered_elts = total_ordered_elts + nspec_sub
+ ! seek for a new root to build the new sublist
+ if (next_root > 0) then
+ root = next_root
+ else
+ if (total_ordered_elts /= nspec) &
+ call find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
+ root = next_root
+ endif
+ enddo
+
+ if (INVERSE) then
+ do ispec=1,nspec
+ mask(invperm_all(ispec)) = ispec
+ enddo
+ else
+ mask(:) = invperm_all(:)
+ endif
+
+ end subroutine cuthill_mckee
+
+
+!*******************************************************************************
+! Objective: Cuthill-McKee ordering
+! The algorithm is:
+!
+! X(1) = ROOT.
+! for ( I = 1 to N-1)
+! Find all unlabeled neighbors of X(I),
+! assign them the next available labels, in order of increasing degree.
+!
+! Parameters:
+! root the starting point for the cm ordering.
+! nbnodes the number of nodes.
+! nnz the number of adjacency entries.
+!
+! xadj/adj the graph
+! mask only those nodes with nonzero mask are considered
+!
+! gsize the number of the connected component
+! invp Inverse permutation (from new order to old order)
+!*******************************************************************************
+
+subroutine find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+! input
+ integer, intent(in) :: total_size_adj,total_ordered_elts,nspec
+ integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
+ integer, intent(in), dimension(nspec) :: mask,invperm_all
+! output
+ integer, intent(out) :: next_root
+! variables
+ integer :: cur_node,neighbor_node,i,j
+
+ do i=total_ordered_elts, 1, -1
+ cur_node = invperm_all(i)
+ do j= xadj(cur_node), xadj(cur_node+1)-1
+ neighbor_node = adj(j)
+ if (mask(neighbor_node)/=0) then
+ next_root=neighbor_node
+ return
+ endif
+ enddo
+ enddo
+
+end subroutine find_next_root
+
+!*******************************************************************************
+! Objective: Cuthill-McKee ordering
+! The algorithm is:
+!
+! X(1) = ROOT.
+! for ( I = 1 to N-1)
+! Find all unlabeled neighbors of X(I),
+! assign them the next available labels, in order of increasing degree.
+!
+! Parameters:
+! root the starting point for the cm ordering.
+! nbnodes the number of nodes.
+! nnz the number of adjacency entries.
+!
+! xadj/adj the graph
+! mask only those nodes with nonzero mask are considered
+!
+! gsize the number of the connected component
+! invp Inverse permutation (from new order to old order)
+!*******************************************************************************
+
+subroutine Cut_McK( root, nbnodes, nnz, xadj, adj, mask, gsize, invp, limit, nspec_sub, next_root)
+
+ implicit none
+
+ include "constants.h"
+
+!--------------------------------------------------------------- Input Variables
+ integer root, nnz, nbnodes, limit, nspec_sub, next_root
+
+ integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
+
+!-------------------------------------------------------------- Output Variables
+ integer gsize
+ integer invp(nbnodes)
+
+!--------------------------------------------------------------- Local Variables
+ integer i, j, k, l, lbegin, lnbr, linvp, lvlend, nbr, node, fnbr
+ integer deg(nbnodes)
+
+! Find the degrees of the nodes in the subgraph specified by mask and root
+! Here invp is used to store a levelization of the subgraph
+ invp(:)=0
+ deg(:)=0
+ call degree ( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, invp)
+
+ mask(root) = 0
+
+ IF (gsize > 1) THEN
+ !If there is at least 2 nodes in the subgraph
+ lvlend = 0
+ lnbr = 1
+
+ DO while (lvlend < lnbr)
+ !lbegin/lvlend point to the begin/end of the present level
+ lbegin = lvlend + 1
+ lvlend = lnbr
+
+ do i= lbegin, lvlend
+ node = invp(i)
+
+ !Find the unnumbered neighbours of node.
+ !fnbr/lnbr point to the first/last neighbors of node
+ fnbr = lnbr + 1
+ do j= xadj(node), xadj(node+1)-1
+ nbr = adj(j)
+
+ if (mask(nbr) /= 0) then
+ lnbr = lnbr + 1
+ mask(nbr) = 0
+ invp(lnbr) = nbr
+ endif
+ enddo
+
+ !If no neighbors, go to next node in this level.
+ IF (lnbr > fnbr) THEN
+ !Sort the neighbors of NODE in increasing order by degree.
+ !Linear insertion is used.
+ k = fnbr
+ do while (k < lnbr)
+ l = k
+ k = k + 1
+ nbr = invp(k)
+
+ DO WHILE (fnbr < l)
+ linvp = invp(l)
+
+ if (deg(linvp) <= deg(nbr)) then
+ exit
+ endif
+
+ invp(l+1) = linvp
+ l = l-1
+ ENDDO
+
+ invp(l+1) = nbr
+ enddo
+ ENDIF
+ enddo
+ ENDDO
+
+ ENDIF
+
+ if (gsize > limit) then
+ do i = limit + 1 , nbnodes
+ node=invp(i)
+ if (node /=0) mask(node) = 1
+ enddo
+ next_root = invp(limit +1)
+ nspec_sub = limit
+ else
+ next_root = -1
+ nspec_sub = gsize
+ endif
+
+END subroutine Cut_McK
+
+
+!*******************************************************************************
+! Objective: computes the degrees of the nodes in the connected graph
+!
+! Parameters:
+! root the root node
+! nbnodes the number of nodes in the graph
+! nnz the graph size
+! xadj/adj the whole graph
+! mask Only nodes with mask == 0 are considered
+!
+! gsize the number of nodes in the connected graph
+! deg degree for all the nodes in the connected graph
+! level levelization of the connected graph
+!
+!*******************************************************************************
+
+subroutine degree( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, level )
+
+ implicit none
+
+!--------------------------------------------------------------- Input Variables
+ integer root, nbnodes, nnz
+ integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
+
+!-------------------------------------------------------------- Output Variables
+ integer gsize
+ integer deg(nbnodes), level(nbnodes)
+
+!--------------------------------------------------------------- Local Variables
+ integer i, j, ideg, lbegin, lvlend, lvsize, nxt, nbr, node
+
+! added a test to detect disconnected subsets in the mesh
+! (in which case Cuthill-McKee fails and should be turned off)
+ if(root > nbnodes+1) stop 'error: root > nbnodes+1 in Cuthill-McKee'
+ if(root < 1) then
+ print *,'error: root < 1 in Cuthill-McKee; you probably have a mesh composed of'
+ print *,'two disconnected subsets of elements, in which case Cuthill-McKee fails and should be turned off.'
+ print *,'please set PERFORM_CUTHILL_MCKEE = .false. in constants.h and recompile.'
+ print *,'please also doublecheck that you indeed want to run two separate meshes simultaneously,'
+ print *,'which is extremely unusual (but formally not incorrect).'
+ stop 'fatal error in Cuthill-McKee'
+ endif
+
+! The sign of xadj(I) is used to indicate if node i has been considered
+ xadj(root) = -xadj(root)
+ level(1) = root
+ nxt = 1
+ lvlend = 0
+ lvsize = 1
+
+ DO WHILE (lvsize > 0)
+ ! lbegin/lvlend points the begin/end of the present level
+ lbegin = lvlend + 1
+ lvlend = nxt
+
+ ! Find the degrees of nodes in the present level and generate the next level
+ DO i= lbegin, lvlend
+ node = level(i)
+ ideg = 0
+ do j= ABS( xadj(node) ), ABS( xadj(node+1) )-1
+ nbr = adj(j)
+
+ if (mask(nbr) /= 0) then
+ ideg = ideg + 1
+
+ if (xadj(nbr) >= 0) then
+ xadj(nbr) = -xadj(nbr)
+ nxt = nxt + 1
+ level(nxt) = nbr
+ endif
+ endif
+ enddo
+
+ deg(node) = ideg
+ ENDDO
+
+ !Compute the level size of the next level
+ lvsize = nxt - lvlend
+ ENDDO
+
+ !Reset xadj to its correct sign
+ do i = 1, nxt
+ node = level(i)
+ xadj(node) = -xadj(node)
+ enddo
+
+ gsize = nxt
+
+END subroutine degree
+
+!
+!-----------------------------------------------------------------------
+!
+
+ subroutine permute_elements_real(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ real(kind=CUSTOM_REAL), intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:) = array_to_permute(:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_real
+
+!
+!-----------------------------------------------------------------------
+!
+
+! implement permutation of elements for arrays of integer type
+ subroutine permute_elements_integer(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ integer, intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:) = array_to_permute(:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_integer
+
+!
+!-----------------------------------------------------------------------
+!
+
+! implement permutation of elements for arrays of double precision type
+ subroutine permute_elements_dble(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ double precision, intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:) = array_to_permute(:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_dble
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_poroelastic_velocities.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/get_poroelastic_velocities.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_poroelastic_velocities.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/get_poroelastic_velocities.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,155 @@
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!----
+!---- subroutine to compute poroelastic velocities cpI, cpII, & cs as a function of the dominant frequency
+!----
+
+ subroutine get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
+ tortl,rhol_s,rhol_f,etal_f,perm,fi,f0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: f0,w0il
+ double precision :: H_biot,C_biot,M_biot
+ double precision :: cpIsquare,cpIIsquare
+ double precision :: cssquare,att_I,att_II
+ double precision :: etal_f,rhol_f,rhol_s,rhol_bar,perm
+ double precision :: mul_fr,phil,tortl
+
+ double precision :: a_r,a_i,b_r,b_i,cc,alpha,aa1,aa2
+ double precision :: xx,yy, gXI, gYI,gXII,gYII,w_c,f_c
+ double precision :: wi,fi,taus,taue,Q0,bbr,bbi
+
+ double precision :: gA,gB,sa,sb,xxs,yys
+ logical :: TURN_VISCATTENUATION_ON
+
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+
+ w_c = etal_f*phil/(tortl*rhol_f*perm)
+ f_c = w_c/(2*pi)
+
+ wi=2.d0*pi*fi
+
+ alpha=10.d0**dlog10(wi)
+ w0il = 2.d0*pi*f0
+ taue = (sqrt(Q0*Q0+1) +1)/(w0il*Q0)
+ taus = (sqrt(Q0*Q0+1) -1)/(w0il*Q0)
+
+ if(TURN_VISCATTENUATION_ON) then
+! high frequency, with memory variables
+ bbr = etal_f/perm*(1.d0+alpha*alpha*taus*taue)/(1.d0 + alpha*alpha*taus*taus)
+ bbi = etal_f/perm*alpha*(taue-taus)/(1.d0 + alpha*alpha*taus*taus)
+ else
+! low frequency
+ bbr = etal_f/perm
+ bbi = 0.d0
+ endif
+
+! cs
+ gA = (rhol_f*tortl*rhol_bar-phil*rhol_f**2)**2/(phil*rhol_bar)**2 - (bbr**2-bbi**2)/alpha**2*&
+ (phil*rhol_f/(rhol_bar*tortl) -1.d0) - bbi/alpha*phil*rhol_f/(rhol_bar*tortl)*&
+ (rhol_f*tortl*rhol_bar-phil*rhol_f**2)/(phil*rhol_bar)
+ gB = -2.d0*bbr*bbi/alpha**2*(phil*rhol_f/(rhol_bar*tortl) -1.d0) + bbr/alpha*phil*rhol_f/&
+ (rhol_bar*tortl)*(rhol_f*tortl*rhol_bar-phil*rhol_f**2)/(phil*rhol_bar)
+!
+ sa = (rhol_f*tortl*rhol_bar-phil*rhol_f**2)**2/(phil*rhol_bar)**2 + (bbr**2-bbi**2)/alpha**2
+ sb = 2.d0*bbr*bbi/alpha**2
+!
+ xxs = sa*gA + sb*gB
+ yys = gA*sb - sa*gB
+
+ cssquare = mul_fr/(rhol_bar-phil*rhol_f/tortl) * 2.d0*(gA**2+gB**2)/(sqrt(xxs**2+yys**2)+xxs)
+
+
+! cpI & cpII
+ a_r = rhol_bar - phil*rhol_f/tortl - phil*rhol_bar/(tortl*rhol_f)*bbi/alpha
+ a_i = phil*rhol_bar/(tortl*rhol_f)*bbr
+ b_r = H_biot + M_biot*phil*rhol_bar/(tortl*rhol_f) - 2.d0*phil*C_biot/tortl - &
+ phil*H_biot/(tortl*rhol_f)*bbi/alpha
+ b_i = phil*H_biot/(tortl*rhol_f)*bbr
+ cc = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
+!
+ xx = b_r*b_r - b_i*b_i/(alpha*alpha) - 4.d0*a_r*cc
+ yy = 2.d0*b_r*b_i/alpha - 4.d0*a_i/alpha*cc
+!
+ gXI = a_r*(b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) + &
+ a_i/alpha*(b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
+
+ gYI = a_i/alpha*(b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) - &
+ a_r*(b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
+ gYI = -gYI
+
+ gXII = a_r*(b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) + &
+ a_i/alpha*(b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
+
+ gYII = a_i/alpha*(b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) - &
+ a_r*(b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
+ gYII = -gYII
+!
+!
+!
+ cpIsquare = ((b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2 + &
+ (b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)/&
+ (sqrt(gXI**2+gYI**2) + gXI)
+
+ cpIIsquare = ((b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2 + &
+ (b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)/&
+ (sqrt(gXII**2+gYII**2) + gXII)
+
+! attenuation factors
+ att_I = -alpha*sign(1.d0,yy)*sqrt(sqrt(gXI**2+gYI**2)-gXI) / &
+ sqrt((b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2+&
+ (b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)
+ att_II = -alpha*sign(1.d0,yy)*sqrt(sqrt(gXII**2+gYII**2)-gXII) / &
+ sqrt((b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2+&
+ (b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)
+
+! inverse quality factors
+ aa1 = -gYI/gXI
+ aa2 = -gYII/gXII
+
+ end subroutine get_poroelastic_velocities
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/gll_library.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/gll_library.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/gll_library.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/gll_library.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,534 @@
+
+!=======================================================================
+!
+! Library to compute the Gauss-Lobatto-Legendre points and weights
+! Based on Gauss-Lobatto routines from M.I.T.
+! Department of Mechanical Engineering
+!
+!=======================================================================
+
+ double precision function endw1(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ f3 = zero
+ apb = alpha+beta
+ if(n == 0) then
+ endw1 = zero
+ return
+ endif
+ f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if(n == 1) then
+ endw1 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
+ if(n == 2) then
+ endw1 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw1 = f3
+
+ end function endw1
+
+!
+!=======================================================================
+!
+
+ double precision function endw2(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ apb = alpha+beta
+ f3 = zero
+ if (n == 0) then
+ endw2 = zero
+ return
+ endif
+ f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw2 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw2 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw2 = f3
+
+ end function endw2
+
+!
+!=======================================================================
+!
+
+ double precision function gammaf (x)
+
+ implicit none
+
+ double precision, parameter :: pi = 3.141592653589793d0
+
+ double precision x
+
+ double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
+
+ gammaf = one
+
+ if (x == -half) gammaf = -two*sqrt(pi)
+ if (x == half) gammaf = sqrt(pi)
+ if (x == one ) gammaf = one
+ if (x == two ) gammaf = one
+ if (x == 1.5d0) gammaf = sqrt(pi)/2.d0
+ if (x == 2.5d0) gammaf = 1.5d0*sqrt(pi)/2.d0
+ if (x == 3.5d0) gammaf = 2.5d0*1.5d0*sqrt(pi)/2.d0
+ if (x == 3.d0 ) gammaf = 2.d0
+ if (x == 4.d0 ) gammaf = 6.d0
+ if (x == 5.d0 ) gammaf = 24.d0
+ if (x == 6.d0 ) gammaf = 120.d0
+
+ end function gammaf
+
+!
+!=====================================================================
+!
+
+ subroutine jacg (xjac,np,alpha,beta)
+
+!=======================================================================
+!
+! computes np Gauss points, which are the zeros of the
+! Jacobi polynomial with parameters alpha and beta
+!
+! .alpha = beta = 0.0 -> Legendre points
+! .alpha = beta = -0.5 -> Chebyshev points
+!
+!=======================================================================
+
+ implicit none
+
+ integer np
+ double precision alpha,beta
+ double precision xjac(np)
+
+ integer k,j,i,jmin,jm,n
+ double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+
+ integer, parameter :: K_MAX_ITER = 10
+ double precision, parameter :: zero = 0.d0, eps = 1.0d-12
+
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ xlast = 0.d0
+ n = np-1
+ dth = 4.d0*atan(1.d0)/(2.d0*dble(n)+2.d0)
+ p = 0.d0
+ pd = 0.d0
+ jmin = 0
+ do j=1,np
+ if(j == 1) then
+ x = cos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ else
+ x1 = cos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ x2 = xlast
+ x = (x1+x2)/2.d0
+ endif
+ do k=1,K_MAX_ITER
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
+ recsum = 0.d0
+ jm = j-1
+ do i=1,jm
+ recsum = recsum+1.d0/(x-xjac(np-i+1))
+ enddo
+ delx = -p/(pd-recsum*p)
+ x = x+delx
+ if(abs(delx) < eps) goto 31
+ enddo
+ 31 continue
+ xjac(np-j+1) = x
+ xlast = x
+ enddo
+ do i=1,np
+ xmin = 2.d0
+ do j=i,np
+ if(xjac(j) < xmin) then
+ xmin = xjac(j)
+ jmin = j
+ endif
+ enddo
+ if(jmin /= i) then
+ swap = xjac(i)
+ xjac(i) = xjac(jmin)
+ xjac(jmin) = swap
+ endif
+ enddo
+
+ end subroutine jacg
+
+!
+!=====================================================================
+!
+
+ subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
+
+!=======================================================================
+!
+! Computes the Jacobi polynomial of degree n and its derivative at x
+!
+!=======================================================================
+
+ implicit none
+
+ double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
+ integer n
+
+ double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
+ integer k
+
+ apb = alp+bet
+ poly = 1.d0
+ pder = 0.d0
+ psave = 0.d0
+ pdsave = 0.d0
+
+ if (n == 0) return
+
+ polyl = poly
+ pderl = pder
+ poly = (alp-bet+(apb+2.d0)*x)/2.d0
+ pder = (apb+2.d0)/2.d0
+ if (n == 1) return
+
+ do k=2,n
+ dk = dble(k)
+ a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
+ a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
+ b3 = (2.d0*dk+apb-2.d0)
+ a3 = b3*(b3+1.d0)*(b3+2.d0)
+ a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
+ polyn = ((a2+a3*x)*poly-a4*polyl)/a1
+ pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
+ psave = polyl
+ pdsave = pderl
+ polyl = poly
+ poly = polyn
+ pderl = pder
+ pder = pdern
+ enddo
+
+ polym1 = polyl
+ pderm1 = pderl
+ polym2 = psave
+ pderm2 = pdsave
+
+ end subroutine jacobf
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNDLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the derivative of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P1D,P2D,P3D,FK,P3
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P1D = 0.d0
+ P2D = 1.d0
+ P3D = 1.d0
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
+ P1 = P2
+ P2 = P3
+ P1D = P2D
+ P2D = P3D
+ enddo
+
+ PNDLEG = P3D
+
+ end function pndleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P3,FK
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P3 = P2
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P1 = P2
+ P2 = P3
+ enddo
+
+ PNLEG = P3
+
+ end function pnleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision function pnormj (n,alpha,beta)
+
+ implicit none
+
+ double precision alpha,beta
+ integer n
+
+ double precision one,two,dn,const,prod,dindx,frac
+ double precision, external :: gammaf
+ integer i
+
+ one = 1.d0
+ two = 2.d0
+ dn = dble(n)
+ const = alpha+beta+one
+
+ if (n <= 1) then
+ prod = gammaf(dn+alpha)*gammaf(dn+beta)
+ prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
+ pnormj = prod * two**const/(two*dn+const)
+ return
+ endif
+
+ prod = gammaf(alpha+one)*gammaf(beta+one)
+ prod = prod/(two*(one+const)*gammaf(const+one))
+ prod = prod*(one+alpha)*(two+alpha)
+ prod = prod*(one+beta)*(two+beta)
+
+ do i=3,n
+ dindx = dble(i)
+ frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
+ prod = prod*frac
+ enddo
+
+ pnormj = prod * two**const/(two*dn+const)
+
+ end function pnormj
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgjd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g j d : Generate np Gauss-Jacobi points and weights
+! associated with Jacobi polynomial of degree n = np-1
+!
+! Note : Coefficients alpha and beta must be greater than -1.
+! ----
+!=======================================================================
+
+ implicit none
+ include 'constants.h'
+
+ !double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision z(np)
+ real(kind=CUSTOM_REAL) :: w(np)
+ double precision alpha,beta
+
+ integer n,np1,np2,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
+ double precision, external :: gammaf,pnormj
+
+ pd = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ apb = alpha+beta
+ p = zero
+ pdm1 = zero
+
+ if (np <= 0) call exit_MPI('minimum number of Gauss points is 1')
+
+ if ((alpha <= -one) .or. (beta <= -one)) call exit_MPI('alpha and beta must be greater than -1')
+
+ if (np == 1) then
+ z(1) = (beta-alpha)/(apb+two)
+ w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
+ return
+ endif
+
+ call jacg(z,np,alpha,beta)
+
+ np1 = n+1
+ np2 = n+2
+ dnp1 = dble(np1)
+ dnp2 = dble(np2)
+ fac1 = dnp1+alpha+beta+one
+ fac2 = fac1+dnp1
+ fac3 = fac2+one
+ fnorm = pnormj(np1,alpha,beta)
+ rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
+ do i=1,np
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
+ w(i) = -rcoef/(p*pdm1)
+ enddo
+
+ end subroutine zwgjd
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgljd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
+! ----------- weights associated with Jacobi polynomials of degree
+! n = np-1.
+!
+! Note : alpha and beta coefficients must be greater than -1.
+! Legendre polynomials are special case of Jacobi polynomials
+! just by setting alpha and beta to 0.
+!
+!=======================================================================
+
+ implicit none
+ include 'constants.h'
+
+
+ !double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision alpha,beta
+ double precision z(np)
+ real(kind=CUSTOM_REAL) :: w(np)
+
+ integer n,nm1,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision alpg,betg
+ double precision, external :: endw1,endw2
+
+ p = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ nm1 = n-1
+ pd = zero
+
+ if (np <= 1) call exit_MPI('minimum number of Gauss-Lobatto points is 2')
+
+! with spectral elements, use at least 3 points
+ if (np <= 2) call exit_MPI('minimum number of Gauss-Lobatto points for the SEM is 3')
+
+ if ((alpha <= -one) .or. (beta <= -one)) call exit_MPI('alpha and beta must be greater than -1')
+
+ if (nm1 > 0) then
+ alpg = alpha+one
+ betg = beta+one
+ call zwgjd(z(2),w(2),nm1,alpg,betg)
+ endif
+
+ z(1) = - one
+ z(np) = one
+
+ do i=2,np-1
+ w(i) = w(i)/(one-z(i)**2)
+ enddo
+
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
+ w(1) = endw1(n,alpha,beta)/(two*pd)
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
+ w(np) = endw2(n,alpha,beta)/(two*pd)
+
+ end subroutine zwgljd
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/gmat01.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/gmat01.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/gmat01.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/gmat01.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,396 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine gmat01(density_array,porosity_array,tortuosity_array, &
+ aniso_array,permeability,poroelastcoef, &
+ numat,myrank,ipass,Qp_array,Qs_array, &
+ freq0,Q0,f0,TURN_VISCATTENUATION_ON)
+
+! reads properties of a 2D isotropic or anisotropic linear elastic element
+
+ implicit none
+ include "constants.h"
+
+ integer :: numat,myrank,ipass
+ double precision :: density_array(2,numat),poroelastcoef(4,3,numat),porosity_array(numat)
+ double precision :: aniso_array(6,numat),tortuosity_array(numat),permeability(3,numat)
+ double precision :: Qp_array(numat),Qs_array(numat)
+ double precision :: f0,Q0,freq0
+ logical :: TURN_VISCATTENUATION_ON
+
+ ! local parameters
+ double precision :: lambdaplus2mu,kappa
+ 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
+ double precision :: cpIsquare,cpIIsquare,cssquare,mu_s,mu_fr,eta_f,lambda_s,lambda_fr
+ double precision :: val1,val2,val3,val4,val5,val6
+ double precision :: val7,val8,val9,val10,val11,val12,val0
+ double precision :: c11,c13,c15,c33,c35,c55
+ double precision :: D_biot,H_biot,C_biot,M_biot
+ double precision :: w_c
+ integer in,n,indic
+ character(len=80) datlin
+
+
+ !
+ !---- loop over the different material sets
+ !
+ density_array(:,:) = zero
+ porosity_array(:) = zero
+ tortuosity_array(:) = zero
+ aniso_array(:,:) = zero
+ permeability(:,:) = zero
+ poroelastcoef(:,:,:) = zero
+ Qp_array(:) = zero
+ Qs_array(:) = zero
+
+ if(myrank == 0 .and. ipass == 1) write(IOUT,100) numat
+
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ do in = 1,numat
+
+ 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, 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
+
+ ! P and S velocity
+ cp = 20
+ cs = 10
+
+ ! Anisotropy parameters
+ c11 = val1
+ c13 = val2
+ c15 = val3
+ c33 = val4
+ c35 = val5
+ c55 = val6
+
+ ! Qp and Qs values
+ !Qp = val9
+ !Qs = val10
+
+ ! 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)
+
+ !---- isotropic material, moduli are given, allows for declaration of poroelastic material
+ !---- poroelastic (0<phi<1)
+ else if (indic == 3) then
+ ! Qs values
+ Qs = val12
+
+ density(1) =val0
+ density(2) =val1
+
+ ! Solid properties
+ kappa_s = val7
+ mu_s = val11
+ ! Fluid properties
+ kappa_f = val8
+ eta_f = val10
+ ! Frame properties
+ 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
+ lambdaplus2mu_fr = kappa_fr + FOUR_THIRDS*mu_fr
+ lambda_fr = lambdaplus2mu_fr - 2.d0*mu_fr
+ phi = val2
+ tortuosity = val3
+
+ ! 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)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare, &
+ H_biot,C_biot,M_biot,mu_fr,phi, &
+ tortuosity,density(1),density(2),eta_f, &
+ val4,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ 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)
+
+ ! Poisson's ratio for the solid phase
+ poisson_s = HALF*(3.d0*kappa_s- 2.d0*mu_s)/(3.d0*kappa_s+mu_s)
+
+ ! Poisson's ratio 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'
+
+ else
+ call exit_MPI('wrong model flag read')
+
+ endif
+
+ !
+ !---- set elastic coefficients and density
+ !
+ ! 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)
+! dummy poroelastcoef values, trick to avoid floating invalid
+ poroelastcoef(1,1,n) = lambda
+ poroelastcoef(2,1,n) = mu
+ poroelastcoef(3,1,n) = lambdaplus2mu
+ poroelastcoef(4,1,n) = zero
+ aniso_array(1,n) = c11
+ aniso_array(2,n) = c13
+ aniso_array(3,n) = c15
+ aniso_array(4,n) = c33
+ aniso_array(5,n) = c35
+ aniso_array(6,n) = c55
+! dummy Q values, trick to avoid a bug in attenuation_model
+ Qp_array(n) = 15
+ Qs_array(n) = 15
+ porosity_array(n) = 0.d0
+ elseif (indic == 3) then
+ density_array(1,n) = density(1)
+ density_array(2,n) = density(2)
+ poroelastcoef(1,1,n) = lambda_s
+ poroelastcoef(2,1,n) = mu_s ! = mu_fr
+ poroelastcoef(3,1,n) = lambdaplus2mu_s
+ poroelastcoef(4,1,n) = zero
+
+ poroelastcoef(1,2,n) = kappa_f
+ poroelastcoef(2,2,n) = eta_f
+ poroelastcoef(3,2,n) = zero
+ poroelastcoef(4,2,n) = zero
+
+ poroelastcoef(1,3,n) = lambda_fr
+ poroelastcoef(2,3,n) = mu_fr
+ poroelastcoef(3,3,n) = lambdaplus2mu_fr
+ poroelastcoef(4,3,n) = zero
+ Qp_array(n) = 10.d0 ! dummy for attenuation_model
+ Qs_array(n) = Qs
+ endif
+
+ !
+ !---- check what has been read
+ !
+ if(myrank == 0 .and. ipass == 1) then
+ if(indic == 1) then
+ ! 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,density(1),c11,c13,c15,c33,c35,c55
+ elseif(indic == 3) then
+ ! 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,w_c
+ endif
+ endif
+
+ enddo
+
+ !
+ !---- formats
+ !
+100 format(//,' M a t e r i a l s e t s : ', &
+ ' 2 D (p o r o) e l a s t i c i t y', &
+ /1x,54('='),//5x,'Number of material sets . . . . . . (numat) =',i6)
+
+200 format(//5x,'----------------------------------------',/5x, &
+ '-- Elastic (solid) isotropic material --',/5x, &
+ '----------------------------------------',/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, &
+ 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
+ 'c11 coefficient (Pascal). . . . . . (c11) =',1pe15.8,/5x, &
+ 'c13 coefficient (Pascal). . . . . . (c13) =',1pe15.8,/5x, &
+ 'c15 coefficient (Pascal). . . . . . (c15) =',1pe15.8,/5x, &
+ 'c33 coefficient (Pascal). . . . . . (c33) =',1pe15.8,/5x, &
+ 'c35 coefficient (Pascal). . . . . . (c35) =',1pe15.8,/5x, &
+ 'c55 coefficient (Pascal). . . . . . (c55) =',1pe15.8,/5x)
+
+500 format(//5x,'----------------------------------------',/5x, &
+ '-- Poroelastic isotropic material --',/5x, &
+ '----------------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
+ 'First P-wave velocity. . . . . . . . . . . (cpI) =',1pe15.8,/5x, &
+ 'Second P-wave velocity. . . . . . . . . . . (cpII) =',1pe15.8,/5x, &
+ 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8)
+
+600 format(//5x,'-------------------------------',/5x, &
+ '-- Solid phase properties --',/5x, &
+ 'Mass density. . . . . . . . . . (density_s) =',1pe15.8,/5x, &
+ 'Poisson''s ratio. . . . . . . . .(poisson_s) =',1pe15.8,/5x, &
+ 'First Lame parameter Lambda. . . (lambda_s) =',1pe15.8,/5x, &
+ 'Second Lame parameter Mu. . . . . . .(mu_s) =',1pe15.8,/5x, &
+ 'Solid bulk modulus Kappa . . . . . . . .(kappa_s) =',1pe15.8,/5x, &
+ 'Young''s modulus E. . . . . . . . .(young_s) =',1pe15.8)
+
+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)
+
+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. . . . . . . . . . . . . . . . .(c) =',1pe15.8,/5x,&
+ 'Permeability xx component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Permeability zx component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Permeability zz component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
+
+900 format(//5x,'-------------------------------',/5x, &
+ '-- Biot coefficients --',/5x, &
+ '-------------------------------',/5x, &
+ 'D. . . . . . . . =',1pe15.8,/5x, &
+ 'H. . . . . . . . =',1pe15.8,/5x, &
+ 'C. . . . . . . . =',1pe15.8,/5x, &
+ 'M. . . . . . . . =',1pe15.8,/5x, &
+ 'characteristic freq =',1pe15.8)
+
+ end subroutine gmat01
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/include_for_periodic_conditions.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/include_for_periodic_conditions.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/include_for_periodic_conditions.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/include_for_periodic_conditions.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,105 @@
+
+!----------------------------------------------------------------------
+ do ispecperio2 = 1,NSPEC_PERIO
+
+ ispec2 = numperio_right(ispecperio2)
+
+ if(codeabs_perio_right(ILEFT,ispecperio2)) then
+ i2 = 1
+ do j2 = 1,NGLLZ
+ iglob2 = ibool(i2,j2,ispec2)
+ if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
+ (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
+ print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
+! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
+! print *,ispec,i,j,ispec2,i2,j2
+! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
+!--------------------------------------------------------------------------------
+ iglob_target_to_replace = ibool(i2,j2,ispec2)
+ do ispec3 = 1,nspec
+ do j3 = 1,NGLLZ
+ do i3 = 1,NGLLX
+ if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
+ enddo
+ enddo
+ enddo
+!--------------------------------------------------------------------------------
+ endif
+ enddo
+ endif
+
+ if(codeabs_perio_right(IRIGHT,ispecperio2)) then
+ i2 = NGLLX
+ do j2 = 1,NGLLZ
+ iglob2 = ibool(i2,j2,ispec2)
+ if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
+ (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
+ print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
+! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
+! print *,ispec,i,j,ispec2,i2,j2
+! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
+!--------------------------------------------------------------------------------
+ iglob_target_to_replace = ibool(i2,j2,ispec2)
+ do ispec3 = 1,nspec
+ do j3 = 1,NGLLZ
+ do i3 = 1,NGLLX
+ if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
+ enddo
+ enddo
+ enddo
+!--------------------------------------------------------------------------------
+ endif
+ enddo
+ endif
+
+ if(codeabs_perio_right(IBOTTOM,ispecperio2)) then
+ j2 = 1
+ do i2 = 1,NGLLX
+ iglob2 = ibool(i2,j2,ispec2)
+ if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
+ (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
+ print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
+! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
+! print *,ispec,i,j,ispec2,i2,j2
+! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
+!--------------------------------------------------------------------------------
+ iglob_target_to_replace = ibool(i2,j2,ispec2)
+ do ispec3 = 1,nspec
+ do j3 = 1,NGLLZ
+ do i3 = 1,NGLLX
+ if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
+ enddo
+ enddo
+ enddo
+!--------------------------------------------------------------------------------
+ endif
+ enddo
+ endif
+
+ if(codeabs_perio_right(ITOP,ispecperio2)) then
+ j2 = NGLLZ
+ do i2 = 1,NGLLX
+ iglob2 = ibool(i2,j2,ispec2)
+ if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
+ (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
+ print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
+! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
+! print *,ispec,i,j,ispec2,i2,j2
+! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
+!--------------------------------------------------------------------------------
+ iglob_target_to_replace = ibool(i2,j2,ispec2)
+ do ispec3 = 1,nspec
+ do j3 = 1,NGLLZ
+ do i3 = 1,NGLLX
+ if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
+ enddo
+ enddo
+ enddo
+!--------------------------------------------------------------------------------
+ endif
+ enddo
+ endif
+
+ enddo
+!----------------------------------------------------------------------
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/initialize_simulation.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/initialize_simulation.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/initialize_simulation.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/initialize_simulation.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,120 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine initialize_simulation(nproc,myrank,NUMBER_OF_PASSES, &
+ ninterface_acoustic,ninterface_elastic,ninterface_poroelastic)
+
+ implicit none
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: nproc,myrank,NUMBER_OF_PASSES
+ integer :: ninterface_acoustic, ninterface_elastic,ninterface_poroelastic
+
+ ! local parameters
+ integer :: ier
+ character(len=256) :: prname
+
+!***********************************************************************
+!
+! i n i t i a l i z a t i o n p h a s e
+!
+!***********************************************************************
+
+#ifdef USE_MPI
+ call MPI_INIT(ier)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,nproc,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+ if( ier /= 0 ) call exit_MPI('error MPI initialization')
+
+ ! 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
+ !ier = 0
+ !ninterface_acoustic = 0
+ !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
+
+ ninterface_acoustic = 0
+ ninterface_elastic = 0
+ ninterface_poroelastic = 0
+
+ ! 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',iostat=ier)
+ if( ier /= 0 ) call exit_MPI('error opening file simulation_results***.txt')
+
+ endif
+
+ end subroutine initialize_simulation
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/invert_mass_matrix.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/invert_mass_matrix.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/invert_mass_matrix.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/invert_mass_matrix.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,206 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine invert_mass_matrix_init(any_elastic,any_acoustic,any_poroelastic, &
+ rmass_inverse_elastic,npoin_elastic, &
+ rmass_inverse_acoustic,npoin_acoustic, &
+ rmass_s_inverse_poroelastic, &
+ rmass_w_inverse_poroelastic,npoin_poroelastic, &
+ nspec,ibool,kmato,wxgll,wzgll,jacobian, &
+ elastic,poroelastic, &
+ assign_external_model,numat, &
+ density,poroelastcoef,porosity,tortuosity, &
+ vpext,rhoext)
+
+! builds the global mass matrix
+
+ implicit none
+ include 'constants.h'
+
+ logical any_elastic,any_acoustic,any_poroelastic
+
+ ! inverse mass matrices
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(npoin_elastic) :: rmass_inverse_elastic
+
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: rmass_inverse_acoustic
+
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(npoin_poroelastic) :: &
+ rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
+
+ integer :: nspec
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wzgll
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: jacobian
+
+ logical,dimension(nspec) :: elastic,poroelastic
+
+ logical :: assign_external_model
+ integer :: numat
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,rhoext
+
+ ! local parameters
+ integer :: ispec,i,j,iglob
+ double precision :: rhol,kappal,mul_relaxed,lambdal_relaxed
+ double precision :: rhol_s,rhol_f,rhol_bar,phil,tortl
+
+ ! initializes mass matrix
+ if(any_elastic) rmass_inverse_elastic(:) = 0._CUSTOM_REAL
+ if(any_poroelastic) rmass_s_inverse_poroelastic(:) = 0._CUSTOM_REAL
+ if(any_poroelastic) rmass_w_inverse_poroelastic(:) = 0._CUSTOM_REAL
+ if(any_acoustic) rmass_inverse_acoustic(:) = 0._CUSTOM_REAL
+
+ 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/3.d0*mul_relaxed
+ endif
+
+ if( poroelastic(ispec) ) then
+
+ ! material is poroelastic
+
+ rhol_s = density(1,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ rhol_bar = (1.d0-phil)*rhol_s + phil*rhol_f
+
+ ! for the solid mass matrix
+ rmass_s_inverse_poroelastic(iglob) = rmass_s_inverse_poroelastic(iglob) &
+ + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar - phil*rhol_f/tortl)
+ ! for the fluid mass matrix
+ rmass_w_inverse_poroelastic(iglob) = rmass_w_inverse_poroelastic(iglob) &
+ + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar*rhol_f*tortl &
+ - phil*rhol_f*rhol_f)/(rhol_bar*phil)
+
+ elseif( elastic(ispec) ) then
+
+ ! for elastic medium
+
+ rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) &
+ + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
+
+ else
+
+ ! for acoustic medium
+
+ rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) &
+ + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / kappal
+
+ endif
+
+ enddo
+ enddo
+ enddo ! do ispec = 1,nspec
+
+ end subroutine invert_mass_matrix_init
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine invert_mass_matrix(any_elastic,any_acoustic,any_poroelastic, &
+ rmass_inverse_elastic,npoin_elastic, &
+ rmass_inverse_acoustic,npoin_acoustic, &
+ rmass_s_inverse_poroelastic, &
+ rmass_w_inverse_poroelastic,npoin_poroelastic)
+
+! inverts the global mass matrix
+
+ implicit none
+ include 'constants.h'
+
+ logical any_elastic,any_acoustic,any_poroelastic
+
+! inverse mass matrices
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(npoin_elastic) :: rmass_inverse_elastic
+
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: rmass_inverse_acoustic
+
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(npoin_poroelastic) :: &
+ rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
+
+
+! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ if(any_elastic) &
+ where(rmass_inverse_elastic <= 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
+ if(any_poroelastic) &
+ where(rmass_s_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_s_inverse_poroelastic = 1._CUSTOM_REAL
+ if(any_poroelastic) &
+ where(rmass_w_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_w_inverse_poroelastic = 1._CUSTOM_REAL
+ if(any_acoustic) &
+ where(rmass_inverse_acoustic <= 0._CUSTOM_REAL) rmass_inverse_acoustic = 1._CUSTOM_REAL
+
+! compute the inverse of the mass matrix
+ if(any_elastic) &
+ rmass_inverse_elastic(:) = 1._CUSTOM_REAL / rmass_inverse_elastic(:)
+ if(any_poroelastic) &
+ rmass_s_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_s_inverse_poroelastic(:)
+ if(any_poroelastic) &
+ rmass_w_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_w_inverse_poroelastic(:)
+ if(any_acoustic) &
+ rmass_inverse_acoustic(:) = 1._CUSTOM_REAL / rmass_inverse_acoustic(:)
+
+ end subroutine invert_mass_matrix
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/is_in_convex_quadrilateral.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/is_in_convex_quadrilateral.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/is_in_convex_quadrilateral.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/is_in_convex_quadrilateral.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,77 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine is_in_convex_quadrilateral(elmnt_coords, x_coord, z_coord, is_in)
+
+ implicit none
+
+ double precision, dimension(2,4) :: elmnt_coords
+ double precision, intent(in) :: x_coord, z_coord
+ logical, intent(out) :: is_in
+
+ real :: x1, x2, x3, x4, z1, z2, z3, z4
+ real :: normal1, normal2, normal3, normal4
+
+ x1 = elmnt_coords(1,1)
+ x2 = elmnt_coords(1,2)
+ x3 = elmnt_coords(1,3)
+ x4 = elmnt_coords(1,4)
+ z1 = elmnt_coords(2,1)
+ z2 = elmnt_coords(2,2)
+ z3 = elmnt_coords(2,3)
+ z4 = elmnt_coords(2,4)
+
+ normal1 = (z_coord-z1) * (x2-x1) - (x_coord-x1) * (z2-z1)
+ normal2 = (z_coord-z2) * (x3-x2) - (x_coord-x2) * (z3-z2)
+ normal3 = (z_coord-z3) * (x4-x3) - (x_coord-x3) * (z4-z3)
+ normal4 = (z_coord-z4) * (x1-x4) - (x_coord-x4) * (z1-z4)
+
+ if ((normal1 < 0) .or. (normal2 < 0) .or. (normal3 < 0) .or. (normal4 < 0)) then
+ is_in = .false.
+ else
+ is_in = .true.
+ endif
+
+ end subroutine is_in_convex_quadrilateral
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/lagrange_poly.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/lagrange_poly.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/lagrange_poly.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/lagrange_poly.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,162 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ double precision function hgll(I,Z,ZGLL,NZ)
+
+!-------------------------------------------------------------
+!
+! Compute the value of the Lagrangian interpolant L through
+! the NZ Gauss-Lobatto Legendre points ZGLL at point Z
+!
+!-------------------------------------------------------------
+
+ implicit none
+
+ integer i,nz
+ double precision z
+ double precision ZGLL(0:nz-1)
+
+ integer n
+ double precision EPS,DZ,ALFAN
+ double precision, external :: PNLEG,PNDLEG
+
+ EPS = 1.d-5
+ DZ = Z - ZGLL(I)
+ if(abs(DZ) < EPS) then
+ HGLL = 1.d0
+ return
+ endif
+ N = NZ - 1
+ ALFAN = dble(N)*(dble(N)+1.d0)
+ HGLL = - (1.d0-Z*Z)*PNDLEG(Z,N)/ (ALFAN*PNLEG(ZGLL(I),N)*(Z-ZGLL(I)))
+
+ end function hgll
+
+!
+!=====================================================================
+!
+
+ subroutine lagrange_any(xi,NGLL,xigll,h,hprime)
+
+! subroutine to compute the Lagrange interpolants based upon the GLL points
+! and their first derivatives at any point xi in [-1,1]
+
+ implicit none
+
+ integer NGLL
+ double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)
+
+ integer dgr,i,j
+ double precision prod1,prod2
+
+ do dgr=1,NGLL
+
+ prod1 = 1.0d0
+ prod2 = 1.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1 = prod1*(xi-xigll(i))
+ prod2 = prod2*(xigll(dgr)-xigll(i))
+ endif
+ enddo
+ h(dgr)=prod1/prod2
+
+ hprime(dgr)=0.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1=1.0d0
+ do j=1,NGLL
+ if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
+ enddo
+ hprime(dgr) = hprime(dgr)+prod1
+ endif
+ enddo
+ hprime(dgr) = hprime(dgr)/prod2
+
+ enddo
+
+ end subroutine lagrange_any
+
+!
+!=====================================================================
+!
+
+! subroutine to compute the derivative of the Lagrange interpolants
+! at the GLL points at any given GLL point
+
+ double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the derivative of the I-th
+! Lagrange interpolant through the
+! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
+!
+!------------------------------------------------------------------------
+
+ implicit none
+
+ integer i,j,nz
+ double precision zgll(0:nz-1)
+
+ integer degpoly
+
+ double precision, external :: pnleg,pndleg
+
+ degpoly = nz - 1
+ if (i == 0 .and. j == 0) then
+ lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == degpoly .and. j == degpoly) then
+ lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == j) then
+ lagrange_deriv_GLL = 0.d0
+ else
+ lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
+ (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
+ + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
+ (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
+ endif
+
+ end function lagrange_deriv_GLL
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_receivers.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/locate_receivers.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_receivers.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_receivers.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,317 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!----
+!---- locate_receivers finds the correct position of the receivers
+!----
+
+ 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,ipass, &
+ x_final_receiver, z_final_receiver)
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer nrec,nspec,npoin,ngnod,npgeo,ipass
+ integer, intent(in) :: nproc, myrank
+
+ integer knods(ngnod,nspec)
+ double precision coorg(NDIM,npgeo)
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! array containing coordinates of the points
+ double precision coord(NDIM,npoin)
+
+ integer irec,i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
+
+ double precision x_source,z_source,dist,stele,stbur
+ double precision, dimension(nrec) :: distance_receiver
+ double precision xi,gamma,dx,dz,dxi,dgamma
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision zigll(NGLLZ)
+
+ double precision x,z,xix,xiz,gammax,gammaz,jacobian
+
+! use dynamic allocation
+ double precision distmin
+ double precision, dimension(:), allocatable :: final_distance
+
+! receiver information
+ integer :: nrecloc
+ integer, dimension(nrec) :: ispec_selected_rec, recloc
+ double precision, dimension(nrec) :: xi_receiver,gamma_receiver
+
+! station information for writing the seismograms
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ 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
+ integer, dimension(nrec,nproc) :: gather_ispec_selected_rec
+ integer, dimension(nrec), intent(inout) :: which_proc_receiver
+ integer :: ierror
+
+
+ ierror = 0
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ierror)
+#endif
+
+! **************
+
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) '********************'
+ write(IOUT,*) ' locating receivers'
+ write(IOUT,*) '********************'
+ write(IOUT,*)
+ write(IOUT,*) 'reading receiver information from the DATA/STATIONS file'
+ write(IOUT,*)
+ endif
+
+ open(unit=1,file='DATA/STATIONS_target',status='old',action='read')
+
+! allocate memory for arrays using number of stations
+ allocate(final_distance(nrec))
+
+! loop on all the stations
+ do irec=1,nrec
+
+ ! set distance to huge initial value
+ distmin=HUGEVAL
+
+ read(1,*) station_name(irec),network_name(irec),st_xval(irec),st_zval(irec),stele,stbur
+
+ ! check that station is not buried, burial is not implemented in current code
+ if(abs(stbur) > TINYVAL) call exit_MPI('stations with non-zero burial not implemented yet')
+
+ ! compute distance between source and receiver
+ distance_receiver(irec) = sqrt((st_zval(irec)-z_source)**2 + (st_xval(irec)-x_source)**2)
+
+ 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
+
+ iglob = ibool(i,j,ispec)
+ dist = sqrt((st_xval(irec)-dble(coord(1,iglob)))**2 + (st_zval(irec)-dble(coord(2,iglob)))**2)
+
+ ! keep this point if it is closer to the receiver
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_rec(irec) = ispec
+ ix_initial_guess = i
+ iz_initial_guess = j
+ endif
+
+ enddo
+ enddo
+
+ ! end of loop on all the spectral elements
+ enddo
+
+
+! ****************************************
+! find the best (xi,gamma) for each receiver
+! ****************************************
+
+ ! use initial guess in xi and gamma
+ xi = xigll(ix_initial_guess)
+ gamma = zigll(iz_initial_guess)
+
+ ! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+ ! recompute jacobian for the new point
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_rec(irec),ngnod,nspec,npgeo, &
+ .true.)
+
+ ! compute distance to target location
+ dx = - (x - st_xval(irec))
+ dz = - (z - st_zval(irec))
+
+ ! compute increments
+ dxi = xix*dx + xiz*dz
+ dgamma = gammax*dx + gammaz*dz
+
+ ! update values
+ xi = xi + dxi
+ gamma = gamma + dgamma
+
+ ! impose that we stay in that element
+ ! (useful if user gives a receiver outside the mesh for instance)
+ ! we can go slightly outside the [1,1] segment since with finite elements
+ ! the polynomial solution is defined everywhere
+ ! this can be useful for convergence of itertive scheme with distorted elements
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
+
+ ! end of non linear iterations
+ enddo
+
+ ! compute final coordinates of point found
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_rec(irec),ngnod,nspec,npgeo, &
+ .true.)
+
+ ! store xi,gamma of point found
+ xi_receiver(irec) = xi
+ gamma_receiver(irec) = gamma
+
+ ! 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
+ close(1)
+
+! elect one process for each receiver.
+#ifdef USE_MPI
+ call MPI_GATHER(final_distance(1),nrec,MPI_DOUBLE_PRECISION,&
+ gather_final_distance(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
+ call MPI_GATHER(xi_receiver(1),nrec,MPI_DOUBLE_PRECISION,&
+ gather_xi_receiver(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
+ call MPI_GATHER(gamma_receiver(1),nrec,MPI_DOUBLE_PRECISION,&
+ gather_gamma_receiver(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
+ call MPI_GATHER(ispec_selected_rec(1),nrec,MPI_INTEGER,&
+ gather_ispec_selected_rec(1,1),nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
+
+ if ( myrank == 0 ) then
+ do irec = 1, nrec
+ which_proc_receiver(irec:irec) = minloc(gather_final_distance(irec,:)) - 1
+ enddo
+ endif
+
+ call MPI_BCAST(which_proc_receiver(1),nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
+
+#else
+
+ gather_final_distance(:,1) = final_distance(:)
+
+ gather_xi_receiver(:,1) = xi_receiver(:)
+ gather_gamma_receiver(:,1) = gamma_receiver(:)
+ gather_ispec_selected_rec(:,1) = ispec_selected_rec(:)
+
+ which_proc_receiver(:) = 0
+
+#endif
+
+ nrecloc = 0
+ do irec = 1, nrec
+ if ( which_proc_receiver(irec) == myrank ) then
+ nrecloc = nrecloc + 1
+ recloc(nrecloc) = irec
+ endif
+ enddo
+
+ if (myrank == 0 .and. ipass == 1) then
+
+ do irec = 1, nrec
+ write(IOUT,*)
+ write(IOUT,*) 'Station # ',irec,' ',station_name(irec),network_name(irec)
+
+ if(gather_final_distance(irec,which_proc_receiver(irec)+1) == HUGEVAL) &
+ call exit_MPI('error locating receiver')
+
+ write(IOUT,*) ' original x: ',sngl(st_xval(irec))
+ write(IOUT,*) ' original z: ',sngl(st_zval(irec))
+ write(IOUT,*) ' distance from source: ',sngl(distance_receiver(irec))
+ write(IOUT,*) 'closest estimate found: ',sngl(gather_final_distance(irec,which_proc_receiver(irec)+1)), &
+ ' m away'
+ write(IOUT,*) ' in element ',gather_ispec_selected_rec(irec,which_proc_receiver(irec)+1)
+ write(IOUT,*) ' at process ', which_proc_receiver(irec)
+ write(IOUT,*) ' at xi,gamma coordinates = ',gather_xi_receiver(irec,which_proc_receiver(irec)+1),&
+ gather_gamma_receiver(irec,which_proc_receiver(irec)+1)
+ write(IOUT,*)
+ enddo
+
+ write(IOUT,*)
+ write(IOUT,*) 'end of receiver detection'
+ write(IOUT,*)
+
+ ! write out actual station locations (compare with STATIONS_target from meshfem2D)
+ ! NOTE: this will be written out even if generate_STATIONS = .false.
+ open(unit=15,file='DATA/STATIONS',status='unknown')
+ do irec = 1,nrec
+ write(15,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") &
+ irec,x_final_receiver(irec),z_final_receiver(irec)
+ enddo
+ close(15)
+
+ endif
+
+ ! deallocate arrays
+ deallocate(final_distance)
+
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ierror)
+#endif
+
+ end subroutine locate_receivers
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_source_force.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/locate_source_force.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_source_force.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_source_force.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,257 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!----
+!---- locate_source_force finds the correct position of the point force source
+!----
+
+ subroutine locate_source_force(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,ipass,iglob_source)
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer nspec,npoin,ngnod,npgeo,ipass
+
+ integer knods(ngnod,nspec)
+ double precision coorg(NDIM,npgeo)
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! array containing coordinates of the points
+ double precision coord(NDIM,npoin)
+
+ integer i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
+
+ double precision x_source,z_source,dist
+ double precision xi,gamma,dx,dz,dxi,dgamma
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision zigll(NGLLZ)
+
+ double precision x,z,xix,xiz,gammax,gammaz,jacobian
+ double precision distmin,final_distance,dist_glob
+
+! source information
+ integer ispec_selected_source,is_proc_source,nb_proc_source,iglob_source
+ integer, intent(in) :: nproc, myrank
+ double precision xi_source,gamma_source
+
+#ifdef USE_MPI
+ integer, dimension(1:nproc) :: allgather_is_proc_source
+ integer, dimension(1) :: locate_is_proc_source
+ integer :: ierror
+#endif
+
+
+
+! **************
+ if ((myrank == 0 .or. nproc == 1) .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) '*******************************'
+ write(IOUT,*) ' locating force source'
+ write(IOUT,*) '*******************************'
+ write(IOUT,*)
+ endif
+
+! set distance to huge initial value
+ distmin = HUGEVAL
+
+ is_proc_source = 0
+
+ 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
+
+ iglob = ibool(i,j,ispec)
+ dist = sqrt((x_source-dble(coord(1,iglob)))**2 &
+ + (z_source-dble(coord(2,iglob)))**2)
+
+! keep this point if it is closer to the source
+ if(dist < distmin) then
+ iglob_source = iglob
+ distmin = dist
+ ispec_selected_source = ispec
+ ix_initial_guess = i
+ iz_initial_guess = j
+ endif
+
+ enddo
+ enddo
+
+! 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)
+
+#else
+ dist_glob = distmin
+
+#endif
+
+! check if this process contains the source
+ if ( abs(dist_glob - distmin) < TINYVAL ) is_proc_source = 1
+
+#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)
+
+#else
+
+ nb_proc_source = is_proc_source
+
+#endif
+
+
+#ifdef USE_MPI
+ ! when several processes contain the source, we elect one of them (minimum rank).
+ if ( nb_proc_source > 1 ) then
+
+ call MPI_ALLGATHER(is_proc_source, 1, MPI_INTEGER, allgather_is_proc_source(1), &
+ 1, MPI_INTEGER, MPI_COMM_WORLD, ierror)
+ locate_is_proc_source = maxloc(allgather_is_proc_source) - 1
+
+ if ( myrank /= locate_is_proc_source(1) ) then
+ is_proc_source = 0
+ endif
+ nb_proc_source = 1
+
+ endif
+
+#endif
+
+! ****************************************
+! find the best (xi,gamma) for each source
+! ****************************************
+
+! use initial guess in xi and gamma
+ xi = xigll(ix_initial_guess)
+ gamma = zigll(iz_initial_guess)
+
+! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+! recompute jacobian for the new point
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
+ .true.)
+
+! compute distance to target location
+ dx = - (x - x_source)
+ dz = - (z - z_source)
+
+! compute increments
+ dxi = xix*dx + xiz*dz
+ dgamma = gammax*dx + gammaz*dz
+
+! update values
+ xi = xi + dxi
+ gamma = gamma + dgamma
+
+! impose that we stay in that element
+! (useful if user gives a source outside the mesh for instance)
+! we can go slightly outside the [1,1] segment since with finite elements
+! the polynomial solution is defined everywhere
+! this can be useful for convergence of itertive scheme with distorted elements
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
+
+! end of non linear iterations
+ enddo
+
+! compute final coordinates of point found
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
+ .true.)
+
+! store xi,gamma of point found
+ xi_source = xi
+ gamma_source = gamma
+
+! compute final distance between asked and found
+ final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
+
+ if (is_proc_source == 1 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Force source:'
+
+ if(final_distance == HUGEVAL) call exit_MPI('error locating force source')
+
+ write(IOUT,*) ' original x: ',sngl(x_source)
+ write(IOUT,*) ' original z: ',sngl(z_source)
+ write(IOUT,*) 'closest estimate found: ',sngl(final_distance),' m away'
+#ifdef USE_MPI
+ write(IOUT,*) ' in rank ',myrank
+#endif
+ write(IOUT,*) ' in element ',ispec_selected_source
+ write(IOUT,*) ' at xi,gamma coordinates = ',xi_source,gamma_source
+ write(IOUT,*)
+
+ write(IOUT,*)
+ write(IOUT,*) 'end of force source detection'
+ write(IOUT,*)
+ endif
+
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ierror)
+#endif
+
+ end subroutine locate_source_force
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_source_moment_tensor.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/locate_source_moment_tensor.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_source_moment_tensor.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/locate_source_moment_tensor.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,256 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!----
+!---- locate_source_moment_tensor finds the correct position of the moment-tensor source
+!----
+
+ 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,ipass)
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer nspec,npoin,ngnod,npgeo,ipass
+
+ integer knods(ngnod,nspec)
+ double precision coorg(NDIM,npgeo)
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! array containing coordinates of the points
+ double precision coord(NDIM,npoin)
+
+ integer i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
+
+ double precision x_source,z_source,dist
+ double precision xi,gamma,dx,dz,dxi,dgamma
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision zigll(NGLLZ)
+
+ double precision x,z,xix,xiz,gammax,gammaz,jacobian
+ double precision distmin,final_distance,dist_glob
+
+! source information
+ integer ispec_selected_source,is_proc_source,nb_proc_source
+ integer, intent(in) :: nproc, myrank
+ double precision xi_source,gamma_source
+
+#ifdef USE_MPI
+ integer, dimension(1:nproc) :: allgather_is_proc_source
+ integer, dimension(1) :: locate_is_proc_source
+ integer :: ierror
+#endif
+
+
+
+! **************
+ 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
+
+ is_proc_source = 0
+
+ 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
+
+ iglob = ibool(i,j,ispec)
+ dist = sqrt((x_source-dble(coord(1,iglob)))**2 &
+ + (z_source-dble(coord(2,iglob)))**2)
+
+! keep this point if it is closer to the source
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_source = ispec
+ ix_initial_guess = i
+ iz_initial_guess = j
+ endif
+
+ enddo
+ enddo
+
+! 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)
+
+#else
+ dist_glob = distmin
+
+#endif
+
+! check if this process contains the source
+ if ( dist_glob == distmin ) is_proc_source = 1
+
+#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)
+
+#else
+ nb_proc_source = is_proc_source
+
+#endif
+
+
+#ifdef USE_MPI
+ ! when several processes contain the source, we elect one of them (minimum rank).
+ if ( nb_proc_source > 1 ) then
+
+ call MPI_ALLGATHER(is_proc_source, 1, MPI_INTEGER, allgather_is_proc_source(1), &
+ 1, MPI_INTEGER, MPI_COMM_WORLD, ierror)
+ locate_is_proc_source = maxloc(allgather_is_proc_source) - 1
+
+ if ( myrank /= locate_is_proc_source(1) ) then
+ is_proc_source = 0
+ endif
+ nb_proc_source = 1
+
+ endif
+
+#endif
+
+! ****************************************
+! find the best (xi,gamma) for each source
+! ****************************************
+
+! use initial guess in xi and gamma
+ xi = xigll(ix_initial_guess)
+ gamma = zigll(iz_initial_guess)
+
+! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+! recompute jacobian for the new point
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
+ .true.)
+
+! compute distance to target location
+ dx = - (x - x_source)
+ dz = - (z - z_source)
+
+! compute increments
+ dxi = xix*dx + xiz*dz
+ dgamma = gammax*dx + gammaz*dz
+
+! update values
+ xi = xi + dxi
+ gamma = gamma + dgamma
+
+! impose that we stay in that element
+! (useful if user gives a source outside the mesh for instance)
+! we can go slightly outside the [1,1] segment since with finite elements
+! the polynomial solution is defined everywhere
+! this can be useful for convergence of itertive scheme with distorted elements
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
+
+! end of non linear iterations
+ enddo
+
+! compute final coordinates of point found
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
+ .true.)
+
+! store xi,gamma of point found
+ xi_source = xi
+ gamma_source = gamma
+
+! compute final distance between asked and found
+ final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
+
+ if (is_proc_source == 1 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Moment-tensor source:'
+
+ if(final_distance == HUGEVAL) call exit_MPI('error locating moment-tensor source')
+
+ write(IOUT,*) ' original x: ',sngl(x_source)
+ write(IOUT,*) ' original z: ',sngl(z_source)
+ write(IOUT,*) 'closest estimate found: ',sngl(final_distance),' m away'
+#ifdef USE_MPI
+ write(IOUT,*) ' in rank ',myrank
+#endif
+ write(IOUT,*) ' in element ',ispec_selected_source
+ write(IOUT,*) ' at xi,gamma coordinates = ',xi_source,gamma_source
+ write(IOUT,*)
+
+ write(IOUT,*)
+ write(IOUT,*) 'end of moment-tensor source detection'
+ write(IOUT,*)
+ endif
+
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ierror)
+#endif
+
+ end subroutine locate_source_moment_tensor
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/netlib_specfun_erf.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/netlib_specfun_erf.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/netlib_specfun_erf.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/netlib_specfun_erf.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,318 @@
+
+ subroutine calerf(ARG,RESULT,JINT)
+
+!------------------------------------------------------------------
+!
+! This routine can be freely obtained from Netlib
+! at http://www.netlib.org/specfun/erf
+!
+! Most Netlib software packages have no restrictions on their use
+! but Netlib recommends that you check with the authors to be sure.
+! See http://www.netlib.org/misc/faq.html#2.3 for details.
+!
+!------------------------------------------------------------------
+!
+! This packet evaluates erf(x) for a real argument x.
+! It contains one FUNCTION type subprogram: ERF,
+! and one SUBROUTINE type subprogram, CALERF. The calling
+! statements for the primary entries are:
+!
+! Y = ERF(X)
+!
+! The routine CALERF is intended for internal packet use only,
+! all computations within the packet being concentrated in this
+! routine. The function subprograms invoke CALERF with the
+! statement
+!
+! call CALERF(ARG,RESULT,JINT)
+!
+! where the parameter usage is as follows
+!
+! Function Parameters for CALERF
+! call ARG Result JINT
+!
+! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0
+!
+! The main computation evaluates near-minimax approximations
+! from "Rational Chebyshev approximations for the error function"
+! by William J. Cody, Math. Comp., 1969, PP. 631-638. This
+! transportable program uses rational functions that theoretically
+! approximate erf(x) and erfc(x) to at least 18 significant
+! decimal digits. The accuracy achieved depends on the arithmetic
+! system, the compiler, the intrinsic functions, and proper
+! selection of the machine-dependent constants.
+!
+!*******************************************************************
+!*******************************************************************
+!
+! Explanation of machine-dependent constants
+!
+! XMIN = the smallest positive floating-point number.
+! XINF = the largest positive finite floating-point number.
+! XNEG = the largest negative argument acceptable to ERFCX;
+! the negative of the solution to the equation
+! 2*exp(x*x) = XINF.
+! XSMALL = argument below which erf(x) may be represented by
+! 2*x/sqrt(pi) and above which x*x will not underflow.
+! A conservative value is the largest machine number X
+! such that 1.0 + X = 1.0 to machine precision.
+! XBIG = largest argument acceptable to ERFC; solution to
+! the equation: W(x) * (1-0.5/x**2) = XMIN, where
+! W(x) = exp(-x*x)/[x*sqrt(pi)].
+! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to
+! machine precision. A conservative value is
+! 1/[2*sqrt(XSMALL)]
+! XMAX = largest acceptable argument to ERFCX; the minimum
+! of XINF and 1/[sqrt(pi)*XMIN].
+!
+! Approximate IEEE double precision values are defined below.
+!
+!*******************************************************************
+!*******************************************************************
+!
+! Error returns
+!
+! The program returns ERFC = 0 for ARG >= XBIG;
+!
+! Author: William J. Cody
+! Mathematics and Computer Science Division
+! Argonne National Laboratory
+! Argonne, IL 60439, USA
+!
+! Latest modification: March 19, 1990
+!
+! Converted to Fortran90 and slightly modified by
+! Dimitri Komatitsch, University of Pau, France, November 2007.
+!
+!------------------------------------------------------------------
+
+ implicit none
+
+ integer I,JINT
+ double precision A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEEN,SQRPI, &
+ TWO,THRESHOLD,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL, &
+ Y,YSQ,ZERO
+ dimension A(5),B(4),C(9),D(8),P(6),Q(5)
+
+!------------------------------------------------------------------
+! Mathematical constants
+!------------------------------------------------------------------
+ data FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/, &
+ SQRPI/5.6418958354775628695D-1/,THRESHOLD/0.46875D0/, &
+ SIXTEEN/16.0D0/
+
+!------------------------------------------------------------------
+! Machine-dependent constants
+!------------------------------------------------------------------
+ data XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/, &
+ XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erf in first interval
+!------------------------------------------------------------------
+ data A/3.16112374387056560D00,1.13864154151050156D02, &
+ 3.77485237685302021D02,3.20937758913846947D03, &
+ 1.85777706184603153D-1/
+ data B/2.36012909523441209D01,2.44024637934444173D02, &
+ 1.28261652607737228D03,2.84423683343917062D03/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erfc in second interval
+!------------------------------------------------------------------
+ data C/5.64188496988670089D-1,8.88314979438837594D0, &
+ 6.61191906371416295D01,2.98635138197400131D02, &
+ 8.81952221241769090D02,1.71204761263407058D03, &
+ 2.05107837782607147D03,1.23033935479799725D03, &
+ 2.15311535474403846D-8/
+ data D/1.57449261107098347D01,1.17693950891312499D02, &
+ 5.37181101862009858D02,1.62138957456669019D03, &
+ 3.29079923573345963D03,4.36261909014324716D03, &
+ 3.43936767414372164D03,1.23033935480374942D03/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erfc in third interval
+!------------------------------------------------------------------
+ data P/3.05326634961232344D-1,3.60344899949804439D-1, &
+ 1.25781726111229246D-1,1.60837851487422766D-2, &
+ 6.58749161529837803D-4,1.63153871373020978D-2/
+ data Q/2.56852019228982242D00,1.87295284992346047D00, &
+ 5.27905102951428412D-1,6.05183413124413191D-2, &
+ 2.33520497626869185D-3/
+
+ X = ARG
+ Y = ABS(X)
+ if (Y <= THRESHOLD) then
+
+!------------------------------------------------------------------
+! Evaluate erf for |X| <= 0.46875
+!------------------------------------------------------------------
+ YSQ = ZERO
+ if (Y > XSMALL) YSQ = Y * Y
+ XNUM = A(5)*YSQ
+ XDEN = YSQ
+
+ do I = 1, 3
+ XNUM = (XNUM + A(I)) * YSQ
+ XDEN = (XDEN + B(I)) * YSQ
+ enddo
+
+ RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
+ if (JINT /= 0) RESULT = ONE - RESULT
+ if (JINT == 2) RESULT = EXP(YSQ) * RESULT
+ goto 800
+
+!------------------------------------------------------------------
+! Evaluate erfc for 0.46875 <= |X| <= 4.0
+!------------------------------------------------------------------
+ else if (Y <= FOUR) then
+ XNUM = C(9)*Y
+ XDEN = Y
+
+ do I = 1, 7
+ XNUM = (XNUM + C(I)) * Y
+ XDEN = (XDEN + D(I)) * Y
+ enddo
+
+ RESULT = (XNUM + C(8)) / (XDEN + D(8))
+ if (JINT /= 2) then
+ YSQ = AINT(Y*SIXTEEN)/SIXTEEN
+ DEL = (Y-YSQ)*(Y+YSQ)
+ RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+ endif
+
+!------------------------------------------------------------------
+! Evaluate erfc for |X| > 4.0
+!------------------------------------------------------------------
+ else
+ RESULT = ZERO
+ if (Y >= XBIG) then
+ if (JINT /= 2 .OR. Y >= XMAX) goto 300
+ if (Y >= XHUGE) then
+ RESULT = SQRPI / Y
+ goto 300
+ endif
+ endif
+ YSQ = ONE / (Y * Y)
+ XNUM = P(6)*YSQ
+ XDEN = YSQ
+
+ do I = 1, 4
+ XNUM = (XNUM + P(I)) * YSQ
+ XDEN = (XDEN + Q(I)) * YSQ
+ enddo
+
+ RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
+ RESULT = (SQRPI - RESULT) / Y
+ if (JINT /= 2) then
+ YSQ = AINT(Y*SIXTEEN)/SIXTEEN
+ DEL = (Y-YSQ)*(Y+YSQ)
+ RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+ endif
+ endif
+
+!------------------------------------------------------------------
+! Fix up for negative argument, erf, etc.
+!------------------------------------------------------------------
+ 300 if (JINT == 0) then
+ RESULT = (HALF - RESULT) + HALF
+ if (X < ZERO) RESULT = -RESULT
+ else if (JINT == 1) then
+ if (X < ZERO) RESULT = TWO - RESULT
+ else
+ if (X < ZERO) then
+ if (X < XNEG) then
+ RESULT = XINF
+ else
+ YSQ = AINT(X*SIXTEEN)/SIXTEEN
+ DEL = (X-YSQ)*(X+YSQ)
+ Y = EXP(YSQ*YSQ) * EXP(DEL)
+ RESULT = (Y+Y) - RESULT
+ endif
+ endif
+ endif
+
+ 800 return
+
+ end subroutine calerf
+
+!--------------------------------------------------------------------
+
+ double precision function netlib_specfun_erf(X)
+
+! This subprogram computes approximate values for erf(x).
+! (see comments heading CALERF).
+!
+! Author/date: William J. Cody, January 8, 1985
+
+ implicit none
+
+ integer JINT
+ double precision X, RESULT
+
+ JINT = 0
+ call calerf(X,RESULT,JINT)
+ netlib_specfun_erf = RESULT
+
+ end function netlib_specfun_erf
+
+!
+! Subject: RE: Can one freely use and redistribute Fortran routines "specfun" from Netlib?
+! From: Jack Dongarra
+! Date: Wed, 21 Nov 2007 10:33:45 -0500
+! To: Rusty Lusk, Dimitri Komatitsch
+!
+! Yes the code can freely be used and incorporated into other software. You
+! should of course acknowledge the use of the software.
+!
+! Hope this helps,
+!
+! Jack Dongarra
+!
+! **********************************************************************
+! Prof. Jack Dongarra; Innovative Computing Laboratory; EECS Department;
+! 1122 Volunteer Blvd; University of Tennessee; Knoxville TN 37996-3450;
+! +1-865-974-8295; http://www.cs.utk.edu/~dongarra/
+!
+! -----Original Message-----
+! From: Rusty Lusk
+! Sent: Wednesday, November 21, 2007 10:29 AM
+! To: Dimitri Komatitsch
+! Cc: Jack Dongarra
+! Subject: Re: Can one freely use and redistribute Fortran routines "specfun"
+! from Netlib?
+!
+! Netlib is managed at the University of Tennesee, not Argonne at this
+! point. I have copied Jack Dongarra on this reply; he should be able
+! to answer questions about licensing issues for code from Netlib.
+!
+! Regards,
+! Rusty
+!
+! On Nov 21, 2007, at 8:36 AM, Dimitri Komatitsch wrote:
+!
+! >
+! > Dear Sir,
+! >
+! > Can one freely use and redistribute Fortran routines "specfun" from
+! > Netlib http://netlib2.cs.utk.edu/specfun/
+! > which were written back in 1985-1990 by William J. Cody
+! > from the Mathematics and Computer Science Division at Argonne?
+! >
+! > We use one of these routines (the error function, erf())
+! > in one of our source codes, which we would like to
+! > release as open source under GPL v2+, and we therefore
+! > wonder if we could include that erf() routine in the
+! > package in a separate file (of course saying in a comment in the
+! > header that it comes from Netlib and was written by William J. Cody from
+! > Argonne).
+! >
+! > Thank you,
+! > Best regards,
+! >
+! > Dimitri Komatitsch.
+! >
+! > --
+! > Dimitri Komatitsch - dimitri.komatitsch aT univ-pau.fr
+! > Professor, University of Pau, Institut universitaire de France
+! > and INRIA Magique3D, France http://www.univ-pau.fr/~dkomati1
+! >
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/paco_beyond_critical.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/paco_beyond_critical.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/paco_beyond_critical.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/paco_beyond_critical.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,605 @@
+!
+! This subroutine was written by Paco Sanchez-Sesma and his colleagues
+! from the Autonomous University of Mexico (UNAM), Mexico City, Mexico
+!
+! original name : DISTRAFF.f
+!
+! CALCULO DE DESPLAZAMIENTOS (UX, UZ) y TRACCIONES (TX, TZ) DE CAMPO LIBRE
+! EN UN SEMIESPACIO ELASTICO Y EN LA VECINDAD DE LA SUPERFICIE
+!
+! INCIDENCIA DE ONDAS P, SV Y DE RAYLEIGH
+!
+! 7 de febrero de 2007
+!
+! modified by Dimitri Komatitsch and Ronan Madec in March 2008
+! in particular, converted to Fortran90 and to double precision
+
+subroutine paco_beyond_critical(coord,npoin,deltat,NSTEP_global,angleforce,&
+ f0,cp_local,cs_local,INCLUDE_ATTENUATION,QD,source_type,v0x_left,v0z_left,v0x_right,v0z_right,&
+ v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot,left_bound,right_bound,&
+ bot_bound,nleft,nright,nbot,displ_elastic,veloc_elastic,accel_elastic)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: f0,cp_local,cs_local,deltat,dt,TP,angleforce,QD,delta_in_period
+ logical :: INCLUDE_ATTENUATION
+ integer :: npt,NSTEP_global,source_type,nleft,nright,nbot,npoin
+
+ integer, dimension(nleft) :: left_bound
+ integer, dimension(nright) :: right_bound
+ integer, dimension(nbot) :: bot_bound
+
+ double precision, dimension(nleft,NSTEP_global) :: v0x_left,v0z_left, t0x_left,t0z_left
+ double precision, dimension(nright,NSTEP_global) :: v0x_right,v0z_right, t0x_right,t0z_right
+ double precision, dimension(nbot,NSTEP_global) :: v0x_bot,v0z_bot, t0x_bot,t0z_bot
+
+ double precision, dimension(2,npoin) :: coord
+ double precision, dimension(2,npoin) :: displ_elastic
+ double precision, dimension(2,npoin) :: veloc_elastic
+ double precision, dimension(2,npoin) :: accel_elastic
+
+ integer, dimension(:),allocatable :: local_pt
+
+ double precision, dimension(:), allocatable :: temp_field
+
+ integer :: J, indice, NSTEP_local, FLAG, N, NFREC, NFREC1
+
+ double precision :: ANU,BEALF,ALFBE,RLM,VNX,VNZ,A1,B1,TOTO,FJ,AKA,AQA,GAMR
+
+! location of the point
+ double precision :: X, Z, xmin, xmax, zmin, zmax
+ integer :: inode
+
+ complex(selected_real_kind(15,300)) :: CAKA,CAQA,UI,UR
+ complex(selected_real_kind(15,300)) :: UX,UZ,SX,SZ,SXZ,A2,B2,AL,AK,AM
+
+ complex(selected_real_kind(15,300)) :: TX,TZ
+
+ complex(selected_real_kind(15,300)), dimension(:),allocatable::Field_Ux,Field_Uz,Field_Tx,Field_Tz
+
+ double precision :: TS
+
+! to move the place where the wave reflects on free surface (offset too)
+ double precision :: offset
+
+! size of the model
+ xmin=minval(coord(1,:))
+ xmax=maxval(coord(1,:))
+ zmin=minval(coord(2,:))
+ zmax=maxval(coord(2,:))
+
+! offset of the origin of time of the Ricker (equivalent to t0 in SPECFEM2D)
+ offset=4.d0*(xmax-xmin)/5.d0
+ TS=2.d0/f0
+
+! dominant period of the Ricker (equivalent to 1/f0 in SPECFEM2D)
+ TP=1.d0/f0
+
+! find optimal period
+! if period is too small, you should see several initial plane wave on your initial field
+ delta_in_period=2.d0
+ do while(delta_in_period<1.5*abs(xmax-xmin)/cs_local)
+ delta_in_period=2.d0*delta_in_period
+ end do
+
+! test Deltat compatibility
+ DT=256.d0
+ do while(DT>deltat)
+ DT=DT/2.d0
+ end do
+ if (abs(DT-deltat)>1.0d-13) then
+ print *, "you must take a deltat as a power of two (power can be negative)"
+ print *, "for example you can take", DT
+ stop "can't go further, restart with new deltat"
+ end if
+
+ DT=deltat/2.d0
+
+ N=2
+ do while(N<2*NSTEP_global+1)
+ N=2.d0*N
+ end do
+
+ do while(DT<(delta_in_period/N))
+ N=2.d0*N
+ end do
+
+ print *, 'N found to do frequency calcul :', N
+ print *,'number of discrete frequencies = ',N/2
+ print *,'delta in period (seconds) = ',delta_in_period
+ print *,'delta in frequency (Hz) = ',1.d0/delta_in_period
+ print *,'dt (here we need deltat/2) = ', DT
+
+ NFREC=N/2
+ NFREC1=NFREC+1
+
+
+!
+! FDT: FUNCION DE TRASFERENCIA
+!
+
+! calculation of Poisson's ratio
+ ANU = (cp_local*cp_local-2.d0*cs_local*cs_local)/(2.d0*(cp_local*cp_local-cs_local*cs_local))
+ print *,"Poisson's ratio = ",ANU
+
+ UI=(0.0d0, 1.0d0)
+ UR=(1.0d0, 0.0d0)
+
+! convert angle to radians
+ GAMR = angleforce
+
+ BEALF=SQRT((1.0d0-2.0d0*ANU)/(2.0d0*(1.0d0-ANU)))
+ ALFBE=1.0d0/BEALF
+ RLM=ALFBE**2-2.0d0
+
+! flags: interior=0, left=1, right=2, bottom=3
+ do FLAG=0,3
+
+ if (FLAG==0) then
+ print *, "calcul of the initial field for every point of the mesh"
+ npt=npoin
+ allocate(local_pt(npt))
+ do inode=1,npt
+ local_pt(inode)=inode
+ end do
+ NSTEP_local=1
+ else if(FLAG==1) then
+ print *, "calcul of every time step on the left absorbing boundary"
+ npt=nleft
+ allocate(local_pt(npt))
+ local_pt=left_bound
+ NSTEP_local=NSTEP_global
+ else if(FLAG==2) then
+ print *, "calcul of every time step on the right absorbing boundary"
+ npt=nright
+ allocate(local_pt(npt))
+ local_pt=right_bound
+ NSTEP_local=NSTEP_global
+ else if(FLAG==3) then
+ print *, "calcul of every time step on the bottom absorbing boundary"
+ npt=nbot
+ allocate(local_pt(npt))
+ local_pt=bot_bound
+ NSTEP_local=NSTEP_global
+ end if
+
+! to distinguish all model case and boundary case
+ allocate(temp_field(NSTEP_local))
+
+ allocate(Field_Ux(NFREC1))
+ allocate(Field_Uz(NFREC1))
+ allocate(Field_Tx(NFREC1))
+ allocate(Field_Tz(NFREC1))
+
+
+ if(mod(N,2) /= 0) stop 'N must be a multiple of 2'
+
+! normal vector to the edge at this grid point
+! therefore corners between two grid edges must be computed twice
+! because the normal will change
+ if (FLAG==1) then
+ VNZ = 0.d0
+ VNX = 1.d0
+ else if (FLAG==2) then
+ VNZ = 0.d0
+ VNX = 1.d0
+ else if (FLAG==3) then
+ VNZ = 1.d0
+ VNX = 0.d0
+ else
+ VNZ = 0.d0
+ VNX = 0.d0
+ end if
+
+
+ do indice=1,npt
+
+ if (FLAG==0) then
+ inode=indice
+ X=coord(1,indice)-offset
+! specfem coordinate axes are implemented from bottom to top whereas for this code
+! we need from top to bottom
+ Z=zmax-coord(2,indice)
+ else
+ inode=local_pt(indice)
+ X=coord(1,inode)-offset
+! specfem coordinate axes are implemented from bottom to top whereas for this code
+! we need from top to bottom
+ Z=zmax-coord(2,inode)
+ end if
+
+ if (mod(indice,500)==0) then
+ print *, indice, "points have been treated on ",npt," total points"
+ end if
+
+!
+! first handle the particular case of zero frequency
+!
+ TOTO=0.01d0
+ IF (source_type==1) CALL ONDASP(GAMR,0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+ IF (source_type==2) CALL ONDASS(GAMR,TOTO,0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+ IF (source_type==3) CALL ONDASR(0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+
+
+ TOTO=0.0d0
+ CALL DESFXY(TOTO,TOTO,source_type,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
+
+! write the frequency seismograms
+ TX = SX *VNX+SXZ*VNZ
+ TZ = SXZ*VNX+SZ *VNZ
+
+ Field_Ux(1)=UX
+ Field_Uz(1)=UZ
+ if (FLAG/=0) then
+ Field_Tx(1)=TX
+ Field_Tz(1)=TZ
+ end if
+
+!
+! then loop on all the other discrete frequencies
+!
+ do J=1,N/2
+
+! compute the value of the frequency (= index * delta in frequency = index * 1/delta in period)
+ FJ = dble(J) * 1.d0 / delta_in_period
+
+! pulsation (= 2 * PI * frequency)
+ AKA=2.0d0*PI*FJ
+
+ AQA=AKA*BEALF
+
+! exclude attenuation completely if needed
+ if(INCLUDE_ATTENUATION) then
+ CAKA=CMPLX(AKA,-AKA/(2.0d0*QD))
+ CAQA=CMPLX(AQA,-AQA/(2.0d0*QD))
+ else
+ CAKA=CMPLX(AKA,0)
+ CAQA=CMPLX(AQA,0)
+ endif
+
+ IF (source_type==1) CALL ONDASP(GAMR,AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+ IF (source_type==2) CALL ONDASS(GAMR,AKA,AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+ IF (source_type==3) CALL ONDASR(AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+
+ CALL DESFXY(X,Z,source_type,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
+
+! write the frequency seismograms
+ TX = SX *VNX+SXZ*VNZ
+ TZ = SXZ*VNX+SZ *VNZ
+
+ Field_Ux(J+1)=UX
+ Field_Uz(J+1)=UZ
+ if (FLAG/=0) then
+ Field_Tx(J+1)=TX
+ Field_Tz(J+1)=TZ
+ end if
+
+ enddo
+
+! to convert frequency field in time field
+! (number at the end are unit numbers for writing in the good file,
+! in the case of the traction we fill only one file per call)
+
+! global model case for initial field
+ if (FLAG==0) then
+ call paco_convolve_fft(Field_Ux,1,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ displ_elastic(1,indice)=temp_field(1)
+ call paco_convolve_fft(Field_Uz,1,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ displ_elastic(2,indice)=temp_field(1)
+ call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ veloc_elastic(1,indice)=temp_field(1)
+ call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ veloc_elastic(2,indice)=temp_field(1)
+ call paco_convolve_fft(Field_Ux,3,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ accel_elastic(1,indice)=temp_field(1)
+ call paco_convolve_fft(Field_Uz,3,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ accel_elastic(2,indice)=temp_field(1)
+
+! absorbing boundaries
+
+! left case
+ else if (FLAG==1) then
+ call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0x_left(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0z_left(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0x_left(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0z_left(indice,:)=temp_field(:)
+
+! right case
+ else if (FLAG==2) then
+ call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0x_right(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0z_right(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0x_right(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0z_right(indice,:)=temp_field(:)
+
+! bottom case
+ else if (FLAG==3) then
+ call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0x_bot(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0z_bot(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0x_bot(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0z_bot(indice,:)=temp_field(:)
+ end if
+ enddo
+
+ deallocate(temp_field)
+ deallocate(local_pt)
+
+ deallocate(Field_Ux)
+ deallocate(Field_Uz)
+ deallocate(Field_Tx)
+ deallocate(Field_Tz)
+
+ end do
+
+end subroutine paco_beyond_critical
+
+!---
+
+SUBROUTINE DESFXY(X,Z,ICAS,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
+
+ implicit none
+
+ double precision A1,B1,RLM,X,Z
+ integer ICAS
+ complex(selected_real_kind(15,300)) :: UX,UZ,SX,SZ,SXZ,A2,B2,AL,AK,AM
+ complex(selected_real_kind(15,300)) :: UI,FAC
+ complex(selected_real_kind(15,300)) :: AUX1,AUX2,FI1,FI2,PS1,PS2
+
+ UI=(0.0d0,1.0d0)
+ if (A1/=0.0d0) then
+ AUX1=A1*EXP(UI*(AM*Z-AL*X)) ! campo P incidente
+ else
+ AUX1=CMPLX(0.0d0)
+ end if
+ if (A2/=0.0d0) then
+ AUX2=A2*EXP(-UI*(AM*Z+AL*X)) *1.0d0 ! campo P reflejado
+ else
+ AUX2=CMPLX(0.0d0)
+ end if
+ FI1=AUX1+AUX2
+ FI2=AUX1-AUX2
+ if (B1/=0.0d0) then
+ AUX1=B1*EXP(UI*(AK*Z-AL*X)) ! campo S incidente
+ else
+ AUX1=CMPLX(0.0d0)
+ end if
+ if (B2/=0.0d0) then
+ AUX2=B2*EXP(-UI*(AK*Z+AL*X)) *1.0d0 ! campo S reflejado
+ else
+ AUX2=CMPLX(0.0d0)
+ end if
+ PS1=AUX1+AUX2
+ PS2=AUX1-AUX2
+
+!
+! FAC ES PARA TENER CONSISTENCIA CON AKI & RICHARDS (1980)
+!
+ FAC=UI
+ IF (ICAS==2)FAC=-UI
+
+ UX=(-UI*AL*FI1+UI*AK*PS2)*FAC
+
+ UZ=(UI*AM*FI2+UI*AL*PS1)*FAC
+! Paco's convention for vertical coordinate axis is inverted
+ UZ = - UZ
+
+ AUX1=AL*AL+AM*AM
+ SX=(-RLM*AUX1*FI1-2.0d0*AL*(AL*FI1-AK*PS2))*FAC
+ SZ=(-RLM*AUX1*FI1-2.0d0*(AM*AM*FI1+AK*AL*PS2))*FAC
+
+ SXZ=(2.0d0*AM*AL*FI2+(AL*AL-AK*AK)*PS1)*FAC
+! Paco's convention for vertical coordinate axis is inverted
+ SXZ = - SXZ
+
+END SUBROUTINE DESFXY
+
+SUBROUTINE FAFB(CA,CB,FA,FB)
+
+ implicit none
+
+ double precision CA,CB,A,B
+ complex(selected_real_kind(15,300)) :: FA,FB,ZER,UI
+
+ ZER=(0.0d0,0.0d0)
+ UI=(0.0d0,1.0d0)
+ A=CA*CA-1.0d0
+ B=CB*CB-1.0d0
+
+ IF (CA<1.0d0) then
+ FA=-UI*SQRT(-A)
+ else
+ FA=SQRT(A)+ZER
+ end IF
+
+ IF (CB<1.0d0) then
+ FB=-UI*SQRT(-B)
+ else
+ FB=CMPLX(SQRT(B),0.0d0)
+ end IF
+
+END SUBROUTINE FAFB
+
+SUBROUTINE A2B2(FA,FB,A2,B2)
+
+ implicit none
+
+ complex(selected_real_kind(15,300)) :: FA,FB,A2,B2,DEN,AUX
+
+ AUX=FB*FB-1.0d0
+ DEN=4.0d0*FA*FB+AUX*AUX
+ A2=(4.0d0*FA*FB-AUX*AUX)/DEN
+ B2=4.0d0*FA*AUX/DEN
+
+END SUBROUTINE A2B2
+
+! calculation of P waves
+SUBROUTINE ONDASP(GP,AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+
+ implicit none
+
+ double precision A1,B1,ANU,CA,CB,GP,AQB,BEALF
+ complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
+
+ ZER=(0.0d0,0.0d0)
+ BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
+ A1=1.0d0/AQB
+ B1=0.0d0
+
+ IF (GP==0.0d0) then
+ AL=ZER
+ AK=ZER
+ AM=AQB+ZER
+ A2=(-1.0d0+ZER)/AQB
+ B2=ZER
+ RETURN
+ end IF
+
+ CA=1.0d0/SIN(GP)
+ CB=CA/BEALF
+ AL=AQB/CA+ZER
+ CALL FAFB(CA,CB,FA,FB)
+ AK=AL*FB
+ AM=AL*FA
+ CALL A2B2(FA,FB,A2,B2)
+ A2=A2/AQB
+ B2=B2/AQB
+
+END SUBROUTINE ONDASP
+
+! calculation of S waves
+SUBROUTINE ONDASS(GS,AKB,AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+
+ implicit none
+
+ double precision A1,B1,ANU,CA,CB,GS,AQB,BEALF,AKB
+ complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
+
+ ZER=(0.0d0,0.0d0)
+ BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
+ A1=0.0d0
+ B1=1.0d0/AKB
+
+ IF (GS==0.0d0) then
+ AL=ZER
+ AK=AKB+ZER
+ AM=ZER
+ A2=ZER
+ B2=(-1.0d0+ZER)/AKB
+ return
+ end IF
+
+ CB=1.0d0/SIN(GS)
+ CA=CB*BEALF
+
+!
+! case of the critical angle
+!
+ IF (CA==1.d0) then
+ AL=AQB+ZER
+ AM=ZER
+ CALL FAFB(CA,CB,FA,FB)
+ AK=AL*FB
+ B2=-B1
+ A2=-4.0d0*COS(GS)*B1/(1./BEALF-2.*BEALF)
+
+! case of an angle that is not critical
+ ELSE
+ AL=AQB/CA+ZER
+ CALL FAFB(CA,CB,FA,FB)
+ AK=AL*FB
+ AM=AL*FA
+ CALL A2B2(FA,FB,B2,A2)
+ A2=-A2*FB/FA
+ A2=A2/AKB
+ B2=B2/AKB
+ endif
+
+END SUBROUTINE ONDASS
+
+! calculation of Rayleigh waves
+SUBROUTINE ONDASR(AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+
+ implicit none
+
+ double precision A1,B1,ANU,CA,CB,AQB,BEALF,ba2
+ complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
+
+ double precision, external :: crb
+
+ ZER=(0.0d0,0.0d0)
+ A1=0.0d0
+ B1=0.0d0
+ B2=1.0d0+ZER
+ BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
+ BA2=BEALF*BEALF
+ CB=CRB(BEALF)
+ CA=CB*BEALF
+ AL=AQB/CA+ZER
+
+ CALL FAFB(CA,CB,FA,FB)
+
+ AK=AL*FB
+ AM=AL*FA
+ A2=2.0d0*FB/(FB*FB-1.0d0)*B2
+ B2=B2/(AL*A2+AK)
+ A2=A2*B2
+
+END SUBROUTINE ONDASR
+
+FUNCTION CRB(BEALF)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision U3,BA2,P,Q,FIND,F1,F2,F12,FACT,CRB,BEALF
+
+ U3=1.0d0/3.0d0
+ BA2=BEALF*BEALF
+ P=8.0d0/3.0d0-16.0d0*BA2
+ Q=272.0d0/27.0d0-80.0d0/3.0d0*BA2
+ FIND=Q*Q/4.0d0+P*P*P/27.0d0
+ IF (FIND>=0.0d0) then
+ F1=SQRT(FIND)-Q/2.0d0
+ IF (F1>0.0d0) then
+ F1=F1**U3
+ else
+ F1=-(-F1)**U3
+ end IF
+ F2=-SQRT(FIND)-Q/2.0d0
+ IF (F2>0.0d0) then
+ F2=F2**U3
+ else
+ F2=-(-F2)**U3
+ end IF
+ FACT=F1+F2+8.0d0/3.0d0
+ CRB=SQRT(FACT)
+ else
+ F1=-27.0d0*Q*Q/(4.0d0*P*P*P)
+ F1=SQRT(F1)
+ IF (Q<0.0d0) then
+ F1=COS((PI-ACOS(F1))/3.0d0)
+ else
+ F1=COS(ACOS(F1)/3.0d0)
+ end IF
+ F2=-P/3.0d0
+ F2=SQRT(F2)
+ F12=-2.0d0*F1*F2+8.0d0/3.0d0
+ CRB=SQRT(F12)
+ end IF
+
+END FUNCTION CRB
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/paco_convolve_fft.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/paco_convolve_fft.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/paco_convolve_fft.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/paco_convolve_fft.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,230 @@
+!
+! This subroutine was written by Paco Sanchez-Sesma and his colleagues
+! from the Autonomous University of Mexico (UNAM), Mexico City, Mexico
+!
+! PROGRAMA PARA CALCULAR SISMOGRAMAS SINTETICOS DADA LA
+! FUNCION DE TRANSFERENCIA PARA COMPONENTES Ux, Uz, R2
+! Tx y Tz SOLUCION DE CAMPO LIBRE Caso P-SV, RAYLEIGH
+!
+! modified by Dimitri Komatitsch and Ronan Madec in March 2008
+! in particular, converted to Fortran90 and to double precision
+
+subroutine paco_convolve_fft(Field,label,NSTEP,dt,NFREC,output_field,tp,ts)
+
+ implicit none
+
+ integer :: NFREC,N,NSTEP
+
+ complex(selected_real_kind(15,300)), dimension(NFREC+1) :: Field
+
+ complex(selected_real_kind(15,300)) :: CR(2*NFREC)
+
+ double precision, dimension(NSTEP) :: output_field
+
+ integer :: J,label
+
+ double precision :: AN,FUN,RAIZ,dt,tp,ts
+
+ double precision, external :: RIC, deRIC, de2RIC
+
+ N=2*NFREC
+
+ AN = N
+
+!
+! label=1 <=> champ U en entree =>convolution par un ricker pour U
+! label=2 <=> champ U en entree =>convolution par la derivee de ricker pour V
+! label=3 <=> champ U en entree =>convolution par la derivee seconde de ricker pour A
+! label=4 <=> champ T en entree =>convolution par un ricker
+!
+! flag=0 on a besoin de U, V et A (pas T)
+! flag/=0 on a besoin de T et V (pas U ni A)
+!
+! NSTEP==1 <=> FLAG==0 (flags: interior=0, left=1, right=2, bottom=3)
+!
+
+ do j=1,N
+ if (label==1 .or. label==4) FUN=ric(j,tp,ts,dt)
+ if (label==2) FUN=deric(j,tp,ts,dt)
+ if (label==3) FUN=de2ric(j,tp,ts,dt)
+ CR(j)=CMPLX(FUN,0.0d0)
+ enddo
+
+ CALL fourier_transform(N,CR,-1.0d0)
+
+ RAIZ = SQRT(AN)
+
+ CALL SINTER(Field,output_field,NSTEP,CR,RAIZ,NFREC,label,dt)
+
+END subroutine paco_convolve_fft
+
+SUBROUTINE SINTER(V,output_field,NSTEP,CR,RAIZ,NFREC,label,dt)
+
+ implicit none
+
+ integer NSTEP, j,jn,N,label,nfrec,mult,delay
+
+ double precision :: RAIZ
+
+ complex(selected_real_kind(15,300)) :: VC
+
+ double precision VT(2*NFREC)
+
+ double precision :: filt,dt
+
+ double precision, dimension(NSTEP) :: output_field
+
+ complex(selected_real_kind(15,300)), dimension(NFREC+1) :: V
+
+ complex(selected_real_kind(15,300)) :: CY(2*NFREC),CR(2*NFREC)
+
+ N=2*NFREC
+
+ CY(1) = CR(1) * V(1) * RAIZ * dt
+
+ DO J=2,N/2+1
+ FILT = 1.0d0
+ VC = V(J)
+ CY(J)= CR(J)*VC * RAIZ * dt/ FILT
+ JN = N-J+2
+ CY(JN)=CONJG(CY(J))
+ enddo
+
+ CALL fourier_transform(N,CY,1.0d0)
+
+ if (label==1 .or. label==3 .or. (label==2 .and. NSTEP==1)) then
+! coefficients to take time steps needed (t=0: first time step)
+ mult=1
+ delay=0
+ else if(label==2 .and. NSTEP>1) then
+! coefficients to take time steps needed (t=i*deltat+1/2: one step on two starting at 1/2)
+ mult=2
+ delay=0
+ else if(label==4) then
+! coefficients to take time steps needed (t=i*deltat+1: one step on two starting at 1)
+ mult=2
+ delay=1
+ end if
+
+ do J=1,NSTEP
+ CY(mult*J+delay)=CY(mult*J+delay)/RAIZ/dt
+ VT(mult*J+delay)=REAL(CY(mult*J+delay))
+ output_field(J)=VT(mult*J+delay)
+ enddo
+
+END SUBROUTINE SINTER
+
+!
+! Ricker time function
+!
+FUNCTION RIC(J,tp,ts,dt)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: A,RIC,tp,ts,dt
+
+ integer j
+
+ A=PI*(dt*(J-1)-ts)/tp
+ A=A*A
+ RIC=0.0d0
+ IF(A>30.0d0) RETURN
+ RIC=(A-0.5)*EXP(-A)
+
+END FUNCTION RIC
+
+!
+! first time derivative of Ricker time function
+!
+FUNCTION deRIC(J,tp,ts,dt)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: A,A_dot,deRIC,tp,ts,dt
+ integer :: j
+
+ A=PI*(dt*(J-1)-ts)/tp
+ A=A*A
+ A_dot=2*(PI/tp)**2*(dt*(J-1)-ts)
+ deRIC=0.0d0
+ IF(A>30.0d0) RETURN
+ deRIC=A_dot*(1.5-A)*EXP(-A)
+
+END FUNCTION deRIC
+
+!
+! second time derivative of Ricker time function
+!
+FUNCTION de2RIC(J,tp,ts,dt)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: A,A_dot,A_dot_dot,de2RIC,tp,ts,dt
+ integer j
+
+ A=PI*(dt*(J-1)-ts)/tp
+ A=A*A
+ A_dot=2*(PI/tp)**2*(dt*(J-1)-ts)
+ A_dot_dot=2*(PI/tp)**2
+ de2RIC=0.0d0
+ IF(A>30.0d0) RETURN
+ de2RIC=(A_dot_dot*(1.5-A)-A_dot*A_dot-A_dot*(1.5-A)*A_dot)*EXP(-A)
+
+END FUNCTION de2RIC
+
+
+! Fourier transform
+SUBROUTINE fourier_transform(LX,CX,SIGNI)
+
+ implicit none
+
+ include "constants.h"
+
+ integer LX,i,j,l,istep,m
+
+ double precision SC
+
+ complex(selected_real_kind(15,300)) :: CX(LX),CARG,CW,CTEMP
+
+ double precision SIGNI
+
+ J=1
+ SC=SQRT(1.0d0/LX)
+ DO I=1,LX
+ IF (I<=J) then
+ CTEMP=CX(J)*SC
+ CX(J)=CX(I)*SC
+ CX(I)=CTEMP
+ end IF
+ M=LX/2
+ do while (M>=1 .and. M<J)
+ J=J-M
+ M=M/2
+ end do
+ J=J+M
+ end DO
+ L=1
+
+ do while(L<LX)
+ ISTEP=2*L
+ DO M=1,L
+ CARG=(0.0d0,1.0d0)*(PI*SIGNI*(M-1))/L
+ CW=EXP(CARG)
+ DO I=M,LX,ISTEP
+ CTEMP=CW*CX(I+L)
+ CX(I+L)=CX(I)-CTEMP
+ CX(I)=CX(I)+CTEMP
+ end DO
+ end DO
+
+ L=ISTEP
+ end do
+
+END SUBROUTINE fourier_transform
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/plotgll.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/plotgll.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/plotgll.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/plotgll.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,258 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
+
+! output the Gauss-Lobatto-Legendre mesh in a gnuplot file
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec,iy,ix,iglobnum,iglobnum2,ibloc,inode,npoin,npgeo,ngnod,nspec
+
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLX,nspec)
+
+ double precision coorg(NDIM,npgeo),coord(NDIM,npoin)
+
+! coordinates of the nodes for Gnuplot file
+ integer, parameter :: MAXNGNOD = 9
+ double precision xval(MAXNGNOD),zval(MAXNGNOD)
+
+ character(len=70) name
+
+!
+!---- output the GLL mesh in a Gnuplot file
+!
+
+ write(iout,*)
+ write(iout,*) 'Generating gnuplot meshes...'
+ write(iout,*)
+
+! create non empty files for the case of 4-node elements
+
+ name='macros1.gnu'
+ open(unit=30,file=name,status='unknown')
+
+ name='macros2.gnu'
+ open(unit=31,file=name,status='unknown')
+ write(31,"('')")
+
+ name='gllmesh1.gnu'
+ open(unit=20,file=name,status='unknown')
+
+ name='gllmesh2.gnu'
+ open(unit=21,file=name,status='unknown')
+ write(21,"('')")
+
+ do ispec = 1,nspec
+
+!
+!---- plot the lines in xi-direction
+!
+ do iy = 1,NGLLZ
+ do ix = 1,NGLLX-1
+!
+!---- get the global point number
+!
+ iglobnum = ibool(ix,iy,ispec)
+!
+!---- do the same for next point on horizontal line
+!
+ iglobnum2 = ibool(ix+1,iy,ispec)
+
+ write(20,*) coord(1,iglobnum),coord(2,iglobnum)
+ write(20,*) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(20,"('')")
+
+ if(iy == 1 .or. iy == NGLLZ) then
+ write(21,*) coord(1,iglobnum),coord(2,iglobnum)
+ write(21,*) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(21,"('')")
+ endif
+
+ enddo
+ enddo
+
+!
+!---- plot the lines in eta-direction
+!
+ do ix = 1,NGLLX
+ do iy = 1,NGLLZ-1
+!
+!---- get the global point number
+!
+ iglobnum = ibool(ix,iy,ispec)
+!
+!---- do the same for next point on vertical line
+!
+ iglobnum2 = ibool(ix,iy+1,ispec)
+
+ write(20,*) coord(1,iglobnum),coord(2,iglobnum)
+ write(20,*) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(20,"('')")
+
+ if(ix == 1 .or. ix == NGLLX) then
+ write(21,*) coord(1,iglobnum),coord(2,iglobnum)
+ write(21,*) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(21,"('')")
+ endif
+
+ enddo
+ enddo
+ enddo
+
+!
+!---- plot the macrobloc mesh using Gnuplot
+!
+ do ibloc = 1,nspec
+ do inode = 1,ngnod
+
+ xval(inode) = coorg(1,knods(inode,ibloc))
+ zval(inode) = coorg(2,knods(inode,ibloc))
+
+ enddo
+
+ if(ngnod == 4) then
+!
+!---- 4-node rectangular element
+!
+
+! draw the edges of the element using one color
+ write(30,*) xval(1),zval(1)
+ write(30,*) xval(2),zval(2)
+ write(30,"('')")
+ write(30,*) xval(2),zval(2)
+ write(30,*) xval(3),zval(3)
+ write(30,"('')")
+ write(30,*) xval(3),zval(3)
+ write(30,*) xval(4),zval(4)
+ write(30,"('')")
+ write(30,*) xval(4),zval(4)
+ write(30,*) xval(1),zval(1)
+ write(30,"('')")
+
+ else
+
+!
+!---- 9-node rectangular element
+!
+
+! draw the edges of the element using one color
+ write(30,*) xval(1),zval(1)
+ write(30,*) xval(5),zval(5)
+ write(30,"('')")
+ write(30,*) xval(5),zval(5)
+ write(30,*) xval(2),zval(2)
+ write(30,"('')")
+ write(30,*) xval(2),zval(2)
+ write(30,*) xval(6),zval(6)
+ write(30,"('')")
+ write(30,*) xval(6),zval(6)
+ write(30,*) xval(3),zval(3)
+ write(30,"('')")
+ write(30,*) xval(3),zval(3)
+ write(30,*) xval(7),zval(7)
+ write(30,"('')")
+ write(30,*) xval(7),zval(7)
+ write(30,*) xval(4),zval(4)
+ write(30,"('')")
+ write(30,*) xval(4),zval(4)
+ write(30,*) xval(8),zval(8)
+ write(30,"('')")
+ write(30,*) xval(8),zval(8)
+ write(30,*) xval(1),zval(1)
+ write(30,"('')")
+
+! draw middle lines using another color
+ write(31,*) xval(5),zval(5)
+ write(31,*) xval(9),zval(9)
+ write(31,"('')")
+ write(31,*) xval(9),zval(9)
+ write(31,*) xval(7),zval(7)
+ write(31,"('')")
+ write(31,*) xval(8),zval(8)
+ write(31,*) xval(9),zval(9)
+ write(31,"('')")
+ write(31,*) xval(9),zval(9)
+ write(31,*) xval(6),zval(6)
+ write(31,"('')")
+
+ endif
+
+ enddo
+
+ close(20)
+ close(21)
+
+ close(30)
+ close(31)
+
+!
+!---- generate the command file for Gnuplot
+!
+ open(unit=20,file='plotall_gll_mesh.gnu',status='unknown')
+ write(20,*) 'set term x11'
+ write(20,*) '# set term postscript landscape color solid "Helvetica" 22'
+ write(20,*) '# set output "gll_mesh.ps"'
+ write(20,*) 'set xlabel "X"'
+ write(20,*) 'set ylabel "Y"'
+ write(20,*) 'set title "Gauss-Lobatto-Legendre Mesh"'
+ write(20,*) 'plot "gllmesh1.gnu" title '''' w l 2, "gllmesh2.gnu" title '''' w linesp 1 3'
+ write(20,*) 'pause -1 "Hit any key to exit..."'
+ close(20)
+
+ open(unit=20,file='plotall_macro_mesh.gnu',status='unknown')
+ write(20,*) 'set term x11'
+ write(20,*) '# set term postscript landscape color solid "Helvetica" 22'
+ write(20,*) '# set output "macro_mesh.ps"'
+ write(20,*) 'set xlabel "X"'
+ write(20,*) 'set ylabel "Y"'
+ write(20,*) 'set title "Spectral Element (Macrobloc) Mesh"'
+ write(20,*) 'plot "macros2.gnu" title '''' w l 2, "macros1.gnu" title '''' w linesp 1 3'
+ write(20,*) 'pause -1 "Hit any key to exit..."'
+ close(20)
+
+ end subroutine plotgll
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/plotpost.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/plotpost.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/plotpost.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/plotpost.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,3070 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ 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, &
+ simulation_title,npoin,npgeo,vpmin,vpmax,nrec,NSOURCES, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
+ 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)
+
+!
+! PostScript display routine
+!
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+! color palette
+ integer, parameter :: NUM_COLORS = 236
+ double precision, dimension(NUM_COLORS) :: red,green,blue
+
+ integer it,nrec,nelemabs,numat,pointsdisp,pointsdisp_loop,nspec
+ integer i,npoin,npgeo,ngnod,NSOURCES
+
+ integer kmato(nspec),knods(ngnod,nspec)
+ integer ibool(NGLLX,NGLLZ,nspec)
+
+ double precision xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
+ double precision shapeint(ngnod,pointsdisp,pointsdisp)
+ double precision Uxinterp(pointsdisp,pointsdisp)
+ double precision Uzinterp(pointsdisp,pointsdisp)
+ double precision flagrange(NGLLX,pointsdisp)
+ double precision density(2,numat),poroelastcoef(4,3,numat),porosity(numat),tortuosity(numat)
+
+ double precision dt,timeval
+ double precision, dimension(NSOURCES) :: x_source,z_source
+ double precision displ(3,npoin),coord(NDIM,npoin)
+ double precision vpext(NGLLX,NGLLZ,nspec)
+
+ double precision coorg(NDIM,npgeo)
+ double precision, dimension(nrec) :: st_xval,st_zval
+
+ integer numabs(nelemabs),codeabs(4,nelemabs)
+ logical anyabs,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only
+
+! for fluid/solid edge detection
+ 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
+
+! for the file name
+ character(len=100) :: file_name
+
+! to suppress useless white spaces in postscript lines
+ character(len=100) :: postscript_line
+ character(len=1), dimension(100) :: ch1,ch2
+ equivalence (postscript_line,ch1)
+ logical :: first
+
+ double precision convert,x1,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
+ double precision :: kappal_f,rhol_f
+ double precision :: mul_fr,kappal_fr,phil,tortl
+ double precision :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,rhol_bar
+ double precision :: cpIsquare
+
+ integer k,j,ispec,material,is,ir,imat,icol,l,line_length
+ integer index_char,ii,ipoin,in,nnum,inum,ideb,ifin,iedge
+
+ integer colors,numbers,subsamp,imagetype
+ logical interpol,meshvect,modelvect,boundvect,assign_external_model
+ double precision cutsnaps,sizemax_arrows
+
+ double precision ratio_page,dispmax,xmin,zmin
+
+! title of the plot
+ character(len=60) simulation_title
+
+! for free surface output
+ integer :: nelem_acoustic_surface
+ integer, dimension(4,max(1,nelem_acoustic_surface)) :: acoustic_edges
+
+#ifdef USE_MPI
+ double precision :: xmin_glob, xmax_glob, zmin_glob, zmax_glob
+ double precision :: dispmax_glob
+#endif
+
+ double precision, dimension(:,:), allocatable :: coorg_send
+ double precision, dimension(:,:), allocatable :: coorg_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, coupled_acoustic_poro_glob, &
+ coupled_elastic_poro_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
+! 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)
+#endif
+
+! A4 or US letter paper
+ if(US_LETTER) then
+ usoffset = 1.75d0
+ sizex = 27.94d0
+ sizez = 21.59d0
+ else
+ usoffset = 0.d0
+ sizex = 29.7d0
+ sizez = 21.d0
+ endif
+
+! height of domain numbers in centimeters
+ height = 0.25d0
+
+! define color palette in random order
+
+! red
+ red(1) = 1.00000000000000
+ green(1) = 0.000000000000000E+000
+ blue(1) = 0.000000000000000E+000
+
+! DodgerBlue2
+ red(2) = 0.109803921568627
+ green(2) = 0.525490196078431
+ blue(2) = 0.933333333333333
+
+! gold
+ red(3) = 1.00000000000000
+ green(3) = 0.840000000000000
+ blue(3) = 0.000000000000000E+000
+
+! springgreen
+ red(4) = 0.000000000000000E+000
+ green(4) = 1.00000000000000
+ blue(4) = 0.500000000000000
+
+! NavajoWhite
+ red(5) = 1.00000000000000
+ green(5) = 0.870588235294118
+ blue(5) = 0.678431372549020
+
+! SteelBlue3
+ red(6) = 0.309803921568627
+ green(6) = 0.580392156862745
+ blue(6) = 0.803921568627451
+
+! Ivory3
+ red(7) = 0.803921568627451
+ green(7) = 0.803921568627451
+ blue(7) = 0.756862745098039
+
+! SkyBlue4
+ red(8) = 0.290196078431373
+ green(8) = 0.439215686274510
+ blue(8) = 0.545098039215686
+
+! Snow
+ red(9) = 0.980392156862745
+ green(9) = 0.980392156862745
+ blue(9) = 0.980392156862745
+
+! SteelBlue
+ red(10) = 0.274509803921569
+ green(10) = 0.509803921568627
+ blue(10) = 0.705882352941177
+
+! Bisque3
+ red(11) = 0.803921568627451
+ green(11) = 0.717647058823529
+ blue(11) = 0.619607843137255
+
+! Salmon
+ red(12) = 0.980392156862745
+ green(12) = 0.501960784313725
+ blue(12) = 0.447058823529412
+
+! SlateBlue2
+ red(13) = 0.478431372549020
+ green(13) = 0.403921568627451
+ blue(13) = 0.933333333333333
+
+! NavajoWhite2
+ red(14) = 0.933333333333333
+ green(14) = 0.811764705882353
+ blue(14) = 0.631372549019608
+
+! MediumBlue
+ red(15) = 0.000000000000000E+000
+ green(15) = 0.000000000000000E+000
+ blue(15) = 0.803921568627451
+
+! LightCoral
+ red(16) = 0.941176470588235
+ green(16) = 0.501960784313725
+ blue(16) = 0.501960784313725
+
+! FloralWhite
+ red(17) = 1.00000000000000
+ green(17) = 0.980392156862745
+ blue(17) = 0.941176470588235
+
+! Cornsilk3
+ red(18) = 0.803921568627451
+ green(18) = 0.784313725490196
+ blue(18) = 0.694117647058824
+
+! GhostWhite
+ red(19) = 0.972549019607843
+ green(19) = 0.972549019607843
+ blue(19) = 1.00000000000000
+
+! blue
+ red(20) = 0.000000000000000E+000
+ green(20) = 0.000000000000000E+000
+ blue(20) = 1.00000000000000
+
+! Linen
+ red(21) = 0.980392156862745
+ green(21) = 0.941176470588235
+ blue(21) = 0.901960784313726
+
+! peachpuff
+ red(22) = 1.00000000000000
+ green(22) = 0.850000000000000
+ blue(22) = 0.730000000000000
+
+! Cornsilk1
+ red(23) = 1.00000000000000
+ green(23) = 0.972549019607843
+ blue(23) = 0.862745098039216
+
+! LightSalmon
+ red(24) = 1.00000000000000
+ green(24) = 0.627450980392157
+ blue(24) = 0.478431372549020
+
+! DeepSkyBlue1
+ red(25) = 0.000000000000000E+000
+ green(25) = 0.749019607843137
+ blue(25) = 1.00000000000000
+
+! LemonChiffon4
+ red(26) = 0.545098039215686
+ green(26) = 0.537254901960784
+ blue(26) = 0.439215686274510
+
+! PeachPuff1
+ red(27) = 1.00000000000000
+ green(27) = 0.854901960784314
+ blue(27) = 0.725490196078431
+
+! BlanchedAlmond
+ red(28) = 1.00000000000000
+ green(28) = 0.921568627450980
+ blue(28) = 0.803921568627451
+
+! SlateBlue3
+ red(29) = 0.411764705882353
+ green(29) = 0.349019607843137
+ blue(29) = 0.803921568627451
+
+! LightSkyBlue1
+ red(30) = 0.690196078431373
+ green(30) = 0.886274509803922
+ blue(30) = 1.00000000000000
+
+! DarkViolet
+ red(31) = 0.580392156862745
+ green(31) = 0.000000000000000E+000
+ blue(31) = 0.827450980392157
+
+! Azure3
+ red(32) = 0.756862745098039
+ green(32) = 0.803921568627451
+ blue(32) = 0.803921568627451
+
+! LavenderBlush3
+ red(33) = 0.803921568627451
+ green(33) = 0.756862745098039
+ blue(33) = 0.772549019607843
+
+! Honeydew1
+ red(34) = 0.941176470588235
+ green(34) = 1.00000000000000
+ blue(34) = 0.941176470588235
+
+! Ivory2
+ red(35) = 0.933333333333333
+ green(35) = 0.933333333333333
+ blue(35) = 0.878431372549020
+
+! RosyBrown
+ red(36) = 0.737254901960784
+ green(36) = 0.560784313725490
+ blue(36) = 0.560784313725490
+
+! Thistle
+ red(37) = 0.847058823529412
+ green(37) = 0.749019607843137
+ blue(37) = 0.847058823529412
+
+! Orange
+ red(38) = 1.00000000000000
+ green(38) = 0.647058823529412
+ blue(38) = 0.000000000000000E+000
+
+! DarkSeaGreen
+ red(39) = 0.560784313725490
+ green(39) = 0.737254901960784
+ blue(39) = 0.560784313725490
+
+! Moccasin
+ red(40) = 1.00000000000000
+ green(40) = 0.894117647058824
+ blue(40) = 0.709803921568627
+
+! DeepSkyBlue2
+ red(41) = 0.000000000000000E+000
+ green(41) = 0.698039215686274
+ blue(41) = 0.933333333333333
+
+! SlateGray4
+ red(42) = 0.423529411764706
+ green(42) = 0.482352941176471
+ blue(42) = 0.545098039215686
+
+! Beige
+ red(43) = 0.960784313725490
+ green(43) = 0.960784313725490
+ blue(43) = 0.862745098039216
+
+! Gold
+ red(44) = 1.00000000000000
+ green(44) = 0.843137254901961
+ blue(44) = 0.000000000000000E+000
+
+! SlateBlue
+ red(45) = 0.415686274509804
+ green(45) = 0.352941176470588
+ blue(45) = 0.803921568627451
+
+! SteelBlue1
+ red(46) = 0.388235294117647
+ green(46) = 0.721568627450980
+ blue(46) = 1.00000000000000
+
+! SaddleBrown
+ red(47) = 0.545098039215686
+ green(47) = 0.270588235294118
+ blue(47) = 7.450980392156863E-002
+
+! Pink
+ red(48) = 1.00000000000000
+ green(48) = 0.752941176470588
+ blue(48) = 0.796078431372549
+
+! Black
+ red(49) = 0.000000000000000E+000
+ green(49) = 0.000000000000000E+000
+ blue(49) = 0.000000000000000E+000
+
+! SlateGrey
+ red(50) = 0.439215686274510
+ green(50) = 0.501960784313725
+ blue(50) = 0.564705882352941
+
+! Ivory
+ red(51) = 1.00000000000000
+ green(51) = 1.00000000000000
+ blue(51) = 0.941176470588235
+
+! OliveDrab
+ red(52) = 0.419607843137255
+ green(52) = 0.556862745098039
+ blue(52) = 0.137254901960784
+
+! Ivory1
+ red(53) = 1.00000000000000
+ green(53) = 1.00000000000000
+ blue(53) = 0.941176470588235
+
+! SkyBlue
+ red(54) = 0.529411764705882
+ green(54) = 0.807843137254902
+ blue(54) = 0.921568627450980
+
+! MistyRose3
+ red(55) = 0.803921568627451
+ green(55) = 0.717647058823529
+ blue(55) = 0.709803921568627
+
+! LimeGreen
+ red(56) = 0.196078431372549
+ green(56) = 0.803921568627451
+ blue(56) = 0.196078431372549
+
+! Purple
+ red(57) = 0.627450980392157
+ green(57) = 0.125490196078431
+ blue(57) = 0.941176470588235
+
+! SkyBlue2
+ red(58) = 0.494117647058824
+ green(58) = 0.752941176470588
+ blue(58) = 0.933333333333333
+
+! Red
+ red(59) = 1.00000000000000
+ green(59) = 0.000000000000000E+000
+ blue(59) = 0.000000000000000E+000
+
+! DarkKhaki
+ red(60) = 0.741176470588235
+ green(60) = 0.717647058823529
+ blue(60) = 0.419607843137255
+
+! MediumTurquoise
+ red(61) = 0.282352941176471
+ green(61) = 0.819607843137255
+ blue(61) = 0.800000000000000
+
+! Grey
+ red(62) = 0.745098039215686
+ green(62) = 0.745098039215686
+ blue(62) = 0.745098039215686
+
+! Coral
+ red(63) = 1.00000000000000
+ green(63) = 0.498039215686275
+ blue(63) = 0.313725490196078
+
+! NavajoWhite4
+ red(64) = 0.545098039215686
+ green(64) = 0.474509803921569
+ blue(64) = 0.368627450980392
+
+! SlateBlue4
+ red(65) = 0.278431372549020
+ green(65) = 0.235294117647059
+ blue(65) = 0.545098039215686
+
+! RoyalBlue4
+ red(66) = 0.152941176470588
+ green(66) = 0.250980392156863
+ blue(66) = 0.545098039215686
+
+! YellowGreen
+ red(67) = 0.603921568627451
+ green(67) = 0.803921568627451
+ blue(67) = 0.196078431372549
+
+! DeepSkyBlue3
+ red(68) = 0.000000000000000E+000
+ green(68) = 0.603921568627451
+ blue(68) = 0.803921568627451
+
+! goldenrod
+ red(69) = 0.854901960784314
+ green(69) = 0.647058823529412
+ blue(69) = 0.125490196078431
+
+! AntiqueWhite4
+ red(70) = 0.545098039215686
+ green(70) = 0.513725490196078
+ blue(70) = 0.470588235294118
+
+! lemonchiffon
+ red(71) = 1.00000000000000
+ green(71) = 0.980000000000000
+ blue(71) = 0.800000000000000
+
+! GreenYellow
+ red(72) = 0.678431372549020
+ green(72) = 1.00000000000000
+ blue(72) = 0.184313725490196
+
+! LightSlateGray
+ red(73) = 0.466666666666667
+ green(73) = 0.533333333333333
+ blue(73) = 0.600000000000000
+
+! RoyalBlue
+ red(74) = 0.254901960784314
+ green(74) = 0.411764705882353
+ blue(74) = 0.882352941176471
+
+! DarkGreen
+ red(75) = 0.000000000000000E+000
+ green(75) = 0.392156862745098
+ blue(75) = 0.000000000000000E+000
+
+! NavajoWhite3
+ red(76) = 0.803921568627451
+ green(76) = 0.701960784313725
+ blue(76) = 0.545098039215686
+
+! Azure1
+ red(77) = 0.941176470588235
+ green(77) = 1.00000000000000
+ blue(77) = 1.00000000000000
+
+! PowderBlue
+ red(78) = 0.690196078431373
+ green(78) = 0.878431372549020
+ blue(78) = 0.901960784313726
+
+! slateblue
+ red(79) = 0.420000000000000
+ green(79) = 0.350000000000000
+ blue(79) = 0.800000000000000
+
+! MediumOrchid
+ red(80) = 0.729411764705882
+ green(80) = 0.333333333333333
+ blue(80) = 0.827450980392157
+
+! turquoise
+ red(81) = 0.250000000000000
+ green(81) = 0.880000000000000
+ blue(81) = 0.820000000000000
+
+! Snow1
+ red(82) = 1.00000000000000
+ green(82) = 0.980392156862745
+ blue(82) = 0.980392156862745
+
+! violet
+ red(83) = 0.930000000000000
+ green(83) = 0.510000000000000
+ blue(83) = 0.930000000000000
+
+! DeepPink
+ red(84) = 1.00000000000000
+ green(84) = 7.843137254901961E-002
+ blue(84) = 0.576470588235294
+
+! MistyRose4
+ red(85) = 0.545098039215686
+ green(85) = 0.490196078431373
+ blue(85) = 0.482352941176471
+
+! PeachPuff3
+ red(86) = 0.803921568627451
+ green(86) = 0.686274509803922
+ blue(86) = 0.584313725490196
+
+! MediumSeaGreen
+ red(87) = 0.235294117647059
+ green(87) = 0.701960784313725
+ blue(87) = 0.443137254901961
+
+! Honeydew4
+ red(88) = 0.513725490196078
+ green(88) = 0.545098039215686
+ blue(88) = 0.513725490196078
+
+! Tan
+ red(89) = 0.823529411764706
+ green(89) = 0.705882352941177
+ blue(89) = 0.549019607843137
+
+! DarkGoldenrod
+ red(90) = 0.721568627450980
+ green(90) = 0.525490196078431
+ blue(90) = 4.313725490196078E-002
+
+! Blue2
+ red(91) = 0.000000000000000E+000
+ green(91) = 0.000000000000000E+000
+ blue(91) = 0.933333333333333
+
+! Maroon
+ red(92) = 0.690196078431373
+ green(92) = 0.188235294117647
+ blue(92) = 0.376470588235294
+
+! LightSkyBlue3
+ red(93) = 0.552941176470588
+ green(93) = 0.713725490196078
+ blue(93) = 0.803921568627451
+
+! LemonChiffon2
+ red(94) = 0.933333333333333
+ green(94) = 0.913725490196078
+ blue(94) = 0.749019607843137
+
+! Snow3
+ red(95) = 0.803921568627451
+ green(95) = 0.788235294117647
+ blue(95) = 0.788235294117647
+
+! Ivory4
+ red(96) = 0.545098039215686
+ green(96) = 0.545098039215686
+ blue(96) = 0.513725490196078
+
+! AntiqueWhite3
+ red(97) = 0.803921568627451
+ green(97) = 0.752941176470588
+ blue(97) = 0.690196078431373
+
+! Bisque4
+ red(98) = 0.545098039215686
+ green(98) = 0.490196078431373
+ blue(98) = 0.419607843137255
+
+! Snow2
+ red(99) = 0.933333333333333
+ green(99) = 0.913725490196078
+ blue(99) = 0.913725490196078
+
+! SlateGray1
+ red(100) = 0.776470588235294
+ green(100) = 0.886274509803922
+ blue(100) = 1.00000000000000
+
+! Seashell2
+ red(101) = 0.933333333333333
+ green(101) = 0.898039215686275
+ blue(101) = 0.870588235294118
+
+! Aquamarine
+ red(102) = 0.498039215686275
+ green(102) = 1.00000000000000
+ blue(102) = 0.831372549019608
+
+! SlateGray2
+ red(103) = 0.725490196078431
+ green(103) = 0.827450980392157
+ blue(103) = 0.933333333333333
+
+! White
+ red(104) = 1.00000000000000
+ green(104) = 1.00000000000000
+ blue(104) = 1.00000000000000
+
+! LavenderBlush
+ red(105) = 1.00000000000000
+ green(105) = 0.941176470588235
+ blue(105) = 0.960784313725490
+
+! DodgerBlue3
+ red(106) = 9.411764705882353E-002
+ green(106) = 0.454901960784314
+ blue(106) = 0.803921568627451
+
+! RoyalBlue3
+ red(107) = 0.227450980392157
+ green(107) = 0.372549019607843
+ blue(107) = 0.803921568627451
+
+! LightYellow
+ red(108) = 1.00000000000000
+ green(108) = 1.00000000000000
+ blue(108) = 0.878431372549020
+
+! DeepSkyBlue
+ red(109) = 0.000000000000000E+000
+ green(109) = 0.749019607843137
+ blue(109) = 1.00000000000000
+
+! AntiqueWhite2
+ red(110) = 0.933333333333333
+ green(110) = 0.874509803921569
+ blue(110) = 0.800000000000000
+
+! CornflowerBlue
+ red(111) = 0.392156862745098
+ green(111) = 0.584313725490196
+ blue(111) = 0.929411764705882
+
+! PeachPuff4
+ red(112) = 0.545098039215686
+ green(112) = 0.466666666666667
+ blue(112) = 0.396078431372549
+
+! SpringGreen
+ red(113) = 0.000000000000000E+000
+ green(113) = 1.00000000000000
+ blue(113) = 0.498039215686275
+
+! Honeydew
+ red(114) = 0.941176470588235
+ green(114) = 1.00000000000000
+ blue(114) = 0.941176470588235
+
+! Honeydew2
+ red(115) = 0.878431372549020
+ green(115) = 0.933333333333333
+ blue(115) = 0.878431372549020
+
+! LightSeaGreen
+ red(116) = 0.125490196078431
+ green(116) = 0.698039215686274
+ blue(116) = 0.666666666666667
+
+! NavyBlue
+ red(117) = 0.000000000000000E+000
+ green(117) = 0.000000000000000E+000
+ blue(117) = 0.501960784313725
+
+! Azure4
+ red(118) = 0.513725490196078
+ green(118) = 0.545098039215686
+ blue(118) = 0.545098039215686
+
+! MediumAquamarine
+ red(119) = 0.400000000000000
+ green(119) = 0.803921568627451
+ blue(119) = 0.666666666666667
+
+! SkyBlue3
+ red(120) = 0.423529411764706
+ green(120) = 0.650980392156863
+ blue(120) = 0.803921568627451
+
+! LavenderBlush2
+ red(121) = 0.933333333333333
+ green(121) = 0.878431372549020
+ blue(121) = 0.898039215686275
+
+! Bisque1
+ red(122) = 1.00000000000000
+ green(122) = 0.894117647058824
+ blue(122) = 0.768627450980392
+
+! DarkOrange
+ red(123) = 1.00000000000000
+ green(123) = 0.549019607843137
+ blue(123) = 0.000000000000000E+000
+
+! LightSteelBlue
+ red(124) = 0.690196078431373
+ green(124) = 0.768627450980392
+ blue(124) = 0.870588235294118
+
+! SteelBlue2
+ red(125) = 0.360784313725490
+ green(125) = 0.674509803921569
+ blue(125) = 0.933333333333333
+
+! LemonChiffon3
+ red(126) = 0.803921568627451
+ green(126) = 0.788235294117647
+ blue(126) = 0.647058823529412
+
+! DarkSlateBlue
+ red(127) = 0.282352941176471
+ green(127) = 0.239215686274510
+ blue(127) = 0.545098039215686
+
+! Seashell
+ red(128) = 1.00000000000000
+ green(128) = 0.960784313725490
+ blue(128) = 0.933333333333333
+
+! Firebrick
+ red(129) = 0.698039215686274
+ green(129) = 0.133333333333333
+ blue(129) = 0.133333333333333
+
+! LightGray
+ red(130) = 0.827450980392157
+ green(130) = 0.827450980392157
+ blue(130) = 0.827450980392157
+
+! Blue
+ red(131) = 0.000000000000000E+000
+ green(131) = 0.000000000000000E+000
+ blue(131) = 1.00000000000000
+
+! Bisque2
+ red(132) = 0.933333333333333
+ green(132) = 0.835294117647059
+ blue(132) = 0.717647058823529
+
+! WhiteSmoke
+ red(133) = 0.960784313725490
+ green(133) = 0.960784313725490
+ blue(133) = 0.960784313725490
+
+! SeaGreen
+ red(134) = 0.180392156862745
+ green(134) = 0.545098039215686
+ blue(134) = 0.341176470588235
+
+! Burlywood
+ red(135) = 0.870588235294118
+ green(135) = 0.721568627450980
+ blue(135) = 0.529411764705882
+
+! RoyalBlue2
+ red(136) = 0.262745098039216
+ green(136) = 0.431372549019608
+ blue(136) = 0.933333333333333
+
+! RoyalBlue1
+ red(137) = 0.282352941176471
+ green(137) = 0.462745098039216
+ blue(137) = 1.00000000000000
+
+! SteelBlue4
+ red(138) = 0.211764705882353
+ green(138) = 0.392156862745098
+ blue(138) = 0.545098039215686
+
+! AliceBlue
+ red(139) = 0.941176470588235
+ green(139) = 0.972549019607843
+ blue(139) = 1.00000000000000
+
+! LightSlateBlue
+ red(140) = 0.517647058823529
+ green(140) = 0.439215686274510
+ blue(140) = 1.00000000000000
+
+! MistyRose1
+ red(141) = 1.00000000000000
+ green(141) = 0.894117647058824
+ blue(141) = 0.882352941176471
+
+! SandyBrown
+ red(142) = 0.956862745098039
+ green(142) = 0.643137254901961
+ blue(142) = 0.376470588235294
+
+! DarkOliveGreen
+ red(143) = 0.333333333333333
+ green(143) = 0.419607843137255
+ blue(143) = 0.184313725490196
+
+! Yellow
+ red(144) = 1.00000000000000
+ green(144) = 1.00000000000000
+ blue(144) = 0.000000000000000E+000
+
+! SlateGray3
+ red(145) = 0.623529411764706
+ green(145) = 0.713725490196078
+ blue(145) = 0.803921568627451
+
+! HotPink
+ red(146) = 1.00000000000000
+ green(146) = 0.411764705882353
+ blue(146) = 0.705882352941177
+
+! Violet
+ red(147) = 0.933333333333333
+ green(147) = 0.509803921568627
+ blue(147) = 0.933333333333333
+
+! LightSkyBlue
+ red(148) = 0.529411764705882
+ green(148) = 0.807843137254902
+ blue(148) = 0.980392156862745
+
+! Cornsilk2
+ red(149) = 0.933333333333333
+ green(149) = 0.909803921568627
+ blue(149) = 0.803921568627451
+
+! MidnightBlue
+ red(150) = 9.803921568627451E-002
+ green(150) = 9.803921568627451E-002
+ blue(150) = 0.439215686274510
+
+! AntiqueWhite
+ red(151) = 0.980392156862745
+ green(151) = 0.921568627450980
+ blue(151) = 0.843137254901961
+
+! PaleGreen
+ red(152) = 0.596078431372549
+ green(152) = 0.984313725490196
+ blue(152) = 0.596078431372549
+
+! MedSpringGreen
+ red(153) = 0.000000000000000E+000
+ green(153) = 0.980392156862745
+ blue(153) = 0.603921568627451
+
+! DodgerBlue1
+ red(154) = 0.117647058823529
+ green(154) = 0.564705882352941
+ blue(154) = 1.00000000000000
+
+! Blue3
+ red(155) = 0.000000000000000E+000
+ green(155) = 0.000000000000000E+000
+ blue(155) = 0.803921568627451
+
+! Cyan
+ red(156) = 0.000000000000000E+000
+ green(156) = 1.00000000000000
+ blue(156) = 1.00000000000000
+
+! LemonChiffon
+ red(157) = 1.00000000000000
+ green(157) = 0.980392156862745
+ blue(157) = 0.803921568627451
+
+! mediumorchid
+ red(158) = 0.730000000000000
+ green(158) = 0.330000000000000
+ blue(158) = 0.830000000000000
+
+! Turquoise
+ red(159) = 0.250980392156863
+ green(159) = 0.878431372549020
+ blue(159) = 0.815686274509804
+
+! IndianRed
+ red(160) = 0.803921568627451
+ green(160) = 0.360784313725490
+ blue(160) = 0.360784313725490
+
+! DodgerBlue
+ red(161) = 0.117647058823529
+ green(161) = 0.564705882352941
+ blue(161) = 1.00000000000000
+
+! Seashell3
+ red(162) = 0.803921568627451
+ green(162) = 0.772549019607843
+ blue(162) = 0.749019607843137
+
+! BlueViolet
+ red(163) = 0.541176470588235
+ green(163) = 0.168627450980392
+ blue(163) = 0.886274509803922
+
+! DeepSkyBlue4
+ red(164) = 0.000000000000000E+000
+ green(164) = 0.407843137254902
+ blue(164) = 0.545098039215686
+
+! PaleVioletRed
+ red(165) = 0.858823529411765
+ green(165) = 0.439215686274510
+ blue(165) = 0.576470588235294
+
+! Azure2
+ red(166) = 0.878431372549020
+ green(166) = 0.933333333333333
+ blue(166) = 0.933333333333333
+
+! greenyellow
+ red(167) = 0.680000000000000
+ green(167) = 1.00000000000000
+ blue(167) = 0.180000000000000
+
+! LightGoldenrod
+ red(168) = 0.933333333333333
+ green(168) = 0.866666666666667
+ blue(168) = 0.509803921568627
+
+! MistyRose
+ red(169) = 1.00000000000000
+ green(169) = 0.894117647058824
+ blue(169) = 0.882352941176471
+
+! LightSkyBlue4
+ red(170) = 0.376470588235294
+ green(170) = 0.482352941176471
+ blue(170) = 0.545098039215686
+
+! OrangeRed
+ red(171) = 1.00000000000000
+ green(171) = 0.270588235294118
+ blue(171) = 0.000000000000000E+000
+
+! DimGrey
+ red(172) = 0.411764705882353
+ green(172) = 0.411764705882353
+ blue(172) = 0.411764705882353
+
+! MediumVioletRed
+ red(173) = 0.780392156862745
+ green(173) = 8.235294117647059E-002
+ blue(173) = 0.521568627450980
+
+! DarkSlateGray
+ red(174) = 0.184313725490196
+ green(174) = 0.309803921568627
+ blue(174) = 0.309803921568627
+
+! yellow
+ red(175) = 1.00000000000000
+ green(175) = 1.00000000000000
+ blue(175) = 0.000000000000000E+000
+
+! Plum
+ red(176) = 0.866666666666667
+ green(176) = 0.627450980392157
+ blue(176) = 0.866666666666667
+
+! DarkTurquoise
+ red(177) = 0.000000000000000E+000
+ green(177) = 0.807843137254902
+ blue(177) = 0.819607843137255
+
+! DodgerBlue4
+ red(178) = 6.274509803921569E-002
+ green(178) = 0.305882352941176
+ blue(178) = 0.545098039215686
+
+! Cornsilk
+ red(179) = 1.00000000000000
+ green(179) = 0.972549019607843
+ blue(179) = 0.862745098039216
+
+! SkyBlue1
+ red(180) = 0.529411764705882
+ green(180) = 0.807843137254902
+ blue(180) = 1.00000000000000
+
+! Seashell1
+ red(181) = 1.00000000000000
+ green(181) = 0.960784313725490
+ blue(181) = 0.933333333333333
+
+! lavender
+ red(182) = 0.901960784313726
+ green(182) = 0.901960784313726
+ blue(182) = 0.980392156862745
+
+! Snow4
+ red(183) = 0.545098039215686
+ green(183) = 0.537254901960784
+ blue(183) = 0.537254901960784
+
+! Peru
+ red(184) = 0.803921568627451
+ green(184) = 0.521568627450980
+ blue(184) = 0.247058823529412
+
+! PeachPuff
+ red(185) = 1.00000000000000
+ green(185) = 0.854901960784314
+ blue(185) = 0.725490196078431
+
+! Green
+ red(186) = 0.000000000000000E+000
+ green(186) = 1.00000000000000
+ blue(186) = 0.000000000000000E+000
+
+! Blue1
+ red(187) = 0.000000000000000E+000
+ green(187) = 0.000000000000000E+000
+ blue(187) = 1.00000000000000
+
+! Seashell4
+ red(188) = 0.545098039215686
+ green(188) = 0.525490196078431
+ blue(188) = 0.509803921568627
+
+! dodgerblue
+ red(189) = 0.120000000000000
+ green(189) = 0.560000000000000
+ blue(189) = 1.00000000000000
+
+! MistyRose2
+ red(190) = 0.933333333333333
+ green(190) = 0.835294117647059
+ blue(190) = 0.823529411764706
+
+! Tomato
+ red(191) = 1.00000000000000
+ green(191) = 0.388235294117647
+ blue(191) = 0.278431372549020
+
+! Wheat
+ red(192) = 0.960784313725490
+ green(192) = 0.870588235294118
+ blue(192) = 0.701960784313725
+
+! LightBlue
+ red(193) = 0.678431372549020
+ green(193) = 0.847058823529412
+ blue(193) = 0.901960784313726
+
+! Chocolate
+ red(194) = 0.823529411764706
+ green(194) = 0.411764705882353
+ blue(194) = 0.117647058823529
+
+! Blue4
+ red(195) = 0.000000000000000E+000
+ green(195) = 0.000000000000000E+000
+ blue(195) = 0.545098039215686
+
+! LavenderBlush1
+ red(196) = 1.00000000000000
+ green(196) = 0.941176470588235
+ blue(196) = 0.960784313725490
+
+! Magenta
+ red(197) = 1.00000000000000
+ green(197) = 0.000000000000000E+000
+ blue(197) = 1.00000000000000
+
+! darkturquoise
+ red(198) = 0.000000000000000E+000
+ green(198) = 0.810000000000000
+ blue(198) = 0.820000000000000
+
+! blueviolet
+ red(199) = 0.540000000000000
+ green(199) = 0.170000000000000
+ blue(199) = 0.890000000000000
+
+! MintCream
+ red(200) = 0.960784313725490
+ green(200) = 1.00000000000000
+ blue(200) = 0.980392156862745
+
+! PaleGoldenrod
+ red(201) = 0.933333333333333
+ green(201) = 0.909803921568627
+ blue(201) = 0.666666666666667
+
+! MediumPurple
+ red(202) = 0.576470588235294
+ green(202) = 0.439215686274510
+ blue(202) = 0.858823529411765
+
+! PapayaWhip
+ red(203) = 1.00000000000000
+ green(203) = 0.937254901960784
+ blue(203) = 0.835294117647059
+
+! LavenderBlush4
+ red(204) = 0.545098039215686
+ green(204) = 0.513725490196078
+ blue(204) = 0.525490196078431
+
+! Cornsilk4
+ red(205) = 0.545098039215686
+ green(205) = 0.533333333333333
+ blue(205) = 0.470588235294118
+
+! LtGoldenrodYello
+ red(206) = 0.980392156862745
+ green(206) = 0.980392156862745
+ blue(206) = 0.823529411764706
+
+! limegreen
+ red(207) = 0.200000000000000
+ green(207) = 0.800000000000000
+ blue(207) = 0.200000000000000
+
+! LemonChiffon1
+ red(208) = 1.00000000000000
+ green(208) = 0.980392156862745
+ blue(208) = 0.803921568627451
+
+! DarkOrchid
+ red(209) = 0.600000000000000
+ green(209) = 0.196078431372549
+ blue(209) = 0.800000000000000
+
+! SlateBlue1
+ red(210) = 0.513725490196078
+ green(210) = 0.435294117647059
+ blue(210) = 1.00000000000000
+
+! chartreuse
+ red(211) = 0.500000000000000
+ green(211) = 1.00000000000000
+ blue(211) = 0.000000000000000E+000
+
+! PaleTurquoise
+ red(212) = 0.686274509803922
+ green(212) = 0.933333333333333
+ blue(212) = 0.933333333333333
+
+! NavajoWhite1
+ red(213) = 1.00000000000000
+ green(213) = 0.870588235294118
+ blue(213) = 0.678431372549020
+
+! LightSkyBlue2
+ red(214) = 0.643137254901961
+ green(214) = 0.827450980392157
+ blue(214) = 0.933333333333333
+
+! VioletRed
+ red(215) = 0.815686274509804
+ green(215) = 0.125490196078431
+ blue(215) = 0.564705882352941
+
+! mocassin
+ red(216) = 1.00000000000000
+ green(216) = 0.890000000000000
+ blue(216) = 0.710000000000000
+
+! OldLace
+ red(217) = 0.992156862745098
+ green(217) = 0.960784313725490
+ blue(217) = 0.901960784313726
+
+! deeppink
+ red(218) = 1.00000000000000
+ green(218) = 8.000000000000000E-002
+ blue(218) = 0.580000000000000
+
+! Honeydew3
+ red(219) = 0.756862745098039
+ green(219) = 0.803921568627451
+ blue(219) = 0.756862745098039
+
+! Gainsboro
+ red(220) = 0.862745098039216
+ green(220) = 0.862745098039216
+ blue(220) = 0.862745098039216
+
+! DarkSalmon
+ red(221) = 0.913725490196078
+ green(221) = 0.588235294117647
+ blue(221) = 0.478431372549020
+
+! AntiqueWhite1
+ red(222) = 1.00000000000000
+ green(222) = 0.937254901960784
+ blue(222) = 0.858823529411765
+
+! LightCyan
+ red(223) = 0.878431372549020
+ green(223) = 1.00000000000000
+ blue(223) = 1.00000000000000
+
+! ForestGreen
+ red(224) = 0.133333333333333
+ green(224) = 0.545098039215686
+ blue(224) = 0.133333333333333
+
+! Orchid
+ red(225) = 0.854901960784314
+ green(225) = 0.439215686274510
+ blue(225) = 0.839215686274510
+
+! PeachPuff2
+ red(226) = 0.933333333333333
+ green(226) = 0.796078431372549
+ blue(226) = 0.678431372549020
+
+! LightPink
+ red(227) = 1.00000000000000
+ green(227) = 0.713725490196078
+ blue(227) = 0.756862745098039
+
+! Sienna
+ red(228) = 0.627450980392157
+ green(228) = 0.321568627450980
+ blue(228) = 0.176470588235294
+
+! darkorchid
+ red(229) = 0.600000000000000
+ green(229) = 0.200000000000000
+ blue(229) = 0.800000000000000
+
+! MediumSlateBlue
+ red(230) = 0.482352941176471
+ green(230) = 0.407843137254902
+ blue(230) = 0.933333333333333
+
+! CadetBlue
+ red(231) = 0.372549019607843
+ green(231) = 0.619607843137255
+ blue(231) = 0.627450980392157
+
+! LawnGreen
+ red(232) = 0.486274509803922
+ green(232) = 0.988235294117647
+ blue(232) = 0.000000000000000E+000
+
+! Chartreuse
+ red(233) = 0.498039215686275
+ green(233) = 1.00000000000000
+ blue(233) = 0.000000000000000E+000
+
+! Brown
+ red(234) = 0.647058823529412
+ green(234) = 0.164705882352941
+ blue(234) = 0.164705882352941
+
+! Azure
+ red(235) = 0.941176470588235
+ green(235) = 1.00000000000000
+ blue(235) = 1.00000000000000
+
+! Bisque
+ red(236) = 1.00000000000000
+ green(236) = 0.894117647058824
+ blue(236) = 0.768627450980392
+
+! get minimum and maximum values of mesh coordinates
+ xmin = minval(coord(1,:))
+ zmin = minval(coord(2,:))
+ xmax = maxval(coord(1,:))
+ zmax = maxval(coord(2,:))
+
+#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
+
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'X min, max = ',xmin,xmax
+ write(IOUT,*) 'Z min, max = ',zmin,zmax
+ endif
+
+! ratio of physical page size/size of the domain meshed
+ ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
+
+! compute the maximum of the norm of the vector
+ dispmax = maxval(sqrt(displ(1,:)**2 + displ(3,:)**2))
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (dispmax, dispmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ dispmax = dispmax_glob
+#endif
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Max norm = ',dispmax
+ endif
+
+!
+!---- open PostScript file
+!
+ if ( myrank == 0 ) then
+ write(file_name,"('OUTPUT_FILES/vect',i7.7,'.ps')") it
+ open(unit=24,file=file_name,status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% gray levels for the velocity model'
+ write(24,*) '/BK {setgray fill} def'
+ write(24,*) '% black and white version'
+ write(24,*) '%/BK {pop 1 setgray fill} def'
+ write(24,*) '%'
+ write(24,*) '% magenta for vectors'
+ write(24,*) '/Colvects {0 setlinewidth 1. 0. 1. RG} def'
+ write(24,*) '% black and white version'
+ write(24,*) '%/Colvects {0 setlinewidth 0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% chartreuse for macrobloc mesh'
+ write(24,*) '/Colmesh {0 setlinewidth 0.5 1. 0. RG} def'
+ write(24,*) '% black and white version'
+ write(24,*) '%/Colmesh {0 setlinewidth 0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% cyan for sources and receivers'
+ write(24,*) '/Colreceiv {0. 1. 1. RG} def'
+ write(24,*) '% black and white version'
+ write(24,*) '%/Colreceiv {0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw an arrow'
+ write(24,*) '/F {MV LR gsave LR ST grestore LR ST} def'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '0 setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '% uncomment this to zoom on parts of the mesh'
+ write(24,*) '% -32 CM -21 CM translate 3. 3. scale'
+ write(24,*) '% -52 CM -24 CM translate 4. 4. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '24. CM 1.2 CM MV'
+ write(24,610) usoffset,it
+ write(24,*) '%'
+
+ write(24,*) '24. CM 1.95 CM MV'
+ timeval = it*dt
+ if(timeval >= 1.d-3 .and. timeval < 1000.d0) then
+ write(24,600) usoffset,timeval
+ else
+ write(24,601) usoffset,timeval
+ endif
+ write(24,*) '%'
+ write(24,*) '24. CM 2.7 CM MV'
+ write(24,640) usoffset,dispmax
+ write(24,*) '%'
+ write(24,*) '24. CM 3.45 CM MV'
+ write(24,620) usoffset,cutsnaps*100.d0
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ if(colors == 1) write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Z axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM scalefont setfont'
+ if(colors == 1) write(24,*) '.8 0 .8 setrgbcolor'
+ 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'
+ if(imagetype == 1) then
+ write(24,*) '(Displacement vector field) show'
+ else if(imagetype == 2) then
+ write(24,*) '(Velocity vector field) show'
+ else if(imagetype == 3) then
+ write(24,*) '(Acceleration vector field) show'
+ else
+ call exit_MPI('Bad field code in PostScript display')
+ endif
+ write(24,*) 'grestore'
+ write(24,*) '25.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,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+
+ if(coupled_acoustic_elastic) then
+ write(24,*) '(Coupled Acoustic/Elastic Wave 2D - SEM) show'
+ else if(coupled_acoustic_poro) then
+ write(24,*) '(Coupled Acoustic/Poroelastic Wave 2D - SEM) show'
+ else if(coupled_elastic_poro) 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
+
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- print the spectral elements mesh in PostScript
+!
+
+ endif
+
+
+ convert = PI / 180.d0
+
+!
+!---- draw the velocity model in background
+!
+ if(modelvect) then
+
+ buffer_offset = 0
+ RGB_offset = 0
+
+ do ispec=1,nspec
+ do i=1,NGLLX-subsamp,subsamp
+ do j=1,NGLLX-subsamp,subsamp
+
+ if((vpmax-vpmin)/vpmin > 0.02d0) then
+ if(assign_external_model) then
+ x1 = (vpext(i,j,ispec)-vpmin) / (vpmax-vpmin)
+ else
+ material = kmato(ispec)
+! get elastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = rhol_bar - phil/tortl*rhol_f
+ bfactor = H_biot + phil*rhol_bar/(tortl*rhol_f)*M_biot - 2.d0*phil/tortl*C_biot
+ cfactor = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIloc = sqrt(cpIsquare)
+ x1 = (cpIloc-vpmin)/(vpmax-vpmin)
+ endif
+ else
+ x1 = 0.5d0
+ endif
+
+! rescale to avoid very dark gray levels
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+! invert scale: white = vpmin, dark gray = vpmax
+ x1 = 1.d0 - x1
+
+ xw = coord(1,ibool(i,j,ispec))
+ zw = coord(2,ibool(i,j,ispec))
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ if ( myrank == 0 ) then
+ write(24,500) xw,zw
+ else
+ buffer_offset = buffer_offset + 1
+ 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))
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ if ( myrank == 0 ) then
+ write(24,499) xw,zw
+ else
+ buffer_offset = buffer_offset + 1
+ 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))
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ if ( myrank == 0 ) then
+ write(24,499) xw,zw
+ else
+ buffer_offset = buffer_offset + 1
+ 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))
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ if ( myrank == 0 ) then
+ write(24,499) xw,zw
+ else
+ buffer_offset = buffer_offset + 1
+ 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_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)
+ 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_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
+ RGB_offset = 0
+ do ispec = 1, nspec_recv
+ do i=1,NGLLX-subsamp,subsamp
+ do j=1,NGLLX-subsamp,subsamp
+ buffer_offset = buffer_offset + 1
+ 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_ps_velocity_model(1,buffer_offset), &
+ coorg_recv_ps_velocity_model(2,buffer_offset)
+ buffer_offset = buffer_offset + 1
+ 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_ps_velocity_model(1,buffer_offset), &
+ coorg_recv_ps_velocity_model(2,buffer_offset)
+ RGB_offset = RGB_offset + 1
+ write(24,604) RGB_recv_ps_velocity_model(1,RGB_offset)
+ enddo
+ enddo
+ enddo
+
+ enddo
+ else
+ call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+ 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_ps_velocity_model(1,1), nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
+ MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
+ endif
+
+
+#endif
+
+
+ endif
+
+!
+!---- draw the spectral element mesh
+!
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ endif
+
+ buffer_offset = 0
+ RGB_offset = 0
+
+ do ispec=1,nspec
+
+ if ( myrank == 0 ) write(24,*) '% elem ',ispec
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ if ( myrank == 0 ) then
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x1
+ coorg_send_ps_element_mesh(2,buffer_offset) = z1
+ endif
+
+ if(ngnod == 4) then
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+
+ else
+
+! draw curved lines if elements have 9 nodes
+ do ir=2,pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+ enddo
+
+ ir=pointsdisp
+ do is=2,pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+ enddo
+
+ is=pointsdisp
+ do ir=pointsdisp-1,1,-1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+ enddo
+
+ ir=1
+ do is=pointsdisp-1,2,-1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ 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'
+ endif
+
+ if(colors == 1) then
+
+! use a different color for each material set
+ imat = kmato(ispec)
+ icol = mod(imat - 1,NUM_COLORS) + 1
+
+ if ( myrank == 0 ) then
+ if(meshvect) then
+ write(24,680) red(icol),green(icol),blue(icol)
+ else
+ write(24,679) red(icol),green(icol),blue(icol)
+ endif
+ else
+ RGB_offset = RGB_offset + 1
+ color_send_ps_element_mesh(RGB_offset) = icol
+ endif
+
+ endif
+
+ if ( myrank == 0 ) then
+ if(meshvect) then
+ if(modelvect) then
+ write(24,*) 'Colmesh ST'
+ else
+ write(24,*) '0 setgray ST'
+ endif
+ endif
+ endif
+
+! write the element number, the group number and the material number inside the element
+ if(numbers == 1) then
+
+ xw = (coorg(1,knods(1,ispec)) + coorg(1,knods(2,ispec)) + coorg(1,knods(3,ispec)) + coorg(1,knods(4,ispec))) / 4.d0
+ zw = (coorg(2,knods(1,ispec)) + coorg(2,knods(2,ispec)) + coorg(2,knods(3,ispec)) + coorg(2,knods(4,ispec))) / 4.d0
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+
+ if ( myrank == 0 ) then
+ if(colors == 1) write(24,*) '1 setgray'
+ endif
+
+ if ( myrank == 0 ) then
+ write(24,500) xw,zw
+ else
+ buffer_offset = buffer_offset + 1
+ 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_ps_element_mesh(RGB_offset) = ispec
+ endif
+
+ endif
+
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
+ nb_coorg_per_elem = 1
+ if ( numbers == 1 ) then
+ nb_coorg_per_elem = nb_coorg_per_elem + 1
+ 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)
+ endif
+ nb_color_per_elem = 0
+ if ( colors == 1 ) then
+ nb_color_per_elem = nb_color_per_elem + 1
+ endif
+ if ( numbers == 1 ) then
+ nb_color_per_elem = nb_color_per_elem + 1
+ endif
+
+ 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_ps_element_mesh(1), nspec_recv*nb_coorg_per_elem, &
+ MPI_INTEGER, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ RGB_offset = 0
+ num_spec = nspec
+ do ispec = 1, nspec_recv
+ num_spec = num_spec + 1
+ write(24,*) '% elem ',num_spec
+ buffer_offset = buffer_offset + 1
+ write(24,*) 'mark'
+ 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_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ buffer_offset = buffer_offset + 1
+ 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_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ buffer_offset = buffer_offset + 1
+ 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_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_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_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_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ enddo
+
+ endif
+
+ write(24,*) 'CO'
+ if ( colors == 1 ) then
+ if(meshvect) then
+ RGB_offset = RGB_offset + 1
+ 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_ps_element_mesh(RGB_offset)),&
+ green(color_recv_ps_element_mesh(RGB_offset)),&
+ blue(color_recv_ps_element_mesh(RGB_offset))
+ endif
+ endif
+ if(meshvect) then
+ if(modelvect) then
+ write(24,*) 'Colmesh ST'
+ else
+ write(24,*) '0 setgray ST'
+ endif
+ endif
+ if(numbers == 1) then
+ if(colors == 1) write(24,*) '1 setgray'
+ buffer_offset = buffer_offset + 1
+ 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_ps_element_mesh(RGB_offset)
+ endif
+
+ enddo
+
+ 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
+ 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)
+ endif
+ nb_color_per_elem = 0
+ if ( colors == 1 ) then
+ nb_color_per_elem = nb_color_per_elem + 1
+ endif
+ if ( numbers == 1 ) then
+ nb_color_per_elem = nb_color_per_elem + 1
+ 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_ps_element_mesh(1), nspec*nb_color_per_elem, &
+ MPI_INTEGER, 0, 43, MPI_COMM_WORLD, ier)
+ endif
+
+ endif
+
+#endif
+
+!
+!--- draw absorbing boundaries with a thick color line
+!
+ anyabs_glob = anyabs
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(anyabs, anyabs_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(anyabs_glob .and. boundvect) then
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% boundary conditions on the mesh'
+ write(24,*) '%'
+
+! use green color
+ write(24,*) '0 1 0 RG'
+
+ write(24,*) '0.02 CM setlinewidth'
+ endif
+
+ buffer_offset = 0
+
+ if ( anyabs ) then
+ do inum = 1,nelemabs
+ ispec = numabs(inum)
+
+ do iedge = 1,4
+
+ if(codeabs(iedge,inum) /= 0) then
+
+ 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 absorbing boundary 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_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
+ 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
+ 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_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_ps_abs(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
+ endif
+
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0 setlinewidth'
+ endif
+
+ endif
+
+!
+!--- draw free surface with a thick color line
+!
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% free surface on the mesh'
+ write(24,*) '%'
+
+! use orange color
+ write(24,*) '1 0.66 0 RG'
+
+ write(24,*) '0.02 CM setlinewidth'
+ endif
+
+ buffer_offset = 0
+
+ if ( nelem_acoustic_surface > 0 ) then
+ do inum = 1,nelem_acoustic_surface
+ ispec = acoustic_edges(1,inum)
+
+ x1 = (coorg(1,acoustic_edges(3,inum))-xmin)*ratio_page + orig_x
+ z1 = (coorg(2,acoustic_edges(3,inum))-zmin)*ratio_page + orig_z
+ x2 = (coorg(1,acoustic_edges(4,inum))-xmin)*ratio_page + orig_x
+ z2 = (coorg(2,acoustic_edges(4,inum))-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_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
+ 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
+ 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_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_ps_free_surface(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
+ endif
+
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0 setlinewidth'
+ endif
+
+!
+!---- draw the fluid-solid coupling edges with a thick color line
+!
+ coupled_acoustic_elastic_glob = coupled_acoustic_elastic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(coupled_acoustic_elastic, coupled_acoustic_elastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(coupled_acoustic_elastic_glob .and. boundvect) then
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% fluid-solid coupling edges in the mesh'
+ write(24,*) '%'
+
+ write(24,*) '0.02 CM setlinewidth'
+ endif
+
+ 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
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec = fluid_solid_acoustic_ispec(inum)
+ iedge = fluid_solid_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
+ 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 setlinewidth'
+ endif
+
+ endif
+
+!
+!---- draw the fluid-porous coupling edges with a thick color line
+!
+ coupled_acoustic_poro_glob = coupled_acoustic_poro
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(coupled_acoustic_poro, coupled_acoustic_poro_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(coupled_acoustic_poro_glob .and. boundvect) then
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% fluid-porous coupling edges in the mesh'
+ write(24,*) '%'
+
+ 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
+ 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 setlinewidth'
+ endif
+
+ endif
+
+!
+!---- draw the solid-porous coupling edges with a thick color line
+!
+ coupled_elastic_poro_glob = coupled_elastic_poro
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(coupled_elastic_poro, coupled_elastic_poro_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(coupled_elastic_poro_glob .and. boundvect) then
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% solid-porous coupling edges in the mesh'
+ write(24,*) '%'
+
+ 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 setlinewidth'
+ endif
+
+ endif
+
+!
+!---- draw the normalized vector field
+!
+
+ if ( myrank == 0 ) then
+! return if the maximum vector equals zero (no source)
+ if(dispmax == 0.d0) then
+ write(IOUT,*) 'null vector: returning!'
+ return
+ endif
+
+ write(24,*) '%'
+ write(24,*) '% vector field'
+ write(24,*) '%'
+
+! color arrows if we draw the velocity model in the background
+ if(modelvect) then
+ write(24,*) 'Colvects'
+ else
+ write(24,*) '0 setgray'
+ endif
+ endif
+
+ if(interpol) then
+
+ 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
+ pointsdisp_loop = 1
+ else
+ pointsdisp_loop = pointsdisp
+ endif
+
+ buffer_offset = 0
+
+ do ispec=1,nspec
+
+! interpolation on a uniform grid
+#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
+
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+
+ Uxinterp(i,j) = 0.d0
+ Uzinterp(i,j) = 0.d0
+
+ do k=1,NGLLX
+ do l=1,NGLLX
+
+ Uxinterp(i,j) = Uxinterp(i,j) + displ(1,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
+ Uzinterp(i,j) = Uzinterp(i,j) + displ(3,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
+
+ enddo
+ enddo
+
+ x1 =(xinterp(i,j)-xmin)*ratio_page
+ z1 =(zinterp(i,j)-zmin)*ratio_page
+
+ x2 = Uxinterp(i,j)*sizemax_arrows/dispmax
+ z2 = Uzinterp(i,j)*sizemax_arrows/dispmax
+
+ d = sqrt(x2**2 + z2**2)
+
+! ignore if vector is too small
+ if(d > cutsnaps*sizemax_arrows) then
+
+ d1 = d * ARROW_RATIO
+ d2 = d1 * cos(ARROW_ANGLE*convert)
+
+ dummy = x2/d
+ if(dummy > 0.9999d0) dummy = 0.9999d0
+ if(dummy < -0.9999d0) dummy = -0.9999d0
+ theta = acos(dummy)
+
+ if(z2 < 0.d0) theta = 360.d0*convert - theta
+ thetaup = theta - ARROW_ANGLE*convert
+ thetadown = theta + ARROW_ANGLE*convert
+
+! draw the vector
+ x1 = (orig_x+x1) * centim
+ z1 = (orig_z+z1) * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ xa = -d2*cos(thetaup)
+ za = -d2*sin(thetaup)
+ xa = xa * centim
+ za = za * centim
+ xb = -d2*cos(thetadown)
+ zb = -d2*sin(thetadown)
+ xb = xb * centim
+ zb = zb * centim
+ if ( myrank == 0 ) then
+ 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)
+
+ line_length = len_trim(postscript_line)
+ index_char = 1
+ first = .false.
+ do ii = 1,line_length-1
+ if(ch1(ii) /= ' ' .or. first) then
+ if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
+ ch2(index_char) = ch1(ii)
+ index_char = index_char + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(index_char) = ch1(line_length)
+ write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
+
+ else
+ buffer_offset = buffer_offset + 1
+ 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
+ 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
+ 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_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)
+
+ line_length = len_trim(postscript_line)
+ index_char = 1
+ first = .false.
+ do ii = 1,line_length-1
+ if(ch1(ii) /= ' ' .or. first) then
+ if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
+ ch2(index_char) = ch1(ii)
+ index_char = index_char + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(index_char) = ch1(line_length)
+ write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
+ 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_ps_vector_field(1,1), 8*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 46, MPI_COMM_WORLD, ier)
+ endif
+
+ endif
+
+#endif
+
+
+! draw the vectors at the nodes of the mesh if we do not interpolate the display on a regular grid
+ else
+
+ buffer_offset = 0
+
+ do ipoin=1,npoin
+
+ x1 =(coord(1,ipoin)-xmin)*ratio_page
+ z1 =(coord(2,ipoin)-zmin)*ratio_page
+
+ x2 = displ(1,ipoin)*sizemax_arrows/dispmax
+ z2 = displ(3,ipoin)*sizemax_arrows/dispmax
+
+ d = sqrt(x2**2 + z2**2)
+
+! ignore if vector is too small
+ if(d > cutsnaps*sizemax_arrows) then
+
+ d1 = d * ARROW_RATIO
+ d2 = d1 * cos(ARROW_ANGLE*convert)
+
+ dummy = x2/d
+ if(dummy > 0.9999d0) dummy = 0.9999d0
+ if(dummy < -0.9999d0) dummy = -0.9999d0
+ theta = acos(dummy)
+
+ if(z2 < 0.d0) theta = 360.d0*convert - theta
+ thetaup = theta - ARROW_ANGLE*convert
+ thetadown = theta + ARROW_ANGLE*convert
+
+! draw the vector
+ x1 = (orig_x+x1) * centim
+ z1 = (orig_z+z1) * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ xa = -d2*cos(thetaup)
+ za = -d2*sin(thetaup)
+ xa = xa * centim
+ za = za * centim
+ xb = -d2*cos(thetadown)
+ zb = -d2*sin(thetadown)
+ xb = xb * centim
+ zb = zb * centim
+ if ( myrank == 0 ) then
+ 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)
+
+ line_length = len_trim(postscript_line)
+ index_char = 1
+ first = .false.
+ do ii = 1,line_length-1
+ if(ch1(ii) /= ' ' .or. first) then
+ if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
+ ch2(index_char) = ch1(ii)
+ index_char = index_char + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(index_char) = ch1(line_length)
+ write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
+
+ else
+ buffer_offset = buffer_offset + 1
+ 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
+ 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_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)
+
+ line_length = len_trim(postscript_line)
+ index_char = 1
+ first = .false.
+ do ii = 1,line_length-1
+ if(ch1(ii) /= ' ' .or. first) then
+ if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
+ ch2(index_char) = ch1(ii)
+ index_char = index_char + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(index_char) = ch1(line_length)
+ write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
+ 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_ps_vector_field(1,1), 8*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 47, MPI_COMM_WORLD, ier)
+ endif
+ endif
+
+#endif
+
+ endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+
+! sources and receivers in color if velocity model
+ if(modelvect) then
+ write(24,*) 'Colreceiv'
+ else
+ write(24,*) '0 setgray'
+ endif
+
+!
+!---- write position of the source
+!
+ do i=1,NSOURCES
+ if(i == 1) write(24,*) '% beginning of source line'
+ if(i == NSOURCES) write(24,*) '% end of source line'
+ xw = x_source(i)
+ zw = z_source(i)
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ write(24,500) xw,zw
+ write(24,*) 'Cross'
+ enddo
+
+!
+!---- write position of the receivers
+!
+ do i=1,nrec
+ if(i == 1) write(24,*) '% beginning of receiver line'
+ if(i == nrec) write(24,*) '% end of receiver line'
+
+ xw = st_xval(i)
+ zw = st_zval(i)
+
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ write(24,500) xw,zw
+ write(24,*) 'Diamond'
+ enddo
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+ endif
+
+ 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a100,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
+ 600 format(f6.3,' neg CM 0 MR (Time =',f8.3,' s) show')
+ 601 format(f6.3,' neg CM 0 MR (Time =',1pe12.3,' s) show')
+ 610 format(f6.3,' neg CM 0 MR (Time step = ',i7,') show')
+ 620 format(f6.3,' neg CM 0 MR (Cut =',f5.2,' \%) show')
+ 640 format(f6.3,' neg CM 0 MR (Max norm =',1pe12.3,') show')
+
+ 499 format(f8.3,1x,f8.3,' L')
+ 500 format(f8.3,1x,f8.3,' M')
+ 502 format('fN (',i4,') Cshow')
+ 679 format(f12.6,1x,f12.6,1x,f12.6,' RG fill stroke')
+ 680 format(f12.6,1x,f12.6,1x,f12.6,' RG GF')
+ 681 format(f6.2,1x,f6.2)
+ 602 format(f6.2,1x,f6.2,' M ',f6.2,1x,f6.2,' L ST')
+ 604 format('CP ',f12.6,' BK')
+ 700 format(8(f6.2,1x),'F')
+
+ end subroutine plotpost
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_absorb.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/prepare_absorb.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_absorb.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_absorb.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,522 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine prepare_absorb_files(myrank,any_elastic,any_poroelastic,any_acoustic, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,SIMULATION_TYPE)
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank,SIMULATION_TYPE
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ logical :: any_elastic,any_poroelastic,any_acoustic
+
+ ! local parameters
+ character(len=150) :: outputname,outputname2
+
+
+ if(any_elastic) then
+
+ !--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_left',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=35,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=35,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+ !--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_right',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=36,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=36,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+ !--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_bottom',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=37,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=37,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+ !--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_top',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=38,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=38,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif ! any_elastic
+
+ if(any_poroelastic) then
+
+ !--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_left',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_left',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=45,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=25,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=45,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=25,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+ !--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_right',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_right',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=46,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=26,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=46,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=26,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+ !--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_bottom',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_bottom',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=47,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=29,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=47,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=29,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+ !--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_top',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_top',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=48,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=28,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=48,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=28,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif !any_poroelastic
+
+ if(any_acoustic) then
+
+ !--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_left',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=65,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=65,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+ !--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_right',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=66,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=66,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+ !--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_bottom',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=67,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=67,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+ !--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_top',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=68,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=68,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif !any_acoustic
+
+
+ end subroutine prepare_absorb_files
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_absorb_elastic(NSTEP,p_sv, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_elastic_left,b_absorb_elastic_right, &
+ b_absorb_elastic_bottom,b_absorb_elastic_top)
+
+ implicit none
+ include "constants.h"
+
+ logical :: p_sv
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer :: NSTEP
+ real(kind=CUSTOM_REAL) :: b_absorb_elastic_left(3,NGLLZ,nspec_xmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_elastic_right(3,NGLLZ,nspec_xmax,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_elastic_bottom(3,NGLLX,nspec_zmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_elastic_top(3,NGLLX,nspec_zmax,NSTEP)
+
+ ! local parameters
+ integer :: ispec,i,it
+
+ do it =1, NSTEP
+
+ !--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLZ
+ read(35) b_absorb_elastic_left(1,i,ispec,it)
+ enddo
+ do i=1,NGLLZ
+ read(35) b_absorb_elastic_left(3,i,ispec,it)
+ enddo
+ b_absorb_elastic_left(2,:,ispec,it) = ZERO
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ read(35) b_absorb_elastic_left(2,i,ispec,it)
+ enddo
+ b_absorb_elastic_left(1,:,ispec,it) = ZERO
+ b_absorb_elastic_left(3,:,ispec,it) = ZERO
+ endif
+
+ enddo
+ endif
+
+ !--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLZ
+ read(36) b_absorb_elastic_right(1,i,ispec,it)
+ enddo
+ do i=1,NGLLZ
+ read(36) b_absorb_elastic_right(3,i,ispec,it)
+ enddo
+ b_absorb_elastic_right(2,:,ispec,it) = ZERO
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ read(36) b_absorb_elastic_right(2,i,ispec,it)
+ enddo
+ b_absorb_elastic_right(1,:,ispec,it) = ZERO
+ b_absorb_elastic_right(3,:,ispec,it) = ZERO
+ endif
+
+ enddo
+ endif
+
+ !--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLX
+ read(37) b_absorb_elastic_bottom(1,i,ispec,it)
+ enddo
+ do i=1,NGLLX
+ read(37) b_absorb_elastic_bottom(3,i,ispec,it)
+ enddo
+ b_absorb_elastic_bottom(2,:,ispec,it) = ZERO
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ read(37) b_absorb_elastic_bottom(2,i,ispec,it)
+ enddo
+ b_absorb_elastic_bottom(1,:,ispec,it) = ZERO
+ b_absorb_elastic_bottom(3,:,ispec,it) = ZERO
+ endif
+
+ enddo
+ endif
+
+ !--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLX
+ read(38) b_absorb_elastic_top(1,i,ispec,it)
+ enddo
+ do i=1,NGLLX
+ read(38) b_absorb_elastic_top(3,i,ispec,it)
+ enddo
+ b_absorb_elastic_top(2,:,ispec,it) = ZERO
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ read(38) b_absorb_elastic_top(2,i,ispec,it)
+ enddo
+ b_absorb_elastic_top(1,:,ispec,it) = ZERO
+ b_absorb_elastic_top(3,:,ispec,it) = ZERO
+ endif
+
+ enddo
+ endif
+
+ enddo
+
+ end subroutine prepare_absorb_elastic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_absorb_poroelastic(NSTEP, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_poro_s_left,b_absorb_poro_w_left, &
+ b_absorb_poro_s_right,b_absorb_poro_w_right, &
+ b_absorb_poro_s_bottom,b_absorb_poro_w_bottom, &
+ b_absorb_poro_s_top,b_absorb_poro_w_top)
+
+ implicit none
+ include "constants.h"
+
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+
+ integer :: NSTEP
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_s_left(NDIM,NGLLZ,nspec_xmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_s_right(NDIM,NGLLZ,nspec_xmax,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_s_bottom(NDIM,NGLLX,nspec_zmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_s_top(NDIM,NGLLX,nspec_zmax,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_w_left(NDIM,NGLLZ,nspec_xmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_w_right(NDIM,NGLLZ,nspec_xmax,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_w_bottom(NDIM,NGLLX,nspec_zmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_w_top(NDIM,NGLLX,nspec_zmax,NSTEP)
+
+ ! local parameters
+ integer :: ispec,i,it,id
+
+ do it =1, NSTEP
+
+ !--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ read(45) b_absorb_poro_s_left(id,i,ispec,it)
+ read(25) b_absorb_poro_w_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ !--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ read(46) b_absorb_poro_s_right(id,i,ispec,it)
+ read(26) b_absorb_poro_w_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ !--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ read(47) b_absorb_poro_s_bottom(id,i,ispec,it)
+ read(29) b_absorb_poro_w_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ !--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ read(48) b_absorb_poro_s_top(id,i,ispec,it)
+ read(28) b_absorb_poro_w_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ enddo
+
+ end subroutine prepare_absorb_poroelastic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_absorb_acoustic(NSTEP, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_acoustic_left,b_absorb_acoustic_right, &
+ b_absorb_acoustic_bottom,b_absorb_acoustic_top)
+
+ implicit none
+ include "constants.h"
+
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+
+ integer :: NSTEP
+ real(kind=CUSTOM_REAL) :: b_absorb_acoustic_left(NGLLZ,nspec_xmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_acoustic_right(NGLLZ,nspec_xmax,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_acoustic_bottom(NGLLX,nspec_zmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_acoustic_top(NGLLX,nspec_zmax,NSTEP)
+
+
+ ! local parameters
+ integer :: ispec,i,it
+
+ do it =1, NSTEP
+
+ !--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do i=1,NGLLZ
+ read(65) b_absorb_acoustic_left(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+ !--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do i=1,NGLLZ
+ read(66) b_absorb_acoustic_right(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+ !--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do i=1,NGLLX
+ read(67) b_absorb_acoustic_bottom(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+ !--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do i=1,NGLLX
+ read(68) b_absorb_acoustic_top(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+ enddo
+
+ end subroutine prepare_absorb_acoustic
+
\ No newline at end of file
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_assemble_MPI.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/prepare_assemble_MPI.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_assemble_MPI.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_assemble_MPI.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,340 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!
+! 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.
+!
+
+#ifdef USE_MPI
+
+!-----------------------------------------------
+! Determines the points that are on the interfaces with other partitions, to help
+! 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 (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, &
+ 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 )
+
+ implicit none
+
+ include 'constants.h'
+
+ integer, intent(in) :: nspec, npoin, ngnod
+ logical, dimension(nspec), intent(in) :: elastic, poroelastic
+ integer, dimension(ngnod,nspec), intent(in) :: knods
+ integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
+
+ integer :: ninterface
+ integer :: max_interface_size
+ integer, dimension(ninterface) :: my_nelmnts_neighbours
+ integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
+ integer, dimension(NGLLX*max_interface_size,ninterface) :: &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(ninterface) :: &
+ nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
+
+ integer, dimension(ninterface), intent(out) :: &
+ inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
+ integer, intent(out) :: ninterface_acoustic, ninterface_elastic, ninterface_poroelastic
+
+ logical, dimension(nspec), intent(inout) :: mask_ispec_inner_outer
+
+ ! local parameters
+ integer :: num_interface
+ integer :: ispec_interface
+ logical, dimension(npoin) :: mask_ibool_acoustic
+ logical, dimension(npoin) :: mask_ibool_elastic
+ logical, dimension(npoin) :: mask_ibool_poroelastic
+ integer :: ixmin, ixmax, izmin, izmax, ix, iz
+ integer, dimension(ngnod) :: n
+ integer :: e1, e2, itype, ispec, k, sens, iglob
+ integer :: npoin_interface_acoustic
+ integer :: npoin_interface_elastic
+ integer :: npoin_interface_poroelastic
+
+ ! initializes
+ ibool_interfaces_acoustic(:,:) = 0
+ nibool_interfaces_acoustic(:) = 0
+ ibool_interfaces_elastic(:,:) = 0
+ nibool_interfaces_elastic(:) = 0
+ ibool_interfaces_poroelastic(:,:) = 0
+ nibool_interfaces_poroelastic(:) = 0
+
+ do num_interface = 1, ninterface
+ ! initializes interface point counters
+ npoin_interface_acoustic = 0
+ npoin_interface_elastic = 0
+ npoin_interface_poroelastic = 0
+ mask_ibool_acoustic(:) = .false.
+ mask_ibool_elastic(:) = .false.
+ mask_ibool_poroelastic(:) = .false.
+
+ do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
+ ! element id
+ ispec = my_interfaces(1,ispec_interface,num_interface)
+ ! type of interface: 1 = common point, 2 = common edge
+ itype = my_interfaces(2,ispec_interface,num_interface)
+ ! element control node ids
+ do k = 1, ngnod
+ n(k) = knods(k,ispec)
+ end do
+ ! common node ids
+ e1 = my_interfaces(3,ispec_interface,num_interface)
+ e2 = my_interfaces(4,ispec_interface,num_interface)
+
+ call get_edge(ngnod, n, itype, e1, e2, ixmin, ixmax, izmin, izmax, sens)
+
+ do iz = izmin, izmax, sens
+ do ix = ixmin, ixmax, sens
+ ! global index
+ iglob = ibool(ix,iz,ispec)
+
+ ! checks to which material this common interface belongs
+ if ( elastic(ispec) ) then
+ ! elastic element
+ if(.not. mask_ibool_elastic(iglob)) then
+ mask_ibool_elastic(iglob) = .true.
+ npoin_interface_elastic = npoin_interface_elastic + 1
+ ibool_interfaces_elastic(npoin_interface_elastic,num_interface) = iglob
+ end if
+ else if ( poroelastic(ispec) ) then
+ ! poroelastic element
+ if(.not. mask_ibool_poroelastic(iglob)) then
+ mask_ibool_poroelastic(iglob) = .true.
+ npoin_interface_poroelastic = npoin_interface_poroelastic + 1
+ ibool_interfaces_poroelastic(npoin_interface_poroelastic,num_interface) = iglob
+ end if
+ else
+ ! acoustic element
+ if(.not. mask_ibool_acoustic(iglob)) then
+ mask_ibool_acoustic(iglob) = .true.
+ npoin_interface_acoustic = npoin_interface_acoustic + 1
+ ibool_interfaces_acoustic(npoin_interface_acoustic,num_interface) = iglob
+ end if
+ end if
+ end do
+ end do
+
+ end do
+
+ ! stores counters for interface points
+ nibool_interfaces_acoustic(num_interface) = npoin_interface_acoustic
+ nibool_interfaces_elastic(num_interface) = npoin_interface_elastic
+ nibool_interfaces_poroelastic(num_interface) = npoin_interface_poroelastic
+
+ ! sets inner/outer element flags
+ do ispec = 1, nspec
+ do iz = 1, NGLLZ
+ do ix = 1, NGLLX
+ if ( mask_ibool_acoustic(ibool(ix,iz,ispec)) &
+ .or. mask_ibool_elastic(ibool(ix,iz,ispec)) &
+ .or. mask_ibool_poroelastic(ibool(ix,iz,ispec)) ) then
+ mask_ispec_inner_outer(ispec) = .true.
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end do
+
+ ! sets number of interfaces for each material domain
+ ninterface_acoustic = 0
+ ninterface_elastic = 0
+ ninterface_poroelastic = 0
+
+ ! loops over all MPI interfaces
+ do num_interface = 1, ninterface
+ ! sets acoustic MPI interface (local) indices in range [1,ninterface_acoustic]
+ if ( nibool_interfaces_acoustic(num_interface) > 0 ) then
+ ninterface_acoustic = ninterface_acoustic + 1
+ inum_interfaces_acoustic(ninterface_acoustic) = num_interface
+ end if
+ ! elastic
+ if ( nibool_interfaces_elastic(num_interface) > 0 ) then
+ ninterface_elastic = ninterface_elastic + 1
+ inum_interfaces_elastic(ninterface_elastic) = num_interface
+ end if
+ ! poroelastic
+ if ( nibool_interfaces_poroelastic(num_interface) > 0 ) then
+ ninterface_poroelastic = ninterface_poroelastic + 1
+ inum_interfaces_poroelastic(ninterface_poroelastic) = num_interface
+ end if
+ end do
+
+ end subroutine prepare_assemble_MPI
+
+
+!-----------------------------------------------
+! Get the points (ixmin, ixmax, izmin and izmax) on an node/edge for one element.
+! 'sens' is used to have DO loops with increment equal to 'sens' (-/+1).
+!-----------------------------------------------
+ subroutine get_edge ( ngnod, n, itype, e1, e2, ixmin, ixmax, izmin, izmax, sens )
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: ngnod
+ integer, dimension(ngnod), intent(in) :: n
+ integer, intent(in) :: itype, e1, e2
+ integer, intent(out) :: ixmin, ixmax, izmin, izmax
+ integer, intent(out) :: sens
+
+ if ( itype == 1 ) then
+
+ ! common single point
+
+ ! checks which corner point is given
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ ixmax = 1
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ ixmax = 1
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ sens = 1
+
+ else if( itype == 2 ) then
+
+ ! common edge
+
+ ! checks which edge and corner points are given
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ izmin = 1
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ izmax = 1
+ sens = 1
+ end if
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ izmax = NGLLZ
+ sens = 1
+ end if
+ end if
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ izmin = 1
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ izmax = NGLLZ
+ sens = 1
+ end if
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ izmax = 1
+ sens = -1
+ end if
+ end if
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ izmin = NGLLZ
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ izmax = NGLLZ
+ sens = -1
+ end if
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ izmax = 1
+ sens = -1
+ end if
+ end if
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ izmin = NGLLZ
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ izmax = 1
+ sens = -1
+ end if
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ izmax = NGLLZ
+ sens = 1
+ end if
+ end if
+
+ else
+
+ call exit_MPI('ERROR get_edge unknown type')
+
+ end if
+
+ end subroutine get_edge
+
+#endif
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_color_image.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/prepare_color_image.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_color_image.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_color_image.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,436 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine prepare_color_image_init(NX_IMAGE_color,NZ_IMAGE_color, &
+ xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image, &
+ coord,npoin,npgeo)
+
+ implicit none
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: NX_IMAGE_color,NZ_IMAGE_color
+
+ integer :: npoin,npgeo
+ double precision, dimension(NDIM,npoin) :: coord
+
+ double precision :: xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image
+
+ ! local parameters
+ integer :: npgeo_glob
+ double precision :: xmin_color_image_loc, xmax_color_image_loc, &
+ zmin_color_image_loc,zmax_color_image_loc
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+ ! horizontal size of the image
+ xmin_color_image_loc = minval(coord(1,:))
+ xmax_color_image_loc = maxval(coord(1,:))
+
+ ! vertical size of the image, slightly increase it to go beyond maximum topography
+ zmin_color_image_loc = minval(coord(2,:))
+ zmax_color_image_loc = maxval(coord(2,:))
+
+! global values
+ xmin_color_image = xmin_color_image_loc
+ xmax_color_image = xmax_color_image_loc
+ zmin_color_image = zmin_color_image_loc
+ zmax_color_image = zmax_color_image_loc
+ npgeo_glob = npgeo
+
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(xmin_color_image_loc, xmin_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE(xmax_color_image_loc, xmax_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE(zmin_color_image_loc, zmin_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE(zmax_color_image_loc, zmax_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE(npgeo, npgeo_glob, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ier)
+#endif
+
+ zmax_color_image = zmin_color_image + 1.05d0 * (zmax_color_image - zmin_color_image)
+
+ ! compute number of pixels in the horizontal direction based on typical number
+ ! of spectral elements in a given direction (may give bad results for very elongated models)
+ NX_IMAGE_color = nint(sqrt(dble(npgeo_glob))) * (NGLLX-1) + 1
+
+ ! compute number of pixels in the vertical direction based on ratio of sizes
+ NZ_IMAGE_color = nint(NX_IMAGE_color * (zmax_color_image - zmin_color_image) &
+ / (xmax_color_image - xmin_color_image))
+
+ ! convert pixel sizes to even numbers because easier to reduce size,
+ ! create MPEG movies in postprocessing
+ NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
+ NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
+
+ ! check that image size is not too big
+ if (NX_IMAGE_color > 99999) call exit_MPI('output image too big : NX_IMAGE_color > 99999.')
+ if (NZ_IMAGE_color > 99999) call exit_MPI('output image too big : NZ_IMAGE_color > 99999.')
+
+ end subroutine prepare_color_image_init
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_color_image_pixels(myrank,NX_IMAGE_color,NZ_IMAGE_color, &
+ xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image, &
+ coord,npoin,coorg,npgeo,nspec,ngnod,knods,ibool, &
+ nb_pixel_loc,iglob_image_color)
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank
+ integer :: NX_IMAGE_color,NZ_IMAGE_color
+ double precision :: xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image
+
+ integer :: npoin,nspec,npgeo,ngnod
+ double precision, dimension(NDIM,npoin) :: coord
+ double precision, dimension(NDIM,npgeo) :: coorg
+
+ integer, dimension(ngnod,nspec) :: knods
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ integer :: nb_pixel_loc
+ integer, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: iglob_image_color
+
+ ! local parameters
+ double precision :: size_pixel_horizontal,size_pixel_vertical
+ double precision, dimension(2,4) :: elmnt_coords
+ double precision :: i_coord, j_coord
+ double precision :: dist_pixel, dist_min_pixel
+ integer :: min_i, min_j, max_i, max_j
+ integer :: ispec,i,j,k,l,iglob
+ logical :: pixel_is_in
+
+ ! create all the pixels
+ 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)
+ size_pixel_vertical = (zmax_color_image - zmin_color_image) / dble(NZ_IMAGE_color-1)
+
+ iglob_image_color(:,:) = -1
+
+ ! checking which pixels are inside each elements
+
+ nb_pixel_loc = 0
+ do ispec = 1, nspec
+
+ do k = 1, 4
+ elmnt_coords(1,k) = coorg(1,knods(k,ispec))
+ elmnt_coords(2,k) = coorg(2,knods(k,ispec))
+ enddo
+
+ ! avoid working on the whole pixel grid
+ min_i = floor(minval((elmnt_coords(1,:) - xmin_color_image))/size_pixel_horizontal) + 1
+ max_i = ceiling(maxval((elmnt_coords(1,:) - xmin_color_image))/size_pixel_horizontal) + 1
+ min_j = floor(minval((elmnt_coords(2,:) - zmin_color_image))/size_pixel_vertical) + 1
+ max_j = ceiling(maxval((elmnt_coords(2,:) - zmin_color_image))/size_pixel_vertical) + 1
+
+ ! avoid edge effects
+ if(min_i < 1) min_i = 1
+ if(min_j < 1) min_j = 1
+
+ if(max_i > NX_IMAGE_color) max_i = NX_IMAGE_color
+ if(max_j > NZ_IMAGE_color) max_j = NZ_IMAGE_color
+
+ do j = min_j, max_j
+ do i = min_i, max_i
+ i_coord = (i-1)*size_pixel_horizontal + xmin_color_image
+ j_coord = (j-1)*size_pixel_vertical + zmin_color_image
+
+ ! checking if the pixel is inside the element (must be a convex quadrilateral)
+ call is_in_convex_quadrilateral( elmnt_coords, i_coord, j_coord, pixel_is_in)
+
+ ! if inside, getting the nearest point inside the element!
+ if ( pixel_is_in ) then
+ dist_min_pixel = HUGEVAL
+ do k = 1, NGLLX
+ do l = 1, NGLLZ
+ iglob = ibool(k,l,ispec)
+ dist_pixel = (coord(1,iglob)-i_coord)**2 + (coord(2,iglob)-j_coord)**2
+ if (dist_pixel < dist_min_pixel) then
+ dist_min_pixel = dist_pixel
+ iglob_image_color(i,j) = iglob
+
+ endif
+
+ enddo
+ enddo
+ if ( dist_min_pixel >= HUGEVAL ) then
+ call exit_MPI('Error in detecting pixel for color image')
+
+ endif
+ nb_pixel_loc = nb_pixel_loc + 1
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine prepare_color_image_pixels
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine prepare_color_image_vp(npoin,image_color_vp_display,iglob_image_color, &
+ NX_IMAGE_color,NZ_IMAGE_color,nb_pixel_loc, &
+ num_pixel_loc,nspec,poroelastic,ibool,kmato, &
+ numat,density,poroelastcoef,porosity,tortuosity, &
+ nproc,myrank,assign_external_model,vpext)
+
+! stores P-velocity model in image_color_vp_display
+
+ implicit none
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: npoin,nspec
+ integer :: NX_IMAGE_color,NZ_IMAGE_color
+ double precision, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: image_color_vp_display
+ integer, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: iglob_image_color
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+
+ logical, dimension(nspec) :: poroelastic
+
+ integer :: nb_pixel_loc
+ integer, dimension(nb_pixel_loc) :: num_pixel_loc
+
+ logical :: assign_external_model
+ integer :: nproc,myrank
+ integer :: numat
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext
+
+ ! local parameters
+ double precision, dimension(:), allocatable :: vp_display
+ double precision :: rhol,mul_relaxed,lambdal_relaxed
+ double precision :: rhol_s,rhol_f,rhol_bar,phil,tortl,mul_s,kappal_s,kappal_f, &
+ mul_fr,kappal_fr
+ double precision :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,&
+ M_biot,B_biot,cpIsquare,cpIIsquare,cssquare
+ double precision :: gamma1,gamma2,gamma3,gamma4,ratio
+ integer :: i,j,k,ispec
+#ifdef USE_MPI
+ double precision, dimension(:), allocatable :: data_pixel_recv
+ double precision, dimension(:), allocatable :: data_pixel_send
+ integer, dimension(:,:), allocatable :: num_pixel_recv
+ integer, dimension(:), allocatable :: nb_pixel_per_proc
+ integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
+ integer :: ier,iproc
+#else
+ integer :: dummy
+#endif
+
+ ! to display the P-velocity model in background on color images
+ 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))
+ !solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4.d0*mul_s/3.d0
+ 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.d0*mul_fr/3.d0
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+ !Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
+ + kappal_fr + 4.d0*mul_fr/3.d0
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ B_biot = H_biot - 4.d0*mul_fr/3.d0
+ ! 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.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cssquare = mul_fr/afactor
+
+ ! Approximated ratio r = amplitude "w" field/amplitude "s" field (no viscous dissipation)
+ ! used later for wavespeed kernels calculation, which are presently implemented for inviscid case,
+ ! contrary to primary and density-normalized kernels, which are consistent with viscous fluid case.
+ gamma1 = H_biot - phil/tortl*C_biot
+ gamma2 = C_biot - phil/tortl*M_biot
+ gamma3 = phil/tortl*( M_biot*(afactor/rhol_f + phil/tortl) - C_biot)
+ gamma4 = phil/tortl*( C_biot*(afactor/rhol_f + phil/tortl) - H_biot)
+ ratio = HALF*(gamma1 - gamma3)/gamma4 &
+ + HALF*sqrt((gamma1-gamma3)**2/gamma4**2 &
+ + 4.d0 * gamma2/gamma4)
+
+ 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)
+ 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
+ image_color_vp_display(:,:) = 0.d0
+
+ 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
+ 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
+
+ allocate(nb_pixel_per_proc(nproc))
+ nb_pixel_per_proc(:) = 0
+ call MPI_GATHER( nb_pixel_loc, 1, MPI_INTEGER, nb_pixel_per_proc(1), &
+ 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ier)
+
+
+ if ( myrank == 0 ) then
+ allocate(num_pixel_recv(maxval(nb_pixel_per_proc(:)),nproc))
+ allocate(data_pixel_recv(maxval(nb_pixel_per_proc(:))))
+ endif
+ allocate(data_pixel_send(nb_pixel_loc))
+
+ if (nproc > 1) then
+ if (myrank == 0) then
+ do iproc = 1, nproc-1
+
+ call MPI_RECV(num_pixel_recv(1,iproc+1),nb_pixel_per_proc(iproc+1), MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ 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)
+
+ do k = 1, nb_pixel_per_proc(iproc+1)
+ 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
+
+ ! checks bounds
+ if( i < 1 .or. i > NX_IMAGE_color .or. j < 1 .or. j > NZ_IMAGE_color ) then
+ print*,'image vp bounds:',myrank,iproc,k, &
+ num_pixel_recv(k,iproc+1),nb_pixel_per_proc(iproc+1)
+ print*,' i: ',i,NX_IMAGE_color
+ print*,' j: ',j,NZ_IMAGE_color
+ endif
+
+ image_color_vp_display(i,j) = data_pixel_recv(k)
+ enddo
+ enddo
+
+ 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) = vp_display(iglob_image_color(i,j))
+ enddo
+
+ call MPI_SEND(num_pixel_loc(1),nb_pixel_loc,MPI_INTEGER, &
+ 0, 42, MPI_COMM_WORLD, ier)
+
+ call MPI_SEND(data_pixel_send(1),nb_pixel_loc,MPI_DOUBLE_PRECISION, &
+ 0, 43, MPI_COMM_WORLD, ier)
+
+ endif
+ endif
+
+ deallocate(nb_pixel_per_proc)
+ deallocate(data_pixel_send)
+ if( myrank == 0 ) then
+ deallocate(num_pixel_recv)
+ deallocate(data_pixel_recv)
+ endif
+#else
+ ! to avoid compiler warnings
+ dummy = myrank
+ dummy = nproc
+#endif
+
+ end subroutine prepare_color_image_vp
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_initialfield.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/prepare_initialfield.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_initialfield.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_initialfield.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,395 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine prepare_initialfield(myrank,any_acoustic,any_poroelastic,over_critical_angle, &
+ NSOURCES,source_type,angleforce,x_source,z_source,f0, &
+ npoin,numat,poroelastcoef,density,coord, &
+ angleforce_refl,c_inc,c_refl,cploc,csloc,time_offset, &
+ A_plane, B_plane, C_plane, &
+ accel_elastic,veloc_elastic,displ_elastic)
+
+ implicit none
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: myrank
+ logical :: any_acoustic,any_poroelastic
+
+ integer :: NSOURCES
+ integer, dimension(NSOURCES) :: source_type
+ double precision, dimension(NSOURCES) :: angleforce,x_source,z_source,f0
+
+ integer :: npoin,numat
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(NDIM,npoin) :: coord
+
+ double precision :: angleforce_refl,c_inc,c_refl,cploc,csloc
+ double precision :: time_offset,x0_source,z0_source
+ double precision, dimension(2) :: A_plane, B_plane, C_plane
+
+ real(kind=CUSTOM_REAL), dimension(3,npoin) :: accel_elastic,veloc_elastic,displ_elastic
+
+ logical :: over_critical_angle
+
+ ! local parameters
+ integer :: numat_local,i
+ double precision :: denst,lambdaplus2mu,mu,p
+ double precision :: PP,PS,SP,SS
+ double precision :: xmax, xmin, zmax, zmin,x,z,t
+#ifdef USE_MPI
+ double precision :: xmax_glob, xmin_glob, zmax_glob, zmin_glob
+ integer :: ier
+#endif
+ double precision, external :: ricker_Bielak_displ,ricker_Bielak_veloc,ricker_Bielak_accel
+
+ ! user output
+ 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')
+
+ !=======================================================================
+ !
+ ! Calculation of the initial field for a plane wave
+ !
+ !=======================================================================
+
+ 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/SOURCE'
+ 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(NSOURCES > 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
+ numat_local = numat
+ if (numat /= 1) then
+ if (myrank == 0) write(IOUT,*) 'not possible to have several materials with a plane wave, using the first material'
+ numat_local = 1
+ endif
+
+ mu = poroelastcoef(2,1,numat_local)
+ lambdaplus2mu = poroelastcoef(3,1,numat_local)
+ denst = density(1,numat_local)
+
+ cploc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+
+ ! P wave case
+ if (source_type(1) == 1) then
+
+ p=sin(angleforce(1))/cploc
+ c_inc = cploc
+ c_refl = 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) / &
+ ( cos(2.d0*angleforce_refl)**2/csloc**3 &
+ + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc)
+
+ PS = 4.d0*p*cos(angleforce(1))*cos(2.d0*angleforce_refl) / &
+ (csloc**2*(cos(2.d0*angleforce_refl)**2/csloc**3 &
+ +4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc))
+
+ 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)
+
+ ! SV wave case
+ 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*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(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))
+
+ 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
+ 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)
+
+ ! 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
+
+ ! get minimum and maximum values of mesh coordinates
+ xmin = minval(coord(1,:))
+ zmin = minval(coord(2,:))
+ xmax = maxval(coord(1,:))
+ zmax = maxval(coord(2,:))
+
+#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
+ x0_source=x_source(1)
+ z0_source=z_source(1)
+
+ 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
+
+ if (.not. over_critical_angle) then
+
+ do i = 1,npoin
+
+ x = coord(1,i)
+ z = coord(2,i)
+
+ ! z is from bottom to top therefore we take -z to make parallel with Aki & Richards
+ z = z0_source - z
+ x = x - x0_source
+
+ t = 0.d0 + time_offset
+
+ ! 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(3,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))
+
+ ! 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(3,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(3,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
+
+ endif
+
+ end subroutine prepare_initialfield
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_initialfield_paco(myrank,nelemabs,left_bound,right_bound,bot_bound, &
+ numabs,codeabs,ibool,nspec, &
+ source_type,NSOURCES,c_inc,c_refl, &
+ count_bottom,count_left,count_right)
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank
+
+ integer :: nelemabs
+ integer :: left_bound(nelemabs*NGLLX)
+ integer :: right_bound(nelemabs*NGLLX)
+ integer :: bot_bound(nelemabs*NGLLZ)
+ integer,dimension(nelemabs) :: numabs
+ logical, dimension(4,nelemabs) :: codeabs
+
+ integer :: nspec
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ integer :: NSOURCES
+ integer :: source_type(NSOURCES)
+
+ double precision :: c_inc,c_refl
+
+ integer :: count_bottom,count_left,count_right
+
+ ! local parameters
+ integer :: ispecabs,ispec,i,j,iglob,ibegin,iend
+
+ 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
+
+ count_bottom=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_bottom=count_bottom+1
+ iglob = ibool(i,j,ispec)
+ bot_bound(count_bottom)=iglob
+ enddo
+ endif
+ enddo
+
+ end subroutine prepare_initialfield_paco
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_source_time_function.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/prepare_source_time_function.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_source_time_function.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/prepare_source_time_function.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,160 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine prepare_source_time_function(myrank,NSTEP,NSOURCES,source_time_function, &
+ time_function_type,f0,tshift_src,factor,aval, &
+ t0,nb_proc_source,deltat)
+
+! prepares source_time_function array
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank,NSTEP
+
+ integer :: NSOURCES
+ integer, dimension(NSOURCES) :: time_function_type
+ double precision, dimension(NSOURCES) :: f0,tshift_src,factor
+ double precision, dimension(NSOURCES) :: aval
+ double precision :: t0
+ integer,dimension(NSOURCES) :: nb_proc_source
+ double precision :: deltat
+
+ real(kind=CUSTOM_REAL),dimension(NSOURCES,NSTEP) :: source_time_function
+
+ ! local parameters
+ double precision :: stf_used,time
+ double precision, dimension(NSOURCES) :: hdur,hdur_gauss
+ double precision, external :: netlib_specfun_erf
+ integer :: it,i_source
+
+
+ ! user output
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving the source time function in a text file...'
+ write(IOUT,*)
+ open(unit=55,file='OUTPUT_FILES/source.txt',status='unknown')
+ endif
+
+ ! ! loop on all the sources
+ ! do i_source=1,NSOURCES
+
+ ! loop on all the time steps
+ do it = 1,NSTEP
+
+ ! note: t0 is the simulation start time, tshift_src is the time shift of the source
+ ! relative to this start time
+
+ ! compute current time
+ time = (it-1)*deltat
+
+ stf_used = 0.d0
+
+ ! loop on all the sources
+ do i_source=1,NSOURCES
+
+ if( time_function_type(i_source) == 1 ) then
+
+ ! Ricker (second derivative of a Gaussian) source time function
+ source_time_function(i_source,it) = - factor(i_source) * &
+ (ONE-TWO*aval(i_source)*(time-t0-tshift_src(i_source))**2) * &
+ exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
+
+ ! source_time_function(i_source,it) = - factor(i_source) * &
+ ! TWO*aval(i_source)*sqrt(aval(i_source))*&
+ ! (time-t0-tshift_src(i_source))/pi * exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
+
+ else if( time_function_type(i_source) == 2 ) then
+
+ ! first derivative of a Gaussian source time function
+ source_time_function(i_source,it) = - factor(i_source) * &
+ TWO*aval(i_source)*(time-t0-tshift_src(i_source)) * &
+ exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
+
+ else if(time_function_type(i_source) == 3 .or. time_function_type(i_source) == 4) then
+
+ ! Gaussian or Dirac (we use a very thin Gaussian instead) source time function
+ source_time_function(i_source,it) = factor(i_source) * &
+ exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
+
+ else if(time_function_type(i_source) == 5) then
+
+ ! Heaviside source time function (we use a very thin error function instead)
+ 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-tshift_src(i_source))/hdur_gauss(i_source)))
+
+ else
+ call exit_MPI('unknown source time function')
+ endif
+
+ stf_used = stf_used + source_time_function(i_source,it)
+
+ enddo
+
+ ! output relative time in third column, in case user wants to check it as well
+ ! if (myrank == 0 .and. i_source==1 ) write(55,*) sngl(time-t0-tshift_src(1)),real(source_time_function(1,it),4),sngl(time)
+ if (myrank == 0) then
+ ! note: earliest start time of the simulation is: (it-1)*deltat - t0
+ write(55,*) sngl(time-t0),sngl(stf_used),sngl(time)
+ endif
+
+ !enddo
+ enddo
+
+ 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,NSOURCES
+ source_time_function(i_source,:) = source_time_function(i_source,:) / nb_proc_source(i_source)
+ enddo
+
+ end subroutine prepare_source_time_function
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/read_databases.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/read_databases.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/read_databases.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/read_databases.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,836 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine read_databases_init(myrank,ipass, &
+ simulation_title,SIMULATION_TYPE,SAVE_FORWARD,npgeo, &
+ gnuplot,interpol,NTSTEP_BETWEEN_OUTPUT_INFO, &
+ output_postscript_snapshot,output_color_image,colors,numbers, &
+ meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows, &
+ anglerec,initialfield,add_Bielak_conditions, &
+ seismotype,imagetype,assign_external_model,READ_EXTERNAL_SEP_FILE, &
+ outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON, &
+ TURN_VISCATTENUATION_ON,Q0,freq0,p_sv, &
+ NSTEP,deltat,NTSTEP_BETWEEN_OUTPUT_SEISMO,NSOURCES)
+
+! starts reading in parameters from input Database file
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank,ipass
+ character(len=60) simulation_title
+ integer :: SIMULATION_TYPE,npgeo
+ integer :: colors,numbers,subsamp,seismotype,imagetype
+ logical :: SAVE_FORWARD,gnuplot,interpol,output_postscript_snapshot, &
+ output_color_image
+ logical :: meshvect,modelvect,boundvect,initialfield,add_Bielak_conditions, &
+ assign_external_model,READ_EXTERNAL_SEP_FILE, &
+ outputgrid,OUTPUT_ENERGY,p_sv
+ logical :: TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON
+
+ double precision :: cutsnaps,sizemax_arrows,anglerec
+ double precision :: Q0,freq0
+ double precision :: deltat
+
+ integer :: NSTEP,NSOURCES
+ integer :: NTSTEP_BETWEEN_OUTPUT_INFO,NTSTEP_BETWEEN_OUTPUT_SEISMO
+
+ ! local parameters
+ integer :: ier
+ character(len=80) :: datlin
+ character(len=256) :: prname
+
+ ! opens Database file
+ write(prname,230) myrank
+ open(unit=IIN,file=prname,status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI('error opening file OUTPUT/Database***')
+
+ !--- read job title and skip remaining titles of the input file
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a50)") simulation_title
+
+ !---- print the date, time and start-up banner
+ if (myrank == 0 .and. ipass == 1) call datim(simulation_title)
+
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,*) '*********************'
+ write(IOUT,*) '**** ****'
+ write(IOUT,*) '**** SPECFEM2D ****'
+ write(IOUT,*) '**** ****'
+ write(IOUT,*) '*********************'
+ endif
+
+ !---- read parameters from input file
+ read(IIN,"(a80)") datlin
+ read(IIN,*) SIMULATION_TYPE, SAVE_FORWARD
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) npgeo
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) gnuplot,interpol
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) NTSTEP_BETWEEN_OUTPUT_INFO
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) output_postscript_snapshot,output_color_image,colors,numbers
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
+ cutsnaps = cutsnaps / 100.d0
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) anglerec
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) initialfield,add_Bielak_conditions
+ if(add_Bielak_conditions .and. .not. initialfield) &
+ stop 'need to have an initial field to add Bielak plane wave conditions'
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) seismotype,imagetype
+ if(seismotype < 1 .or. seismotype > 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 /= 6)) then
+ print*, '***** WARNING *****'
+ print*, 'seismotype =',seismotype
+ 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
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) assign_external_model,READ_EXTERNAL_SEP_FILE
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) TURN_VISCATTENUATION_ON,Q0,freq0
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) p_sv
+
+ !---- check parameters read
+ 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,&
+ READ_EXTERNAL_SEP_FILE,TURN_ATTENUATION_ON, &
+ outputgrid,OUTPUT_ENERGY
+ write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
+ endif
+
+ !---- read time step
+ read(IIN,"(a80)") datlin
+ read(IIN,*) NSTEP,deltat
+ if (myrank == 0 .and. ipass == 1) write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+
+ if( SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. &
+ (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)
+
+ !---- read source information
+ read(IIN,"(a80)") datlin
+ read(IIN,*) NSOURCES
+
+ ! output formats
+230 format('./OUTPUT_FILES/Database',i5.5)
+
+200 format(//1x,'C o n t r o l',/1x,13('='),//5x,&
+ 'Number of spectral element control nodes. . .(npgeo) =',i8/5x, &
+ 'Number of space dimensions. . . . . . . . . . (NDIM) =',i8)
+
+600 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Display frequency . . . (NTSTEP_BETWEEN_OUTPUT_INFO) = ',i6/ 5x, &
+ 'Color display . . . . . . . . . . . . . . . (colors) = ',i6/ 5x, &
+ ' == 0 black and white display ', / 5x, &
+ ' == 1 color display ', /5x, &
+ 'Numbered mesh . . . . . . . . . . . . . . .(numbers) = ',i6/ 5x, &
+ ' == 0 do not number the mesh ', /5x, &
+ ' == 1 number the mesh ')
+
+700 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Seismograms recording type . . . . . . .(seismotype) = ',i6/5x, &
+ 'Angle for first line of receivers. . . . .(anglerec) = ',f6.2)
+
+750 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Read external initial field. . . . . .(initialfield) = ',l6/5x, &
+ 'Add Bielak conditions . . . .(add_Bielak_conditions) = ',l6/5x, &
+ 'Assign external model . . . .(assign_external_model) = ',l6/5x, &
+ 'Read external SEP file . . .(READ_EXTERNAL_SEP_FILE) = ',l6/5x, &
+ 'Turn attenuation on or off. . .(TURN_ATTENUATION_ON) = ',l6/5x, &
+ 'Save grid in external file or not. . . .(outputgrid) = ',l6/5x, &
+ 'Save a file with total energy or not.(OUTPUT_ENERGY) = ',l6)
+
+800 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Vector display type . . . . . . . . . . .(imagetype) = ',i6/5x, &
+ 'Percentage of cut for vector plots . . . .(cutsnaps) = ',f6.2/5x, &
+ 'Subsampling for velocity model display. . .(subsamp) = ',i6)
+
+703 format(//' I t e r a t i o n s '/1x,19('='),//5x, &
+ 'Number of time iterations . . . . .(NSTEP) =',i8,/5x, &
+ 'Time step increment. . . . . . . .(deltat) =',1pe15.6,/5x, &
+ 'Total simulation duration . . . . . (ttot) =',1pe15.6)
+
+ end subroutine read_databases_init
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_sources(NSOURCES,source_type,time_function_type, &
+ x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce)
+
+! reads source parameters
+
+ implicit none
+ include "constants.h"
+
+ integer :: NSOURCES
+ integer, dimension(NSOURCES) :: source_type,time_function_type
+ double precision, dimension(NSOURCES) :: x_source,z_source, &
+ Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
+
+ ! local parameters
+ integer :: i_source
+ character(len=80) :: datlin
+
+ ! initializes
+ source_type(:) = 0
+ time_function_type(:) = 0
+ x_source(:) = 0.d0
+ z_source(:) = 0.d0
+ Mxx(:) = 0.d0
+ Mzz(:) = 0.d0
+ Mxz(:) = 0.d0
+ f0(:) = 0.d0
+ tshift_src(:) = 0.d0
+ factor(:) = 0.d0
+ angleforce(:) = 0.d0
+
+ ! reads in source info from Database file
+ do i_source=1,NSOURCES
+ read(IIN,"(a80)") datlin
+ read(IIN,*) source_type(i_source),time_function_type(i_source), &
+ x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
+ factor(i_source),angleforce(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
+ enddo
+
+ end subroutine read_databases_sources
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_atten(N_SLS,f0_attenuation)
+
+! reads attenuation information
+
+ implicit none
+ include "constants.h"
+
+ integer :: N_SLS
+ double precision :: f0_attenuation
+
+ ! local parameters
+ character(len=80) :: datlin
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) N_SLS, f0_attenuation
+
+ end subroutine read_databases_atten
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_coorg_elem(myrank,ipass,npgeo,coorg,numat,ngnod,nspec, &
+ pointsdisp,plot_lowerleft_corner_only, &
+ nelemabs,nelem_acoustic_surface, &
+ num_fluid_solid_edges,num_fluid_poro_edges, &
+ num_solid_poro_edges,nnodes_tangential_curve)
+
+! reads the spectral macrobloc nodal coordinates
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank,ipass,npgeo
+ double precision, dimension(NDIM,npgeo) :: coorg
+
+ integer :: numat,ngnod,nspec
+ integer :: pointsdisp
+ logical :: plot_lowerleft_corner_only
+ integer :: nelemabs,nelem_acoustic_surface, &
+ num_fluid_solid_edges,num_fluid_poro_edges, &
+ num_solid_poro_edges,nnodes_tangential_curve
+
+ ! local parameters
+ integer :: ipoin,ip,id
+ double precision, dimension(:), allocatable :: coorgread
+ character(len=80) :: datlin
+
+ ! initializes
+ coorg(:,:) = 0.d0
+
+ ! reads the spectral macrobloc nodal coordinates
+ read(IIN,"(a80)") datlin
+
+ ! reads in values
+ ipoin = 0
+ allocate(coorgread(NDIM))
+ do ip = 1,npgeo
+ ! reads coordinates
+ read(IIN,*) ipoin,(coorgread(id),id =1,NDIM)
+
+ if(ipoin<1 .or. ipoin>npgeo) call exit_MPI('Wrong control point number')
+
+ ! saves coordinate array
+ coorg(:,ipoin) = coorgread
+
+ enddo
+ deallocate(coorgread)
+
+ !---- read the basic properties of the spectral elements
+ read(IIN,"(a80)") datlin
+ read(IIN,*) numat,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
+
+ read(IIN,"(a80)") datlin
+ 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
+
+ !---- print element group main parameters
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,107)
+ write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
+ endif
+
+ ! output formats
+107 format(/5x,'--> Isoparametric Spectral Elements <--',//)
+
+207 format(5x,'Number of spectral elements . . . . . (nspec) =',i7,/5x, &
+ 'Number of control nodes per element . (ngnod) =',i7,/5x, &
+ 'Number of points in X-direction . . . (NGLLX) =',i7,/5x, &
+ 'Number of points in Y-direction . . . (NGLLZ) =',i7,/5x, &
+ 'Number of points per element. . .(NGLLX*NGLLZ) =',i7,/5x, &
+ 'Number of points for display . . .(pointsdisp) =',i7,/5x, &
+ 'Number of element material sets . . . (numat) =',i7,/5x, &
+ 'Number of absorbing elements . . . .(nelemabs) =',i7)
+
+ end subroutine read_databases_coorg_elem
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_mato(ipass,nspec,ngnod,kmato,knods, &
+ perm,antecedent_list)
+
+! reads spectral macrobloc data
+
+ implicit none
+ include "constants.h"
+
+ integer :: ipass,ngnod,nspec
+ integer, dimension(nspec) :: kmato
+ integer, dimension(ngnod,nspec) :: knods
+
+ integer, dimension(nspec) :: perm,antecedent_list
+
+ ! local parameters
+ integer :: n,k,ispec,kmato_read
+ integer, dimension(:), allocatable :: knods_read
+ character(len=80) :: datlin
+
+ ! initializes
+ kmato(:) = 0
+ knods(:,:) = 0
+
+ ! reads spectral macrobloc data
+ read(IIN,"(a80)") datlin
+
+ ! reads in values
+ allocate(knods_read(ngnod))
+ n = 0
+ do ispec = 1,nspec
+ ! format: #element_id #material_id #node_id1 #node_id2 #...
+ read(IIN,*) n,kmato_read,(knods_read(k), k=1,ngnod)
+ if(ipass == 1) then
+ ! material association
+ kmato(n) = kmato_read
+ ! element control node indices
+ knods(:,n)= knods_read(:)
+ else if(ipass == 2) then
+ kmato(perm(antecedent_list(n))) = kmato_read
+ knods(:,perm(antecedent_list(n)))= knods_read(:)
+ else
+ call exit_MPI('error: maximum is 2 passes')
+ endif
+ enddo
+ deallocate(knods_read)
+
+
+ end subroutine read_databases_mato
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_ninterface(ninterface,max_interface_size)
+
+! reads in interface dimensions
+
+ implicit none
+ include "constants.h"
+
+ integer :: ninterface,max_interface_size
+
+ ! local parameters
+ character(len=80) :: datlin
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) ninterface, max_interface_size
+
+ end subroutine read_databases_ninterface
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_interfaces(ipass,ninterface,nspec,max_interface_size, &
+ my_neighbours,my_nelmnts_neighbours,my_interfaces, &
+ perm,antecedent_list)
+
+! reads in interfaces
+
+ implicit none
+ include "constants.h"
+
+ integer :: ipass,nspec
+ integer :: ninterface,max_interface_size
+ integer, dimension(ninterface) :: my_neighbours,my_nelmnts_neighbours
+ integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
+
+ integer, dimension(nspec) :: perm,antecedent_list
+
+ ! local parameters
+ integer :: num_interface,ie,my_interfaces_read
+
+ ! initializes
+ my_neighbours(:) = -1
+ my_nelmnts_neighbours(:) = 0
+ my_interfaces(:,:,:) = -1
+
+ ! reads in interfaces
+ do num_interface = 1, ninterface
+ ! format: #process_interface_id #number_of_elements_on_interface
+ ! where
+ ! process_interface_id = rank of (neighbor) process to share MPI interface with
+ ! number_of_elements_on_interface = number of interface elements
+ read(IIN,*) my_neighbours(num_interface), my_nelmnts_neighbours(num_interface)
+
+ ! loops over interface elements
+ do ie = 1, my_nelmnts_neighbours(num_interface)
+ ! format: #(1)spectral_element_id #(2)interface_type #(3)node_id1 #(4)node_id2
+ !
+ ! interface types:
+ ! 1 - corner point only
+ ! 2 - element edge
+ read(IIN,*) my_interfaces_read, my_interfaces(2,ie,num_interface), &
+ my_interfaces(3,ie,num_interface), my_interfaces(4,ie,num_interface)
+
+ 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
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+
+ enddo
+ enddo
+
+ end subroutine read_databases_interfaces
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_absorbing(myrank,ipass,nelemabs,nspec,anyabs, &
+ ibegin_bottom,iend_bottom,jbegin_right,jend_right, &
+ ibegin_top,iend_top,jbegin_left,jend_left, &
+ numabs,codeabs,perm,antecedent_list, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ ib_right,ib_left,ib_bottom,ib_top)
+
+! reads in absorbing edges
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank,ipass,nspec
+ integer :: nelemabs
+ integer, dimension(nelemabs) :: numabs,ibegin_bottom,iend_bottom, &
+ ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
+ logical, dimension(4,nelemabs) :: codeabs
+ logical :: anyabs
+ integer, dimension(nspec) :: perm,antecedent_list
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+
+ integer, dimension(nelemabs) :: ib_right,ib_left,ib_bottom,ib_top
+
+ ! local parameters
+ integer :: inum,numabsread
+ logical :: codeabsread(4)
+ character(len=80) :: datlin
+
+ ! initializes
+ codeabs(:,:) = .false.
+
+ ibegin_bottom(:) = 0
+ iend_bottom(:) = 0
+ ibegin_top(:) = 0
+ iend_top(:) = 0
+
+ jbegin_left(:) = 0
+ jend_left(:) = 0
+ jbegin_right(:) = 0
+ jend_right(:) = 0
+
+ nspec_xmin = 0
+ nspec_xmax = 0
+ nspec_zmin = 0
+ nspec_zmax = 0
+
+ ib_right(:) = 0
+ ib_left(:) = 0
+ ib_bottom(:) = 0
+ ib_top(:) = 0
+
+ ! reads in absorbing edges
+ read(IIN,"(a80)") datlin
+
+ ! reads in values
+ if( anyabs ) then
+ ! reads absorbing boundaries
+ do inum = 1,nelemabs
+ read(IIN,*) numabsread,codeabsread(1),codeabsread(2),codeabsread(3),&
+ codeabsread(4), ibegin_bottom(inum), iend_bottom(inum), &
+ jbegin_right(inum), jend_right(inum), ibegin_top(inum), &
+ iend_top(inum), jbegin_left(inum), jend_left(inum)
+
+ if(numabsread < 1 .or. numabsread > nspec) &
+ call exit_MPI('Wrong absorbing element number')
+
+ 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
+
+ ! boundary element numbering
+ do inum = 1,nelemabs
+ if (codeabs(IBOTTOM,inum)) then
+ nspec_zmin = nspec_zmin + 1
+ ib_bottom(inum) = nspec_zmin
+ endif
+ if (codeabs(IRIGHT,inum)) then
+ nspec_xmax = nspec_xmax + 1
+ ib_right(inum) = nspec_xmax
+ endif
+ if (codeabs(ITOP,inum)) then
+ nspec_zmax = nspec_zmax + 1
+ ib_top(inum) = nspec_zmax
+ endif
+ if (codeabs(ILEFT,inum)) then
+ nspec_xmin = nspec_xmin + 1
+ ib_left(inum) = nspec_xmin
+ endif
+ enddo
+
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Number of absorbing elements: ',nelemabs
+ write(IOUT,*) ' nspec_xmin = ',nspec_xmin
+ write(IOUT,*) ' nspec_xmax = ',nspec_xmax
+ write(IOUT,*) ' nspec_zmin = ',nspec_zmin
+ write(IOUT,*) ' nspec_zmax = ',nspec_zmax
+ write(IOUT,*)
+ endif
+
+ endif
+
+ end subroutine read_databases_absorbing
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_free_surf(ipass,nelem_acoustic_surface,nspec, &
+ acoustic_edges,perm,antecedent_list,any_acoustic_edges)
+
+! reads acoustic free surface data
+
+ implicit none
+ include "constants.h"
+
+ integer :: ipass,nspec
+ integer :: nelem_acoustic_surface
+ integer, dimension(4,nelem_acoustic_surface) :: acoustic_edges
+ logical :: any_acoustic_edges
+
+ integer, dimension(nspec) :: perm,antecedent_list
+
+ ! local parameters
+ integer :: inum,acoustic_edges_read
+ character(len=80) :: datlin
+
+ ! initializes
+ acoustic_edges(:,:) = 0
+
+ ! reads in any possible free surface edges
+ read(IIN,"(a80)") datlin
+
+ if( any_acoustic_edges ) then
+ do inum = 1,nelem_acoustic_surface
+ read(IIN,*) acoustic_edges_read, acoustic_edges(2,inum), acoustic_edges(3,inum), &
+ acoustic_edges(4,inum)
+
+ 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
+
+ endif
+
+ end subroutine read_databases_free_surf
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_coupled(ipass,nspec,num_fluid_solid_edges,any_fluid_solid_edges, &
+ fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec, &
+ num_fluid_poro_edges,any_fluid_poro_edges, &
+ fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec, &
+ num_solid_poro_edges,any_solid_poro_edges, &
+ solid_poro_elastic_ispec,solid_poro_poroelastic_ispec, &
+ perm,antecedent_list)
+
+! reads acoustic elastic coupled edges
+! reads acoustic poroelastic coupled edges
+! reads poroelastic elastic coupled edges
+
+ implicit none
+ include "constants.h"
+
+ integer :: ipass,nspec
+
+ integer :: num_fluid_solid_edges
+ logical :: any_fluid_solid_edges
+ integer, dimension(num_fluid_solid_edges) :: fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec
+
+ integer :: num_fluid_poro_edges
+ logical :: any_fluid_poro_edges
+ integer, dimension(num_fluid_poro_edges) :: fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec
+
+ integer :: num_solid_poro_edges
+ logical :: any_solid_poro_edges
+ integer, dimension(num_solid_poro_edges) :: solid_poro_elastic_ispec,solid_poro_poroelastic_ispec
+
+ integer, dimension(nspec) :: perm,antecedent_list
+
+ ! local parameters
+ integer :: inum
+ integer :: fluid_solid_acoustic_ispec_read,fluid_solid_elastic_ispec_read, &
+ fluid_poro_acoustic_ispec_read,fluid_poro_poro_ispec_read, &
+ solid_poro_poro_ispec_read,solid_poro_elastic_ispec_read
+ character(len=80) :: datlin
+
+ ! initializes
+ fluid_solid_acoustic_ispec(:) = 0
+ fluid_solid_elastic_ispec(:) = 0
+ fluid_poro_acoustic_ispec(:) = 0
+ fluid_poro_poroelastic_ispec(:) = 0
+ solid_poro_elastic_ispec(:) = 0
+ solid_poro_poroelastic_ispec(:) = 0
+
+ ! reads acoustic elastic coupled edges
+ read(IIN,"(a80)") datlin
+
+ if ( any_fluid_solid_edges ) then
+ do inum = 1, num_fluid_solid_edges
+ 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
+ endif
+
+ ! reads acoustic poroelastic coupled edges
+ read(IIN,"(a80)") datlin
+
+ if ( any_fluid_poro_edges ) then
+ do inum = 1, num_fluid_poro_edges
+ read(IIN,*) fluid_poro_acoustic_ispec_read,fluid_poro_poro_ispec_read
+
+ if(ipass == 1) then
+ fluid_poro_acoustic_ispec(inum) = fluid_poro_acoustic_ispec_read
+ fluid_poro_poroelastic_ispec(inum) = fluid_poro_poro_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_poro_ispec_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+ enddo
+ endif
+
+ ! reads poroelastic elastic coupled edges
+ read(IIN,"(a80)") datlin
+
+ if ( any_solid_poro_edges ) then
+ do inum = 1, num_solid_poro_edges
+ read(IIN,*) solid_poro_poro_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_poro_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_poro_ispec_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+ enddo
+ endif
+
+ end subroutine read_databases_coupled
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_final(nnodes_tangential_curve,nodes_tangential_curve, &
+ force_normal_to_surface,rec_normal_to_surface, &
+ any_tangential_curve )
+
+! reads tangential detection curve
+! and closes Database file
+
+ implicit none
+ include "constants.h"
+
+ integer :: nnodes_tangential_curve
+ logical :: any_tangential_curve
+ double precision, dimension(2,nnodes_tangential_curve) :: nodes_tangential_curve
+
+ logical :: force_normal_to_surface,rec_normal_to_surface
+
+ ! local parameters
+ integer :: i
+ character(len=80) :: datlin
+
+ ! initializes
+ nodes_tangential_curve(:,:) = 0.d0
+
+ ! reads tangential detection curve
+ read(IIN,"(a80)") datlin
+ read(IIN,*) force_normal_to_surface,rec_normal_to_surface
+
+ if( any_tangential_curve ) then
+ 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.
+ endif
+
+ ! closes input Database file
+ close(IIN)
+
+ end subroutine read_databases_final
+
+
\ No newline at end of file
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/read_external_model.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/read_external_model.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/read_external_model.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/read_external_model.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,188 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine read_external_model(any_acoustic,any_elastic,any_poroelastic, &
+ elastic,poroelastic,anisotropic,nspec,npoin,N_SLS,ibool, &
+ f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
+ inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent, &
+ inv_tau_sigma_nu1,inv_tau_sigma_nu2,phi_nu1,phi_nu2,Mu_nu1,Mu_nu2,&
+ coord,kmato,myrank,rhoext,vpext,vsext, &
+ Qp_attenuationext,Qs_attenuationext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,READ_EXTERNAL_SEP_FILE)
+
+ implicit none
+ include "constants.h"
+
+ integer :: nspec,myrank,npoin
+ double precision :: f0_attenuation
+
+ ! Mesh
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ double precision, dimension(NDIM,npoin) :: coord
+
+ ! Material properties
+ logical :: any_acoustic,any_elastic,any_poroelastic,READ_EXTERNAL_SEP_FILE
+ integer, dimension(nspec) :: kmato
+ logical, dimension(nspec) :: elastic,poroelastic
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: rhoext,vpext,vsext
+
+ ! for attenuation
+ integer :: N_SLS
+ double precision :: Mu_nu1_sent,Mu_nu2_sent
+ double precision, dimension(N_SLS) :: inv_tau_sigma_nu1_sent,phi_nu1_sent, &
+ inv_tau_sigma_nu2_sent,phi_nu2_sent
+ 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
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Qp_attenuationext,Qs_attenuationext
+
+ ! for anisotropy
+ logical, dimension(nspec) :: anisotropic
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c13ext,c15ext,c33ext,c35ext,c55ext
+
+ ! Local variables
+ integer :: i,j,ispec,iglob
+ double precision :: previous_vsext
+ double precision :: tmp1, tmp2,tmp3
+
+ if(READ_EXTERNAL_SEP_FILE) then
+ write(IOUT,*)
+ write(IOUT,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+ write(IOUT,*) 'Assigning external velocity and density model (elastic (no attenuation) and/or acoustic)...'
+ write(IOUT,*) 'Read outside SEG model...'
+ write(IOUT,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+
+ open(unit=1001,file='DATA/model_velocity.dat_input',status='unknown')
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ read(1001,*) tmp1,tmp2,tmp3,rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec)
+ ! vsext(i,j,ispec)=0.0
+ ! Qp, Qs : dummy values. If attenuation needed than the "read" line and model_velocity.dat_input
+ ! need to be modified to provide Qp & Qs values
+ Qp_attenuationext(i,j,ispec) = 10.d0
+ Qs_attenuationext(i,j,ispec) = 10.d0
+ end do
+ end do
+ end do
+ close(1001)
+
+ else
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+ call define_external_model(coord(1,iglob),coord(2,iglob),kmato(ispec),myrank,&
+ rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec), &
+ Qp_attenuationext(i,j,ispec),Qs_attenuationext(i,j,ispec),&
+ c11ext(i,j,ispec),c13ext(i,j,ispec),c15ext(i,j,ispec), &
+ c33ext(i,j,ispec),c35ext(i,j,ispec),c55ext(i,j,ispec))
+
+ if((c11ext(i,j,ispec) /= 0) .or. (c13ext(i,j,ispec) /= 0) .or. (c15ext(i,j,ispec) /= 0) .or. &
+ (c33ext(i,j,ispec) /= 0) .or. (c35ext(i,j,ispec) /= 0) .or. (c55ext(i,j,ispec) /= 0)) then
+ ! vp, vs : dummy values, trick to avoid floating point errors
+ vpext(i,j,ispec) = 20.d0
+ vsext(i,j,ispec) = 10.d0
+ end if
+ end do
+ end do
+ end do
+ end if
+
+ ! initializes
+ any_acoustic = .false.
+ any_elastic = .false.
+ any_poroelastic = .false.
+
+ anisotropic(:) = .false.
+ elastic(:) = .false.
+ poroelastic(:) = .false.
+
+ do ispec = 1,nspec
+ previous_vsext = -1.d0
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ if(.not. (i == 1 .and. j == 1) .and. &
+ ((vsext(i,j,ispec) >= TINYVAL .and. previous_vsext < TINYVAL) .or. &
+ (vsext(i,j,ispec) < TINYVAL .and. previous_vsext >= TINYVAL))) &
+ call exit_MPI('external velocity model cannot be both fluid and solid inside the same spectral element')
+
+ if((c11ext(i,j,ispec) /= 0) .or. (c13ext(i,j,ispec) /= 0) .or. (c15ext(i,j,ispec) /= 0) .or. &
+ (c33ext(i,j,ispec) /= 0) .or. (c35ext(i,j,ispec) /= 0) .or. (c55ext(i,j,ispec) /= 0)) then
+ anisotropic(ispec) = .true.
+ poroelastic(ispec) = .false.
+ elastic(ispec) = .true.
+ any_elastic = .true.
+ Qp_attenuationext(i,j,ispec) = 10.d0
+ Qs_attenuationext(i,j,ispec) = 10.d0
+ elseif(vsext(i,j,ispec) < TINYVAL) then
+ elastic(ispec) = .false.
+ poroelastic(ispec) = .false.
+ any_acoustic = .true.
+ else
+ poroelastic(ispec) = .false.
+ elastic(ispec) = .true.
+ any_elastic = .true.
+ endif
+
+ call attenuation_model(N_SLS,Qp_attenuationext(i,j,ispec),Qs_attenuationext(i,j,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)
+ 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
+ previous_vsext = vsext(i,j,ispec)
+ enddo
+ enddo
+ enddo
+
+ end subroutine read_external_model
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/recompute_jacobian.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/recompute_jacobian.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/recompute_jacobian.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/recompute_jacobian.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,168 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! recompute 2D jacobian at a given point in a 4-node or 9-node element
+
+ subroutine recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian,coorg,knods,ispec,ngnod,nspec,npgeo, &
+ stop_if_negative_jacobian)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec,ngnod,nspec,npgeo
+ double precision x,z,xix,xiz,gammax,gammaz
+ double precision xi,gamma,jacobian
+
+ integer knods(ngnod,nspec)
+ double precision coorg(NDIM,npgeo)
+
+! 2D shape functions and their derivatives at receiver
+ double precision shape2D(ngnod)
+ double precision dershape2D(NDIM,ngnod)
+
+ double precision xxi,zxi,xgamma,zgamma,xelm,zelm
+
+ integer ia,nnum
+
+ logical stop_if_negative_jacobian
+
+! only one problematic element is output to OpenDX for now in case of elements with a negative Jacobian
+ integer, parameter :: ntotspecAVS_DX = 1
+
+! recompute jacobian for any (xi,gamma) point, not necessarily a GLL point
+
+! create the 2D shape functions and the Jacobian
+ call define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)
+
+! compute coordinates and jacobian matrix
+ x = ZERO
+ z = ZERO
+
+ xxi = ZERO
+ zxi = ZERO
+ xgamma = ZERO
+ zgamma = ZERO
+
+ do ia=1,ngnod
+
+ nnum = knods(ia,ispec)
+
+ xelm = coorg(1,nnum)
+ zelm = coorg(2,nnum)
+
+ x = x + shape2D(ia)*xelm
+ z = z + shape2D(ia)*zelm
+
+ xxi = xxi + dershape2D(1,ia)*xelm
+ zxi = zxi + dershape2D(1,ia)*zelm
+ xgamma = xgamma + dershape2D(2,ia)*xelm
+ zgamma = zgamma + dershape2D(2,ia)*zelm
+
+ enddo
+
+ jacobian = xxi*zgamma - xgamma*zxi
+
+! the Jacobian is negative, so far this means that there is an error in the mesh
+! therefore print the coordinates of the mesh points of this element
+! and also create an OpenDX file to visualize it
+ if(jacobian <= ZERO .and. stop_if_negative_jacobian) then
+
+! print the coordinates of the mesh points of this element
+ print *, 'ispec = ', ispec
+ print *, 'ngnod = ', ngnod
+ do ia=1,ngnod
+ nnum = knods(ia,ispec)
+ xelm = coorg(1,nnum)
+ zelm = coorg(2,nnum)
+ print *,'node ', ia,' x,y = ',xelm,zelm
+ enddo
+
+! create an OpenDX file to visualize this element
+ open(unit=11,file='DX_first_element_with_negative_jacobian.dx',status='unknown')
+
+! output the points (the mesh is flat therefore the third coordinate is zero)
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ngnod,' data follows'
+ do ia=1,ngnod
+ nnum = knods(ia,ispec)
+ xelm = coorg(1,nnum)
+ zelm = coorg(2,nnum)
+ write(11,*) xelm,zelm,' 0'
+ enddo
+
+! output the element (use its four corners only for now)
+ write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows'
+! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
+ write(11,*) '0 3 1 2'
+
+! output element data
+ write(11,*) 'attribute "element type" string "quads"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
+
+! output dummy data value
+ write(11,*) '1'
+
+! define OpenDX field
+ write(11,*) 'attribute "dep" string "connections"'
+ write(11,*) 'object "irregular positions irregular connections" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+
+! close OpenDX file
+ close(11)
+
+ call exit_MPI('negative 2D Jacobian, element saved in DX_first_element_with_negative_jacobian.dx')
+ endif
+
+! invert the relation
+ xix = zgamma / jacobian
+ gammax = - zxi / jacobian
+ xiz = - xgamma / jacobian
+ gammaz = xxi / jacobian
+
+ end subroutine recompute_jacobian
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/save_openDX_jacobian.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/save_openDX_jacobian.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/save_openDX_jacobian.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/save_openDX_jacobian.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,155 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine save_openDX_jacobian(nspec,npgeo,ngnod,knods,coorg,xigll,zigll)
+
+ implicit none
+ include "constants.h"
+
+ integer :: nspec,npgeo,ngnod
+ double precision, dimension(NDIM,npgeo) :: coorg
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ integer, dimension(ngnod,nspec) :: knods
+
+ ! local parameters
+ integer, dimension(:), allocatable :: ibool_OpenDX
+ logical, dimension(:), allocatable :: mask_point
+ double precision :: xelm,zelm
+ double precision :: xi,gamma,x,z
+ double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+ integer :: ia,nnum,ipoint_number,total_of_negative_elements
+ integer :: ispec,i,j
+ logical :: found_a_problem_in_this_element
+
+ ! create an OpenDX file to visualize this element
+ open(unit=11,file='DX_all_elements_with_negative_jacobian_in_red.dx',status='unknown')
+
+ ! output all the points (i.e. all the control points of the mesh)
+ ! the mesh is flat therefore the third coordinate is zero
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',npgeo,' data follows'
+ ipoint_number = 0
+ allocate(mask_point(npgeo))
+ allocate(ibool_OpenDX(npgeo))
+ mask_point(:) = .false.
+ do ispec = 1,nspec
+ do ia=1,ngnod
+ nnum = knods(ia,ispec)
+ xelm = coorg(1,nnum)
+ zelm = coorg(2,nnum)
+ if(.not. mask_point(knods(ia,ispec))) then
+ mask_point(knods(ia,ispec)) = .true.
+ ibool_OpenDX(knods(ia,ispec)) = ipoint_number
+ write(11,*) xelm,zelm,' 0'
+ ipoint_number = ipoint_number + 1
+ endif
+ enddo
+ enddo
+ deallocate(mask_point)
+
+ ! output all the elements of the mesh (use their four corners only in OpenDX
+ write(11,*) 'object 2 class array type int rank 1 shape 4 items ',nspec,' data follows'
+ ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
+ do ispec = 1,nspec
+ write(11,*) ibool_OpenDX(knods(1,ispec)),ibool_OpenDX(knods(4,ispec)), &
+ ibool_OpenDX(knods(2,ispec)),ibool_OpenDX(knods(3,ispec))
+ enddo
+ deallocate(ibool_OpenDX)
+
+ ! output element data
+ write(11,*) 'attribute "element type" string "quads"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items ',nspec,' data follows'
+
+ ! output all the element data (value = 1 if positive Jacobian, = 2 if negative Jacobian)
+ total_of_negative_elements = 0
+ do ispec = 1,nspec
+
+ ! check if this element has a negative Jacobian at any of its points
+ found_a_problem_in_this_element = .false.
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ xi = xigll(i)
+ gamma = zigll(j)
+
+ call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
+ jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
+ .false.)
+
+ if(jacobianl <= ZERO) found_a_problem_in_this_element = .true.
+ enddo
+ enddo
+
+ ! output data value
+ if(found_a_problem_in_this_element) then
+ write(11,*) '2'
+ print *,'element ',ispec,' has a negative Jacobian'
+ total_of_negative_elements = total_of_negative_elements + 1
+ else
+ write(11,*) '1'
+ endif
+
+ enddo
+
+ ! define OpenDX field
+ write(11,*) 'attribute "dep" string "connections"'
+ write(11,*) 'object "irregular positions irregular connections" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+
+ ! close OpenDX file
+ close(11)
+
+ print *
+ print *,total_of_negative_elements,' elements have a negative Jacobian, out of ',nspec
+ print *,'i.e., ',sngl(100.d0 * dble(total_of_negative_elements)/dble(nspec)),'%'
+ print *
+
+ end subroutine save_openDX_jacobian
\ No newline at end of file
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/set_sources.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/set_sources.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/set_sources.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/set_sources.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,252 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine set_sources(myrank,NSOURCES,source_type,time_function_type, &
+ x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce,aval, &
+ t0,initialfield,ipass,deltat)
+
+! gets source parameters
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank
+ integer :: NSOURCES
+ integer, dimension(NSOURCES) :: source_type,time_function_type
+ double precision, dimension(NSOURCES) :: x_source,z_source, &
+ Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
+ double precision, dimension(NSOURCES) :: aval
+ double precision :: t0
+ double precision :: deltat
+ integer :: ipass
+ logical :: initialfield
+
+ ! local parameters
+ integer :: i_source
+ double precision, dimension(NSOURCES) :: t0_source,hdur
+ double precision :: min_tshift_src_original
+
+ ! checks the input
+ do i_source=1,NSOURCES
+
+ ! checks source type
+ if(.not. initialfield) then
+ if (source_type(i_source) == 1) then
+ if ( myrank == 0 .and. ipass == 1 ) then
+ ! user output
+ write(IOUT,212) x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
+ factor(i_source),angleforce(i_source)
+ endif
+ else if(source_type(i_source) == 2) then
+ if ( myrank == 0 .and. ipass == 1 ) then
+ ! user output
+ write(IOUT,222) x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
+ factor(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
+ endif
+ else
+ 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
+ if(time_function_type(i_source) == 4 .or. time_function_type(i_source) == 5) &
+ f0(i_source) = 1.d0 / (10.d0 * deltat)
+
+ ! checks source frequency
+ if( abs(f0(i_source)) < TINYVAL ) then
+ call exit_MPI('Error source frequency is zero')
+ endif
+
+ ! half-duration of source
+ hdur(i_source) = 1.d0 / f0(i_source)
+
+ ! sets source start times, shifted by the given (non-zero) time-shift
+ if(time_function_type(i_source)== 5) then
+ t0_source(i_source) = 2.0d0 * hdur(i_source) + tshift_src(i_source)
+ else
+ t0_source(i_source) = 1.20d0 * hdur(i_source) + tshift_src(i_source)
+ 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 ! do i_source=1,NSOURCES
+
+ ! initializes simulation start time
+ if( NSOURCES == 1 ) then
+ ! simulation start time
+ t0 = t0_source(1)
+ ! sets source time shift relative to simulation start time
+ min_tshift_src_original = tshift_src(1)
+ tshift_src(1) = 0.d0
+ else
+ ! starts with earliest start time
+ t0 = minval( t0_source(:) )
+ ! sets source time shifts relative to simulation start time
+ min_tshift_src_original = minval( tshift_src(:) )
+ tshift_src(:) = t0_source(:) - t0
+ endif
+
+ ! checks if user set USER_T0 to fix simulation start time
+ ! note: USER_T0 has to be positive
+ if( USER_T0 > 0.d0 ) then
+ ! user cares about origin time and time shifts of the CMTSOLUTION
+ ! and wants to fix simulation start time to a constant start time
+ ! time 0 on time axis will correspond to given origin time
+
+ ! notifies user
+ if( myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) ' using USER_T0 . . . . . . . . . = ',USER_T0
+ write(IOUT,*) ' original t0 . . . . . . . . . = ',t0
+ write(IOUT,*) ' min_tshift_src_original . . . = ',min_tshift_src_original
+ write(IOUT,*)
+ endif
+
+ ! checks if automatically set t0 is too small
+ ! note: times in seismograms are shifted by t0(1)
+ if( t0 <= USER_T0 + min_tshift_src_original ) then
+
+ ! sets new simulation start time such that
+ ! simulation starts at t = - t0 = - USER_T0
+ t0 = USER_T0
+
+ ! notifies user
+ if( myrank == 0 .and. ipass == 1) then
+ write(IOUT,*) ' fix new simulation start time . = ', - t0
+ endif
+
+ ! loops over all sources
+ do i_source=1,NSOURCES
+ ! sets the given, initial time shifts
+ if( time_function_type(i_source) == 5 ) then
+ tshift_src(i_source) = t0_source(i_source) - 2.0d0 * hdur(i_source)
+ else
+ tshift_src(i_source) = t0_source(i_source) - 1.20d0 * hdur(i_source)
+ endif
+ ! user output
+ if( myrank == 0 .and. ipass == 1) then
+ write(IOUT,*) ' source ',i_source,'uses tshift = ',tshift_src(i_source)
+ endif
+ enddo
+ ! user output
+ if( myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ endif
+
+ else
+ ! start time needs to be at least t0 for numerical stability
+ ! notifies user
+ if( myrank == 0 .and. ipass == 1) then
+ write(IOUT,*) 'error: USER_T0 is too small'
+ write(IOUT,*) ' must make one of three adjustements:'
+ write(IOUT,*) ' - increase USER_T0 to be at least: ',t0
+ write(IOUT,*) ' - decrease time shift tshift_src in SOURCE file'
+ write(IOUT,*) ' - increase frequency f0 in SOURCE file'
+ endif
+ call exit_MPI('error USER_T0 is set but too small')
+ endif
+ else if( USER_T0 < 0.d0 ) then
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) 'error: USER_T0 is negative, must be set zero or positive!'
+ endif
+ call exit_MPI('error negative USER_T0 parameter in constants.h')
+ endif
+
+ ! checks onset times
+ if(.not. initialfield) then
+
+ ! loops over sources
+ do i_source = 1,NSOURCES
+
+ ! excludes Dirac and Heaviside sources
+ if(time_function_type(i_source) /= 4 .and. time_function_type(i_source) /= 5) then
+
+ ! user output
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) ' Onset time. . . . . . = ',t0+tshift_src(i_source)
+ write(IOUT,*) ' Fundamental period. . = ',1.d0/f0(i_source)
+ write(IOUT,*) ' Fundamental frequency = ',f0(i_source)
+ endif
+
+ ! checks source onset time
+ if( t0+tshift_src(i_source) <= 1.d0/f0(i_source)) then
+ call exit_MPI('Onset time too small')
+ else
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) ' --> onset time ok'
+ endif
+ endif
+ endif
+ enddo
+
+ endif
+
+
+ ! output formats
+212 format(//,5x,'Source Type. . . . . . . . . . . . . . = Collocated Force',/5x, &
+ 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
+ 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Angle from vertical direction (deg). . =',1pe20.10,/5x)
+
+222 format(//,5x,'Source Type. . . . . . . . . . . . . . = Moment-tensor',/5x, &
+ 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
+ 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Mxx. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Mzz. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Mxz. . . . . . . . . . . . . . . . . . =',1pe20.10)
+
+ end subroutine set_sources
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/setup_sources_receivers.f90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/setup_sources_receivers.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/setup_sources_receivers.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/setup_sources_receivers.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,170 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine setup_sources_receivers(NSOURCES,initialfield,source_type,&
+ coord,ibool,npoin,nspec,nelem_acoustic_surface,acoustic_surface,elastic,poroelastic, &
+ x_source,z_source,ispec_selected_source,ispec_selected_rec, &
+ is_proc_source,nb_proc_source,ipass,&
+ sourcearray,Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,npgeo,&
+ nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod, &
+ nrec,nrecloc,recloc,which_proc_receiver,st_xval,st_zval, &
+ xi_receiver,gamma_receiver,station_name,network_name,x_final_receiver,z_final_receiver,iglob_source)
+
+ implicit none
+
+ include "constants.h"
+
+ logical :: initialfield
+ integer :: NSOURCES
+ integer :: npgeo,ngnod,myrank,ipass,nproc
+ integer :: npoin,nspec,nelem_acoustic_surface
+
+ ! Gauss-Lobatto-Legendre points
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ ! for receivers
+ integer :: nrec,nrecloc
+ integer, dimension(nrec) :: recloc, which_proc_receiver
+ integer, dimension(nrec) :: ispec_selected_rec
+ double precision, dimension(nrec) :: xi_receiver,gamma_receiver,st_xval,st_zval
+ double precision, dimension(nrec) :: x_final_receiver, z_final_receiver
+
+ ! timing information for the stations
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ ! for sources
+ integer, dimension(NSOURCES) :: source_type
+ integer, dimension(NSOURCES) :: ispec_selected_source,is_proc_source,nb_proc_source,iglob_source
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
+ double precision, dimension(NSOURCES) :: x_source,z_source,xi_source,gamma_source,Mxx,Mzz,Mxz
+
+ logical, dimension(nspec) :: elastic,poroelastic
+ integer, dimension(ngnod,nspec) :: knods
+ integer, dimension(5,nelem_acoustic_surface) :: acoustic_surface
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+ double precision, dimension(NDIM,npgeo) :: coorg
+ double precision, dimension(NDIM,npoin) :: coord
+
+ integer :: ixmin, ixmax, izmin, izmax
+
+ ! Local variables
+ integer i_source,ispec,ispec_acoustic_surface
+
+ do i_source=1,NSOURCES
+
+ if(source_type(i_source) == 1) then
+
+ ! collocated force source
+ call locate_source_force(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,ipass,&
+ iglob_source(i_source))
+
+ ! check that acoustic source is not exactly on the free surface because pressure is zero there
+ if(is_proc_source(i_source) == 1) then
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+ ispec = acoustic_surface(1,ispec_acoustic_surface)
+ ixmin = acoustic_surface(2,ispec_acoustic_surface)
+ ixmax = acoustic_surface(3,ispec_acoustic_surface)
+ izmin = acoustic_surface(4,ispec_acoustic_surface)
+ izmax = acoustic_surface(5,ispec_acoustic_surface)
+ if( .not. elastic(ispec) .and. .not. poroelastic(ispec) .and. &
+ ispec == ispec_selected_source(i_source) ) then
+ if ( (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==NGLLX .and. &
+ gamma_source(i_source) < -0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==NGLLX .and. &
+ gamma_source(i_source) > 0.99d0) .or.&
+ (izmin==1 .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
+ xi_source(i_source) < -0.99d0) .or.&
+ (izmin==1 .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ xi_source(i_source) > 0.99d0) .or.&
+ (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==1 .and. &
+ gamma_source(i_source) < -0.99d0 .and. xi_source(i_source) < -0.99d0) .or.&
+ (izmin==1 .and. izmax==1 .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ gamma_source(i_source) < -0.99d0 .and. xi_source(i_source) > 0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
+ gamma_source(i_source) > 0.99d0 .and. xi_source(i_source) < -0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ gamma_source(i_source) > 0.99d0 .and. xi_source(i_source) > 0.99d0) ) then
+ call exit_MPI('an acoustic source cannot be located exactly '// &
+ 'on the free surface because pressure is zero there')
+ endif
+ endif
+ enddo
+ endif
+
+ 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,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)
+
+ else if(.not.initialfield) then
+
+ call exit_MPI('incorrect source type')
+
+ endif
+
+ enddo ! do i_source=1,NSOURCES
+
+ ! 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(1),z_source(1), &
+ coorg,knods,ngnod,npgeo,ipass, &
+ x_final_receiver,z_final_receiver)
+
+ end subroutine setup_sources_receivers
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/sort_array_coordinates.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/sort_array_coordinates.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/sort_array_coordinates.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/sort_array_coordinates.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,241 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+#ifdef USE_MPI
+
+! subroutines to sort MPI buffers to assemble between chunks
+
+ subroutine sort_array_coordinates(npointot,x,z,ibool,iglob,loc,ifseg, &
+ nglob,ind,ninseg,iwork,work)
+
+! this routine MUST be in double precision to avoid sensitivity
+! to roundoff errors in the coordinates of the points
+!
+! returns: sorted indexing array (ibool), reordering array (iglob) & number of global points (nglob)
+
+ implicit none
+
+ include "constants.h"
+
+ integer,intent(in) :: npointot
+ integer,intent(out) :: nglob
+
+ integer,intent(inout) :: ibool(npointot)
+
+ integer iglob(npointot),loc(npointot)
+ integer ind(npointot),ninseg(npointot)
+ logical ifseg(npointot)
+ double precision,intent(in) :: x(npointot),z(npointot)
+ integer iwork(npointot)
+ double precision work(npointot)
+
+ ! local parameters
+ integer ipoin,i,j
+ integer nseg,ioff,iseg,ig
+ ! define a tolerance, normalized radius is 1., so let's use a small value
+ double precision,parameter :: xtol = SMALLVALTOL
+
+ ! establish initial pointers
+ do ipoin=1,npointot
+ loc(ipoin)=ipoin
+ enddo
+
+ ifseg(:)=.false.
+
+ nseg=1
+ ifseg(1)=.true.
+ ninseg(1)=npointot
+
+ do j=1,NDIM
+
+ ! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+
+ if(j == 1) then
+ call rank_buffers(x(ioff),ind,ninseg(iseg))
+ else if(j == 2) then
+ call rank_buffers(z(ioff),ind,ninseg(iseg))
+ endif
+
+ call swap_all_buffers(ibool(ioff),loc(ioff), &
+ x(ioff),z(ioff),iwork,work,ind,ninseg(iseg))
+
+ ioff=ioff+ninseg(iseg)
+ enddo
+
+ ! check for jumps in current coordinate
+ if(j == 1) then
+ do i=2,npointot
+ if(dabs(x(i)-x(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else if(j == 2) then
+ do i=2,npointot
+ if(dabs(z(i)-z(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ endif
+
+ ! count up number of different segments
+ nseg=0
+ do i=1,npointot
+ if(ifseg(i)) then
+ nseg=nseg+1
+ ninseg(nseg)=1
+ else
+ ninseg(nseg)=ninseg(nseg)+1
+ endif
+ enddo
+ enddo
+
+ ! assign global node numbers (now sorted lexicographically)
+ ig=0
+ do i=1,npointot
+ if(ifseg(i)) ig=ig+1
+ iglob(loc(i))=ig
+ enddo
+
+ nglob=ig
+
+ end subroutine sort_array_coordinates
+
+! -------------------- library for sorting routine ------------------
+
+! sorting routines put here in same file to allow for inlining
+
+ subroutine rank_buffers(A,IND,N)
+!
+! Use Heap Sort (Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(n)
+ integer IND(n)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do j=1,n
+ IND(j)=j
+ enddo
+
+ if(n == 1) return
+
+ L=n/2+1
+ ir=n
+ 100 CONTINUE
+ IF(l>1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 CONTINUE
+ IF(J <= IR) THEN
+ IF(J < IR) THEN
+ IF(A(IND(j)) < A(IND(j+1))) j=j+1
+ ENDIF
+ IF (q < A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ goto 200
+ ENDIF
+ IND(I)=INDX
+ goto 100
+ end subroutine rank_buffers
+
+! -------------------------------------------------------------------
+
+ subroutine swap_all_buffers(IA,IB,A,B,IW,W,ind,n)
+!
+! swap arrays IA, IB, A and B according to addressing in array IND
+!
+ implicit none
+
+ integer n
+
+ integer IND(n)
+ integer IA(n),IB(n),IW(n)
+ double precision A(n),B(n),W(n)
+
+ integer i
+
+ do i=1,n
+ W(i)=A(i)
+ IW(i)=IA(i)
+ enddo
+
+ do i=1,n
+ A(i)=W(ind(i))
+ IA(i)=IW(ind(i))
+ enddo
+
+ do i=1,n
+ W(i)=B(i)
+ IW(i)=IB(i)
+ enddo
+
+ do i=1,n
+ B(i)=W(ind(i))
+ IB(i)=IW(ind(i))
+ enddo
+
+ end subroutine swap_all_buffers
+
+#endif
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/specfem2D.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/specfem2D.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/specfem2D.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/specfem2D.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,6863 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!====================================================================================
+!
+! An explicit 2D parallel MPI spectral element solver
+! for the anelastic anisotropic or poroelastic wave equation.
+!
+!====================================================================================
+
+! If you use this code for your own research, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{VaCaSaKoVi99,
+! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
+! D. Komatitsch and J. P. Vilotte},
+! title = {Elastic wave propagation in an irregularly layered medium},
+! journal = {Soil Dynamics and Earthquake Engineering},
+! year = {1999},
+! volume = {18},
+! pages = {11-18},
+! number = {1},
+! doi = {10.1016/S0267-7261(98)00027-X}}
+!
+! @ARTICLE{LeChKoHuTr09,
+! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
+! Shouh Huang and Jeroen Tromp},
+! title = {Effects of realistic surface topography on seismic ground motion
+! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
+! method and {LiDAR DTM}},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2009},
+! volume = {99},
+! pages = {681-693},
+! number = {2A},
+! doi = {10.1785/0120080264}}
+!
+! @ARTICLE{LeChLiKoHuTr08,
+! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
+! and Bor Shouh Huang and Jeroen Tromp},
+! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
+! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2008},
+! volume = {98},
+! pages = {253-264},
+! number = {1},
+! doi = {10.1785/0120070033}}
+!
+! @ARTICLE{LeKoHuTr09,
+! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
+! title = {Effects of topography on seismic wave propagation: An example from
+! northern {T}aiwan},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2009},
+! volume = {99},
+! pages = {314-325},
+! number = {1},
+! doi = {10.1785/0120080020}}
+!
+! @ARTICLE{KoErGoMi10,
+! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
+! David Mich\'ea},
+! title = {High-order finite-element seismic wave propagation modeling with
+! {MPI} on a large {GPU} cluster},
+! journal = {J. Comput. Phys.},
+! year = {2010},
+! volume = {229},
+! pages = {7692-7714},
+! number = {20},
+! doi = {10.1016/j.jcp.2010.06.024}}
+!
+! @ARTICLE{KoGoErMi10,
+! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
+! David Mich\'ea},
+! title = {Modeling the propagation of elastic waves using spectral elements
+! on a cluster of 192 {GPU}s},
+! journal = {Computer Science Research and Development},
+! year = {2010},
+! volume = {25},
+! pages = {75-82},
+! number = {1-2},
+! doi = {10.1007/s00450-010-0109-1}}
+!
+! @ARTICLE{KoMiEr09,
+! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
+! title = {Porting a high-order finite-element earthquake modeling application
+! to {NVIDIA} graphics cards using {CUDA}},
+! journal = {Journal of Parallel and Distributed Computing},
+! year = {2009},
+! volume = {69},
+! pages = {451-460},
+! number = {5},
+! doi = {10.1016/j.jpdc.2009.01.006}}
+!
+! @ARTICLE{LiPoKoTr04,
+! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
+! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
+! journal={Bull. Seismol. Soc. Am.},
+! year = {2004},
+! volume = {94},
+! pages = {1748-1761},
+! number = {5},
+! doi = {10.1785/012004038}}
+!
+! @INCOLLECTION{ChKoViCaVaFe07,
+! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
+! Yann Capdeville and Bernard Valette and Gaetano Festa},
+! title = {Spectral Element Analysis in Seismology},
+! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
+! publisher = {Elsevier - Academic Press},
+! year = {2007},
+! editor = {Ru-Shan Wu and Val\'erie Maupin},
+! volume = {48},
+! series = {Advances in Geophysics},
+! pages = {365-419}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoLiTrSuStSh04,
+! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
+! and Christiane Stidham and John H. Shaw},
+! year=2004,
+! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
+! based upon the Spectral-Element Method},
+! journal={Bull. Seism. Soc. Am.},
+! volume=94,
+! number=1,
+! pages={187-206}}
+!
+! @ARTICLE{MoTr08,
+! author={C. Morency and J. Tromp},
+! title={Spectral-element simulations of wave propagation in poroelastic media},
+! journal={Geophys. J. Int.},
+! year=2008,
+! volume=175,
+! pages={301-345}}
+!
+! and/or other articles from http://web.univ-pau.fr/~dkomati1/publications.html
+!
+! If you use the kernel capabilities of the code, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! @ARTICLE{MoLuTr09,
+! author={C. Morency and Y. Luo and J. Tromp},
+! title={Finite-frequency kernels for wave propagation in porous media based upon adjoint methods},
+! year=2009,
+! journal={Geophys. J. Int.},
+! doi={10.1111/j.1365-246X.2009.04332}}
+!
+! If you use the METIS / SCOTCH / CUBIT non-structured capabilities, please also cite:
+!
+! @ARTICLE{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},
+! journal = {Lecture Notes in Computer Science},
+! year = {2008},
+! volume = {5336},
+! pages = {350-363}}
+!
+! version 6.1, Christina Morency and Pieyre Le Loher, March 2010:
+! - added SH (membrane) waves calculation for elastic media
+! - added support for external fully anisotropic media
+! - fixed some bugs in acoustic kernels
+!
+! version 6.0, Christina Morency and Yang Luo, August 2009:
+! - support for poroelastic media
+! - adjoint method for acoustic/elastic/poroelastic
+!
+! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, February 2008:
+! - support for CUBIT and GiD meshes
+! - 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)
+! - merged loops in the solver for efficiency
+! - simplified input of external model
+! - added CPU time information
+! - translated many comments from French to English
+!
+! version 5.1, Dimitri Komatitsch, January 2005:
+! - more general mesher with any number of curved layers
+! - Dirac and Gaussian time sources and corresponding convolution routine
+! - option for acoustic medium instead of elastic
+! - receivers at any location, not only grid points
+! - moment-tensor source at any location, not only a grid point
+! - color snapshots
+! - more flexible DATA/Par_file with any number of comment lines
+! - Xsu scripts for seismograms
+! - subtract t0 from seismograms
+! - seismograms and snapshots in pressure in addition to vector field
+!
+! version 5.0, Dimitri Komatitsch, May 2004:
+! - got rid of useless routines, suppressed commons etc.
+! - weak formulation based explicitly on stress tensor
+! - implementation of full anisotropy
+! - implementation of attenuation based on memory variables
+!
+! based on SPECFEM2D version 4.2, June 1998
+! (c) by Dimitri Komatitsch, Harvard University, USA
+! and Jean-Pierre Vilotte, Institut de Physique du Globe de Paris, France
+!
+! itself based on SPECFEM2D version 1.0, 1995
+! (c) by Dimitri Komatitsch and Jean-Pierre Vilotte,
+! Institut de Physique du Globe de Paris, France
+!
+
+! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
+! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
+! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement is then: u = grad(Chi) / rho
+! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+! The source in an acoustic element is a pressure source.
+! First-order acoustic-acoustic discontinuities are also handled automatically
+! because pressure is continuous at such an interface, therefore Chi_dot_dot
+! is continuous, therefore Chi is also continuous, which is consistent with
+! the spectral-element basis functions and with the assembling process.
+! This is the reason why a simple displacement potential u = grad(Chi) would
+! not work because it would be discontinuous at such an interface and would
+! therefore not be consistent with the basis functions.
+
+ program specfem2D
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+! character(len=80) datlin
+
+ integer NSOURCES,i_source
+ integer, dimension(:), allocatable :: source_type,time_function_type
+ double precision, dimension(:), allocatable :: x_source,z_source,xi_source,gamma_source,&
+ Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: sourcearray
+ double precision :: t0
+
+ double precision, dimension(:,:), allocatable :: coorg
+
+! for P-SV or SH (membrane) waves calculation
+ logical :: p_sv
+
+! receiver information
+ integer :: nrec,ios
+ integer, dimension(:), allocatable :: ispec_selected_rec
+ double precision, dimension(:), allocatable :: xi_receiver,gamma_receiver,st_xval,st_zval
+ character(len=150) dummystring
+
+! for seismograms
+ double precision, dimension(:,:), allocatable :: sisux,sisuz,siscurl
+ integer :: seismo_offset, seismo_current
+
+! vector field in an element
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
+
+! pressure in an element
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
+
+! curl in an element
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
+
+ integer :: i,j,k,it,irec,id,n,ispec,npoin,npgeo,iglob
+ integer :: npoin_acoustic
+ integer :: npoin_elastic
+ integer :: npoin_poroelastic
+ logical :: anyabs
+ double precision :: dxd,dyd,dzd,dcurld,valux,valuy,valuz,valcurl,hlagrange,rhol,xi,gamma,x,z
+
+! coefficients of the explicit Newmark time scheme
+ integer NSTEP
+ double precision :: deltatover2,deltatsquareover2,time
+ double precision :: deltat
+
+! Gauss-Lobatto-Legendre points and weights
+ double precision, dimension(NGLLX) :: xigll
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ double precision, dimension(NGLLZ) :: zigll
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wzgll
+
+! 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
+
+! Jacobian matrix and determinant
+ double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the elastic medium
+ 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
+
+! material properties of the poroelastic medium (solid phase:s and fluid phase [defined as w=phi(u_f-u_s)]: w)
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ accels_poroelastic,velocs_poroelastic,displs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ accelw_poroelastic,velocw_poroelastic,displw_poroelastic
+ double precision, dimension(:), allocatable :: porosity,tortuosity
+ double precision, dimension(:,:), allocatable :: density,permeability
+
+! poroelastic and elastic coefficients
+ double precision, dimension(:,:,:), allocatable :: poroelastcoef
+
+! anisotropy parameters
+ logical :: all_anisotropic
+ double precision :: c11,c13,c15,c33,c35,c55
+ logical, dimension(:), allocatable :: anisotropic
+ double precision, dimension(:,:), allocatable :: anisotropy
+
+! 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
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: 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
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,B_biot,cpIsquare,cpIIsquare,cssquare
+ real(kind=CUSTOM_REAL) :: ratio,dd1
+
+ double precision, dimension(:,:,:), allocatable :: vpext,vsext,rhoext
+ double precision, dimension(:,:,:), allocatable :: Qp_attenuationext,Qs_attenuationext
+ double precision, dimension(:,:,:), allocatable :: c11ext,c13ext,c15ext,c33ext,c35ext,c55ext
+
+ 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,ibool_outer,ibool_inner
+ integer, dimension(:,:), allocatable :: knods
+ integer, dimension(:), allocatable :: kmato,numabs, &
+ ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
+
+ integer, dimension(:), allocatable :: ispec_selected_source,iglob_source,&
+ is_proc_source,nb_proc_source
+ 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,UPPER_LIMIT_DISPLAY
+
+ logical interpol,meshvect,modelvect,boundvect,assign_external_model,initialfield, &
+ outputgrid,gnuplot,TURN_ATTENUATION_ON,output_postscript_snapshot,output_color_image, &
+ plot_lowerleft_corner_only,add_Bielak_conditions,OUTPUT_ENERGY,READ_EXTERNAL_SEP_FILE
+
+ double precision :: cutsnaps,sizemax_arrows,anglerec,xirec,gammarec
+
+! for absorbing and acoustic free surface conditions
+ integer :: ispec_acoustic_surface,inum
+ real(kind=CUSTOM_REAL) :: nx,nz,weight,xxi,zgamma
+
+ logical, dimension(:,:), allocatable :: codeabs
+
+! for attenuation
+ integer :: N_SLS
+ 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, 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
+
+! for viscous attenuation
+ double precision, dimension(:,:,:), allocatable :: &
+ rx_viscous,rz_viscous,viscox,viscoz
+ double precision :: theta_e,theta_s
+ double precision :: Q0,freq0
+ double precision :: alphaval,betaval,gammaval,thetainv
+ logical :: TURN_VISCATTENUATION_ON
+ double precision, dimension(NGLLX,NGLLZ) :: viscox_loc,viscoz_loc
+ double precision :: Sn,Snp1,etal_f
+ double precision, dimension(3):: bl_relaxed
+ double precision :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
+! adjoint
+ double precision, dimension(:), allocatable :: b_viscodampx,b_viscodampz
+ integer reclen
+
+! for fluid/solid coupling and edge detection
+ logical, dimension(:), allocatable :: elastic
+ integer, dimension(NEDGES) :: i_begin,j_begin,i_end,j_end
+ 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 :: num_fluid_solid_edges,ispec_acoustic,ispec_elastic, &
+ iedge_acoustic,iedge_elastic,ipoin1D,iglob2
+ logical :: any_acoustic,any_acoustic_glob,any_elastic,any_elastic_glob,coupled_acoustic_elastic
+ real(kind=CUSTOM_REAL) :: displ_x,displ_z,displ_n,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
+ logical :: any_fluid_solid_edges
+
+! for fluid/porous medium coupling and edge detection
+ logical, dimension(:), allocatable :: poroelastic
+ logical :: any_poroelastic,any_poroelastic_glob
+ integer, dimension(:), allocatable :: fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge, &
+ fluid_poro_poroelastic_ispec,fluid_poro_poroelastic_iedge
+ integer :: num_fluid_poro_edges,iedge_poroelastic
+ logical :: coupled_acoustic_poro
+ double precision :: mul_G,lambdal_G,lambdalplus2mul_G
+ double precision :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ double precision :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ double precision :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ double precision :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
+ double precision :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
+ double precision :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
+ double precision :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
+ double precision :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
+ logical :: any_fluid_poro_edges
+
+! for solid/porous medium coupling and edge detection
+ integer, dimension(:), allocatable :: solid_poro_elastic_ispec,solid_poro_elastic_iedge, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge
+ integer :: num_solid_poro_edges,ispec_poroelastic,ii2,jj2
+ logical :: coupled_elastic_poro
+ integer, dimension(:), allocatable :: icount
+ double precision :: sigma_xx,sigma_xz,sigma_zz,sigmap
+ double precision :: b_sigma_xx,b_sigma_xz,b_sigma_zz,b_sigmap
+ integer, dimension(:), allocatable :: ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,&
+ iend_top_poro,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro
+ logical :: any_solid_poro_edges
+
+! for adjoint method
+ logical :: SAVE_FORWARD ! whether or not the last frame is saved to reconstruct the forward field
+ integer :: SIMULATION_TYPE ! 1 = forward wavefield, 2 = backward and adjoint wavefields and kernels
+ double precision :: b_deltatover2,b_deltatsquareover2,b_deltat ! coefficients of the explicit Newmark time scheme
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accels_poroelastic,b_velocs_poroelastic,b_displs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accelw_poroelastic,b_velocw_poroelastic,b_displw_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accel_elastic,b_veloc_elastic,b_displ_elastic
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_potential_dot_dot_acoustic,b_potential_dot_acoustic,b_potential_acoustic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_ac,b_displ_ac,b_accel_ac
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rho_kl, mu_kl, kappa_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_global, mul_global, kappal_global
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: mu_k, kappa_k,rho_k
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhop_kl, beta_kl, alpha_kl
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rho_ac_kl, kappa_ac_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_ac_global, kappal_ac_global
+ 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
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhot_k, rhof_k, sm_k, eta_k, mufr_k, B_k, &
+ C_k, M_k
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: phil_global,etal_f_global,rhol_s_global,rhol_f_global,rhol_bar_global, &
+ tortl_global,mulfr_global
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: permlxx_global,permlxz_global,permlzz_global
+ character(len=150) :: adj_source_file
+ integer :: irec_local,nadj_rec_local
+ double precision :: xx,zz,rholb,tempx1l,tempx2l,b_tempx1l,b_tempx2l,bb_tempx1l,bb_tempx2l
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: adj_sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_left,b_absorb_poro_s_left,b_absorb_poro_w_left
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_right,b_absorb_poro_s_right,b_absorb_poro_w_right
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_bottom,b_absorb_poro_s_bottom,b_absorb_poro_w_bottom
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_top,b_absorb_poro_s_top,b_absorb_poro_w_top
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_absorb_acoustic_left,b_absorb_acoustic_right,&
+ b_absorb_acoustic_bottom, b_absorb_acoustic_top
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(:), allocatable :: ib_left,ib_right,ib_bottom,ib_top
+
+! for color images
+ integer :: NX_IMAGE_color,NZ_IMAGE_color
+ double precision :: xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image
+ integer, dimension(:,:), allocatable :: iglob_image_color,copy_iglob_image_color
+ double precision, dimension(:,:), allocatable :: image_color_data
+ double precision, dimension(:,:), allocatable :: image_color_vp_display
+ integer :: nb_pixel_loc
+ integer, dimension(:), allocatable :: num_pixel_loc
+
+#ifdef USE_MPI
+ integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
+ integer, dimension(:), allocatable :: nb_pixel_per_proc
+ integer, dimension(:,:), allocatable :: num_pixel_recv
+ double precision, dimension(:), allocatable :: data_pixel_recv
+ double precision, dimension(:), allocatable :: data_pixel_send
+#endif
+
+! timing information for the stations
+ character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
+
+! title of the plot
+ character(len=60) simulation_title
+
+! Lagrange interpolators at receivers
+ double precision, dimension(:), allocatable :: hxir,hgammar,hpxir,hpgammar
+ double precision, dimension(:,:), allocatable :: hxir_store,hgammar_store
+
+! Lagrange interpolators at sources
+ double precision, dimension(:), allocatable :: hxis,hgammas,hpxis,hpgammas
+ double precision, dimension(:,:), allocatable :: hxis_store,hgammas_store
+
+! for Lagrange interpolants
+ double precision, external :: hgll
+
+! timer to count elapsed time
+ double precision :: time_start
+ integer :: year_start,month_start
+
+ ! to determine date and time at which the run will finish
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+
+! for MPI and partitioning
+ integer :: ier
+ integer :: nproc
+ integer :: myrank
+ character(len=150) :: outputname,outputname2
+
+ integer :: ninterface
+ integer :: max_interface_size
+ integer, dimension(:), allocatable :: my_neighbours
+ integer, dimension(:), allocatable :: my_nelmnts_neighbours
+ integer, dimension(:,:,:), allocatable :: my_interfaces
+ integer, dimension(:,:), allocatable :: ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(:), allocatable :: nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
+
+ integer :: ninterface_acoustic, ninterface_elastic,ninterface_poroelastic
+ integer, dimension(:), allocatable :: inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
+
+#ifdef USE_MPI
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_ac
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_ac
+ integer, dimension(:), allocatable :: tab_requests_send_recv_acoustic
+ 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,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_poro
+ integer :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, max_ibool_interfaces_size_po
+ integer :: iproc
+#endif
+
+! for overlapping MPI communications with computation
+ integer :: nspec_outer, nspec_inner, num_ispec_outer, num_ispec_inner
+ integer, dimension(:), allocatable :: ispec_outer_to_glob, ispec_inner_to_glob
+ logical, dimension(:), allocatable :: mask_ispec_inner_outer
+
+ integer, dimension(:,:), allocatable :: acoustic_surface
+ integer, dimension(:,:), allocatable :: acoustic_edges
+ logical :: any_acoustic_edges
+
+ integer :: ixmin, ixmax, izmin, izmax
+
+ integer :: nrecloc, irecloc
+ integer, dimension(:), allocatable :: recloc, which_proc_receiver
+
+! mask to sort ibool
+ integer, dimension(:), allocatable :: mask_ibool
+ integer, dimension(:,:,:), allocatable :: copy_ibool_ori
+ integer :: inumber
+
+! to compute analytical initial plane wave field
+ double precision :: angleforce_refl, c_inc, c_refl, cploc, csloc
+ double precision, dimension(2) :: A_plane, B_plane, C_plane
+ double precision :: z0_source, x0_source, time_offset
+
+! beyond critical angle
+ integer , dimension(:), allocatable :: left_bound,right_bound,bot_bound
+ double precision , dimension(:,:), allocatable :: v0x_left,v0z_left,v0x_right,v0z_right,v0x_bot,v0z_bot
+ double precision , dimension(:,:), allocatable :: t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_paco,veloc_paco,displ_paco
+ integer count_left,count_right,count_bottom
+ 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
+ integer :: npoin_outer,npoin_inner
+ 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, dimension(:), allocatable :: source_courbe_eros
+
+ integer :: nnodes_tangential_curve
+ double precision, dimension(:,:), allocatable :: nodes_tangential_curve
+ logical :: any_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
+!!!!!!!!!!
+ double precision, dimension(:,:,:),allocatable:: rho_local,vp_local,vs_local
+!!!! hessian
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhorho_el_hessian_final1, rhorho_el_hessian_final2
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhorho_el_hessian_temp1, rhorho_el_hessian_temp2
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhorho_ac_hessian_final1, rhorho_ac_hessian_final2
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: weight_line_x, weight_line_z, weight_surface,weight_jacobian
+ integer, dimension(:), allocatable :: weight_gll
+ real(kind=CUSTOM_REAL) :: zmin_yang, zmax_yang, xmin_yang, xmax_yang
+
+! to help locate elements with a negative Jacobian using OpenDX
+ logical :: found_a_negative_jacobian
+
+!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
+ logical, parameter :: ADD_PERIODIC_CONDITIONS = .false.
+
+!! DK DK the periodic conditions below are currently specific to a Gmsh model designed by Paul Cristini
+
+!! DK DK the horizontal periodicity distance is:
+ double precision, parameter :: PERIODIC_horiz_dist = 0.3597d0
+
+!! DK DK the length of an edge is about 1d-003, thus use e.g. 1/300 of that
+ double precision, parameter :: PERIODIC_DETECT_TOL = 1d-003 / 300.d0
+
+ integer, parameter :: NSPEC_PERIO = 670 / 2 ! 414 / 2
+
+ integer, dimension(NSPEC_PERIO) :: numperio_left
+ integer, dimension(NSPEC_PERIO) :: numperio_right
+
+ logical, dimension(4,NSPEC_PERIO) :: codeabs_perio_left
+ logical, dimension(4,NSPEC_PERIO) :: codeabs_perio_right
+
+ integer :: idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
+ integer :: ispecperio, ispecperio2, ispec2, i2, j2
+ integer :: iglob_target_to_replace, ispec3, i3, j3
+
+!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
+
+!***********************************************************************
+!
+! i n i t i a l i z a t i o n p h a s e
+!
+!***********************************************************************
+ call initialize_simulation(nproc,myrank,NUMBER_OF_PASSES, &
+ ninterface_acoustic,ninterface_elastic,ninterface_poroelastic)
+
+
+ ! reduction of cache misses inner/outer in two passes
+ do ipass = 1,NUMBER_OF_PASSES
+
+ ! starts reading in Database file
+ call read_databases_init(myrank,ipass, &
+ simulation_title,SIMULATION_TYPE,SAVE_FORWARD,npgeo, &
+ gnuplot,interpol,NTSTEP_BETWEEN_OUTPUT_INFO, &
+ output_postscript_snapshot,output_color_image,colors,numbers, &
+ meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows, &
+ anglerec,initialfield,add_Bielak_conditions, &
+ seismotype,imagetype,assign_external_model,READ_EXTERNAL_SEP_FILE, &
+ outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON, &
+ TURN_VISCATTENUATION_ON,Q0,freq0,p_sv, &
+ NSTEP,deltat,NTSTEP_BETWEEN_OUTPUT_SEISMO,NSOURCES)
+
+ !
+ !--- source information
+ !
+ if(ipass == 1) then
+ allocate( source_type(NSOURCES) )
+ allocate( time_function_type(NSOURCES) )
+ allocate( x_source(NSOURCES) )
+ allocate( z_source(NSOURCES) )
+ allocate( f0(NSOURCES) )
+ allocate( tshift_src(NSOURCES) )
+ allocate( factor(NSOURCES) )
+ allocate( angleforce(NSOURCES) )
+ allocate( Mxx(NSOURCES) )
+ allocate( Mxz(NSOURCES) )
+ allocate( Mzz(NSOURCES) )
+ allocate( aval(NSOURCES) )
+ allocate( ispec_selected_source(NSOURCES) )
+ allocate( iglob_source(NSOURCES) )
+ allocate( source_courbe_eros(NSOURCES) )
+ allocate( xi_source(NSOURCES) )
+ allocate( gamma_source(NSOURCES) )
+ allocate( is_proc_source(NSOURCES) )
+ allocate( nb_proc_source(NSOURCES) )
+ allocate( sourcearray(NSOURCES,NDIM,NGLLX,NGLLZ) )
+ endif
+
+ ! reads in source infos
+ call read_databases_sources(NSOURCES,source_type,time_function_type, &
+ x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce)
+
+ ! sets source parameters
+ call set_sources(myrank,NSOURCES,source_type,time_function_type, &
+ x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce,aval, &
+ t0,initialfield,ipass,deltat)
+
+ !
+ !---- read attenuation information
+ !
+ call read_databases_atten(N_SLS,f0_attenuation)
+
+ ! 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
+
+
+ !
+ !---- read the spectral macrobloc nodal coordinates
+ !
+ if(ipass == 1) allocate(coorg(NDIM,npgeo))
+
+ ! reads the spectral macrobloc nodal coordinates
+ ! and basic properties of the spectral elements
+ call read_databases_coorg_elem(myrank,ipass,npgeo,coorg,numat,ngnod,nspec, &
+ pointsdisp,plot_lowerleft_corner_only, &
+ 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))
+ allocate(dershape2D_display(NDIM,ngnod,pointsdisp,pointsdisp))
+ allocate(xix(NGLLX,NGLLZ,nspec))
+ allocate(xiz(NGLLX,NGLLZ,nspec))
+ allocate(gammax(NGLLX,NGLLZ,nspec))
+ allocate(gammaz(NGLLX,NGLLZ,nspec))
+ allocate(jacobian(NGLLX,NGLLZ,nspec))
+ allocate(flagrange(NGLLX,pointsdisp))
+ allocate(xinterp(pointsdisp,pointsdisp))
+ allocate(zinterp(pointsdisp,pointsdisp))
+ allocate(Uxinterp(pointsdisp,pointsdisp))
+ allocate(Uzinterp(pointsdisp,pointsdisp))
+ allocate(density(2,numat))
+ allocate(anisotropy(6,numat))
+ allocate(porosity(numat))
+ 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(anisotropic(nspec))
+ 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
+
+ !
+ !---- read the material properties
+ !
+ call gmat01(density,porosity,tortuosity,anisotropy,permeability,poroelastcoef,numat,&
+ myrank,ipass,Qp_attenuation,Qs_attenuation,freq0,Q0,f0(1),TURN_VISCATTENUATION_ON)
+ !
+ !---- read spectral macrobloc data
+ !
+ if(ipass == 1) then
+ allocate(antecedent_list(nspec))
+ allocate(perm(nspec))
+ endif
+ call read_databases_mato(ipass,nspec,ngnod,kmato,knods, &
+ perm,antecedent_list)
+
+
+!-------------------------------------------------------------------------------
+!---- determine if each spectral element is elastic, poroelastic, or acoustic
+!-------------------------------------------------------------------------------
+ ! initializes
+ any_acoustic = .false.
+ any_elastic = .false.
+ any_poroelastic = .false.
+
+ anisotropic(:) = .false.
+ elastic(:) = .false.
+ poroelastic(:) = .false.
+
+ ! loops over all elements
+ do ispec = 1,nspec
+
+ if( nint(porosity(kmato(ispec))) == 1 ) then
+ ! acoustic domain
+ elastic(ispec) = .false.
+ poroelastic(ispec) = .false.
+ any_acoustic = .true.
+ elseif( porosity(kmato(ispec)) < TINYVAL) then
+ ! elastic domain
+ elastic(ispec) = .true.
+ poroelastic(ispec) = .false.
+ any_elastic = .true.
+ if(any(anisotropy(:,kmato(ispec)) /= 0)) then
+ anisotropic(ispec) = .true.
+ end if
+ else
+ ! poroelastic domain
+ elastic(ispec) = .false.
+ poroelastic(ispec) = .true.
+ any_poroelastic = .true.
+ endif
+
+ enddo !do ispec = 1,nspec
+
+
+ if(.not. p_sv .and. .not. any_elastic) then
+ print*, '*************** WARNING ***************'
+ print*, 'Surface (membrane) waves calculation needs an elastic medium'
+ print*, '*************** WARNING ***************'
+ stop
+ endif
+ if(.not. p_sv .and. (TURN_ATTENUATION_ON)) then
+ print*, '*************** WARNING ***************'
+ print*, 'Attenuation and anisotropy are not implemented for surface (membrane) waves calculation'
+ print*, '*************** WARNING ***************'
+ stop
+ endif
+
+
+ if(TURN_ATTENUATION_ON) then
+ nspec_allocate = nspec
+ else
+ nspec_allocate = 1
+ 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))
+ e1(:,:,:,:) = 0._CUSTOM_REAL
+ e11(:,:,:,:) = 0._CUSTOM_REAL
+ e13(:,:,:,:) = 0._CUSTOM_REAL
+
+ allocate(dux_dxl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dzl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dxl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dzl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
+ 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 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))
+ allocate(viscox(NGLLX,NGLLZ,nspec))
+ allocate(viscoz(NGLLX,NGLLZ,nspec))
+ else
+ allocate(rx_viscous(NGLLX,NGLLZ,1))
+ allocate(rz_viscous(NGLLX,NGLLZ,1))
+ allocate(viscox(NGLLX,NGLLZ,1))
+ allocate(viscoz(NGLLX,NGLLZ,1))
+ endif
+ endif
+
+ !
+ !---- read interfaces data
+ !
+ call read_databases_ninterface(ninterface,max_interface_size)
+ 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))
+ allocate(ibool_interfaces_acoustic(NGLLX*max_interface_size,ninterface))
+ allocate(ibool_interfaces_elastic(NGLLX*max_interface_size,ninterface))
+ allocate(ibool_interfaces_poroelastic(NGLLX*max_interface_size,ninterface))
+ allocate(nibool_interfaces_acoustic(ninterface))
+ allocate(nibool_interfaces_elastic(ninterface))
+ allocate(nibool_interfaces_poroelastic(ninterface))
+ allocate(inum_interfaces_acoustic(ninterface))
+ allocate(inum_interfaces_elastic(ninterface))
+ allocate(inum_interfaces_poroelastic(ninterface))
+ endif
+ call read_databases_interfaces(ipass,ninterface,nspec,max_interface_size, &
+ my_neighbours,my_nelmnts_neighbours,my_interfaces, &
+ perm,antecedent_list)
+
+ endif
+
+
+! --- allocate arrays for absorbing boundary conditions
+
+ if(nelemabs <= 0) then
+ nelemabs = 1
+ anyabs = .false.
+ else
+ anyabs = .true.
+ endif
+
+ if(ipass == 1) then
+ allocate(numabs(nelemabs))
+ allocate(codeabs(4,nelemabs))
+
+ allocate(ibegin_bottom(nelemabs))
+ allocate(iend_bottom(nelemabs))
+ allocate(ibegin_top(nelemabs))
+ allocate(iend_top(nelemabs))
+
+ allocate(jbegin_left(nelemabs))
+ allocate(jend_left(nelemabs))
+ allocate(jbegin_right(nelemabs))
+ allocate(jend_right(nelemabs))
+
+ allocate(ibegin_bottom_poro(nelemabs))
+ allocate(iend_bottom_poro(nelemabs))
+ allocate(ibegin_top_poro(nelemabs))
+ allocate(iend_top_poro(nelemabs))
+
+ allocate(jbegin_left_poro(nelemabs))
+ allocate(jend_left_poro(nelemabs))
+ allocate(jbegin_right_poro(nelemabs))
+ allocate(jend_right_poro(nelemabs))
+
+ allocate(ib_left(nelemabs))
+ allocate(ib_right(nelemabs))
+ allocate(ib_bottom(nelemabs))
+ allocate(ib_top(nelemabs))
+
+ endif
+
+ !
+ !---- read absorbing boundary data
+ !
+ call read_databases_absorbing(myrank,ipass,nelemabs,nspec,anyabs, &
+ ibegin_bottom,iend_bottom,jbegin_right,jend_right, &
+ ibegin_top,iend_top,jbegin_left,jend_left, &
+ numabs,codeabs,perm,antecedent_list, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ ib_right,ib_left,ib_bottom,ib_top)
+
+
+ if( anyabs ) then
+ ! Files to save absorbed waves needed to reconstruct backward wavefield for adjoint method
+ if(ipass == 1) then
+ if(any_elastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 2)) then
+ allocate(b_absorb_elastic_left(3,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_elastic_right(3,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_elastic_bottom(3,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_elastic_top(3,NGLLX,nspec_zmax,NSTEP))
+ else
+ allocate(b_absorb_elastic_left(1,1,1,1))
+ allocate(b_absorb_elastic_right(1,1,1,1))
+ allocate(b_absorb_elastic_bottom(1,1,1,1))
+ allocate(b_absorb_elastic_top(1,1,1,1))
+ endif
+ if(any_poroelastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 2)) then
+ allocate(b_absorb_poro_s_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_poro_s_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_poro_s_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_poro_s_top(NDIM,NGLLX,nspec_zmax,NSTEP))
+ allocate(b_absorb_poro_w_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_poro_w_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_poro_w_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_poro_w_top(NDIM,NGLLX,nspec_zmax,NSTEP))
+ else
+ allocate(b_absorb_poro_s_left(1,1,1,1))
+ allocate(b_absorb_poro_s_right(1,1,1,1))
+ allocate(b_absorb_poro_s_bottom(1,1,1,1))
+ allocate(b_absorb_poro_s_top(1,1,1,1))
+ allocate(b_absorb_poro_w_left(1,1,1,1))
+ allocate(b_absorb_poro_w_right(1,1,1,1))
+ allocate(b_absorb_poro_w_bottom(1,1,1,1))
+ allocate(b_absorb_poro_w_top(1,1,1,1))
+ endif
+ if(any_acoustic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 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))
+ else
+ allocate(b_absorb_acoustic_left(1,1,1))
+ allocate(b_absorb_acoustic_right(1,1,1))
+ allocate(b_absorb_acoustic_bottom(1,1,1))
+ allocate(b_absorb_acoustic_top(1,1,1))
+ endif
+ endif
+
+ else
+
+ if(.not. allocated(b_absorb_elastic_left)) then
+ allocate(b_absorb_elastic_left(1,1,1,1))
+ allocate(b_absorb_elastic_right(1,1,1,1))
+ allocate(b_absorb_elastic_bottom(1,1,1,1))
+ allocate(b_absorb_elastic_top(1,1,1,1))
+ endif
+
+ if(.not. allocated(b_absorb_poro_s_left)) then
+ allocate(b_absorb_poro_s_left(1,1,1,1))
+ allocate(b_absorb_poro_s_right(1,1,1,1))
+ allocate(b_absorb_poro_s_bottom(1,1,1,1))
+ allocate(b_absorb_poro_s_top(1,1,1,1))
+ allocate(b_absorb_poro_w_left(1,1,1,1))
+ allocate(b_absorb_poro_w_right(1,1,1,1))
+ allocate(b_absorb_poro_w_bottom(1,1,1,1))
+ allocate(b_absorb_poro_w_top(1,1,1,1))
+ endif
+
+ if(.not. allocated(b_absorb_acoustic_left)) then
+ allocate(b_absorb_acoustic_left(1,1,1))
+ allocate(b_absorb_acoustic_right(1,1,1))
+ allocate(b_absorb_acoustic_bottom(1,1,1))
+ allocate(b_absorb_acoustic_top(1,1,1))
+ endif
+
+ endif
+
+!
+!---- read acoustic free surface data
+!
+ if(nelem_acoustic_surface > 0) then
+ any_acoustic_edges = .true.
+ else
+ any_acoustic_edges = .false.
+ nelem_acoustic_surface = 1
+ endif
+ if( ipass == 1 ) then
+ allocate(acoustic_edges(4,nelem_acoustic_surface))
+ allocate(acoustic_surface(5,nelem_acoustic_surface))
+ endif
+ call read_databases_free_surf(ipass,nelem_acoustic_surface,nspec, &
+ acoustic_edges,perm,antecedent_list,any_acoustic_edges)
+ ! resets nelem_acoustic_surface
+ if( any_acoustic_edges .eqv. .false. ) nelem_acoustic_surface = 0
+
+ ! constructs acoustic surface
+ if(nelem_acoustic_surface > 0) then
+ call construct_acoustic_surface ( nspec, ngnod, knods, nelem_acoustic_surface, &
+ acoustic_edges, acoustic_surface)
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
+ endif
+ endif
+
+
+ !
+ !---- read coupled edges
+ !
+ if( num_fluid_solid_edges > 0 ) then
+ any_fluid_solid_edges = .true.
+ else
+ any_fluid_solid_edges = .false.
+ num_fluid_solid_edges = 1
+ endif
+ 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
+ if( num_fluid_poro_edges > 0 ) then
+ any_fluid_poro_edges = .true.
+ else
+ any_fluid_poro_edges = .false.
+ num_fluid_poro_edges = 1
+ endif
+ 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
+ if ( num_solid_poro_edges > 0 ) then
+ any_solid_poro_edges = .true.
+ else
+ any_solid_poro_edges = .false.
+ num_solid_poro_edges = 1
+ endif
+ 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
+
+ call read_databases_coupled(ipass,nspec,num_fluid_solid_edges,any_fluid_solid_edges, &
+ fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec, &
+ num_fluid_poro_edges,any_fluid_poro_edges, &
+ fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec, &
+ num_solid_poro_edges,any_solid_poro_edges, &
+ solid_poro_elastic_ispec,solid_poro_poroelastic_ispec, &
+ perm,antecedent_list)
+
+ ! resets counters
+ if( any_fluid_solid_edges .eqv. .false. ) num_fluid_solid_edges = 0
+ if( any_fluid_poro_edges .eqv. .false. ) num_fluid_poro_edges = 0
+ if( any_solid_poro_edges .eqv. .false. ) num_solid_poro_edges = 0
+
+
+ !
+ !---- read tangential detection curve
+ ! and close Database file
+ !
+ if (nnodes_tangential_curve > 0) then
+ any_tangential_curve = .true.
+ else
+ any_tangential_curve = .false.
+ nnodes_tangential_curve = 1
+ endif
+ if (ipass == 1) then
+ allocate(nodes_tangential_curve(2,nnodes_tangential_curve))
+ allocate(dist_tangential_detection_curve(nnodes_tangential_curve))
+ endif
+ call read_databases_final(nnodes_tangential_curve,nodes_tangential_curve, &
+ force_normal_to_surface,rec_normal_to_surface, &
+ any_tangential_curve)
+ ! resets nnode_tangential_curve
+ if( any_tangential_curve .eqv. .false. ) nnodes_tangential_curve = 0
+
+!
+!---- compute shape functions and their derivatives for SEM grid
+!
+
+! set up Gauss-Lobatto-Legendre derivation matrices
+ call define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ call define_shape_functions(shape2D(:,i,j),dershape2D(:,:,i,j),xigll(i),zigll(j),ngnod)
+ enddo
+ enddo
+
+!
+!---- generate the global numbering
+!
+
+! "slow and clean" or "quick and dirty" version
+ if(FAST_NUMBERING) then
+ call createnum_fast(knods,ibool,shape2D,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
+ else
+ call createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
+ endif
+
+! 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))
+
+ print *
+ print *,'Xmin,Xmax of the whole mesh = ',minval(coord(1,:)),maxval(coord(1,:))
+ print *,'Zmin,Zmax of the whole mesh = ',minval(coord(2,:)),maxval(coord(2,:))
+ print *
+
+!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
+
+ if(ADD_PERIODIC_CONDITIONS) then
+
+#ifdef USE_MPI
+ stop 'periodic conditions currently implemented for a serial simulation only (due e.g. to mass matrix rebuilding)'
+#endif
+
+ if(any_poroelastic .or. any_acoustic) stop 'periodic conditions currently implemented for purely elastic models only'
+
+ if(ACTUALLY_IMPLEMENT_PERM_OUT .or. ACTUALLY_IMPLEMENT_PERM_INN .or. ACTUALLY_IMPLEMENT_PERM_WHOLE) &
+ stop 'currently, all permutations should be off for periodic conditions'
+
+print *
+open(unit=123,file='Database00000_left_edge_only',status='old')
+do ispecperio = 1,NSPEC_PERIO
+ read(123,*) numperio_left(ispecperio), &
+ codeabs_perio_left(IBOTTOM,ispecperio), &
+ codeabs_perio_left(IRIGHT,ispecperio), &
+ codeabs_perio_left(ITOP,ispecperio), &
+ codeabs_perio_left(ILEFT,ispecperio), &
+ idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
+enddo
+close(123)
+print *,'read ',NSPEC_PERIO,' elements for left periodic edge'
+
+open(unit=123,file='Database00000_right_edge_only',status='old')
+do ispecperio = 1,NSPEC_PERIO
+ read(123,*) numperio_right(ispecperio), &
+ codeabs_perio_right(IBOTTOM,ispecperio), &
+ codeabs_perio_right(IRIGHT,ispecperio), &
+ codeabs_perio_right(ITOP,ispecperio), &
+ codeabs_perio_right(ILEFT,ispecperio), &
+ idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
+enddo
+close(123)
+print *,'read ',NSPEC_PERIO,' elements for right periodic edge'
+print *
+
+print *,'because of periodic conditions, values computed by checkgrid() are not reliable'
+print *
+
+!---------------------------------------------------------------------------
+
+ do ispecperio = 1,NSPEC_PERIO
+
+ ispec = numperio_left(ispecperio)
+
+! print *,'dist of edge is ',sqrt((coord(2,ibool(1,1,ispec)) - coord(2,ibool(1,NGLLZ,ispec))) ** 2 + &
+! (coord(1,ibool(1,1,ispec)) - coord(1,ibool(1,NGLLZ,ispec))) ** 2)
+
+ if(codeabs_perio_left(ILEFT,ispecperio)) then
+ i = 1
+ do j = 1,NGLLZ
+ iglob = ibool(i,j,ispec)
+!----------------------------------------------------------------------
+ include "include_for_periodic_conditions.f90"
+!----------------------------------------------------------------------
+ enddo
+ endif
+
+ if(codeabs_perio_left(IRIGHT,ispecperio)) then
+ i = NGLLX
+ do j = 1,NGLLZ
+ iglob = ibool(i,j,ispec)
+!----------------------------------------------------------------------
+ include "include_for_periodic_conditions.f90"
+!----------------------------------------------------------------------
+ enddo
+ endif
+
+ if(codeabs_perio_left(IBOTTOM,ispecperio)) then
+ j = 1
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+!----------------------------------------------------------------------
+ include "include_for_periodic_conditions.f90"
+!----------------------------------------------------------------------
+ enddo
+ endif
+
+ if(codeabs_perio_left(ITOP,ispecperio)) then
+ j = NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+!----------------------------------------------------------------------
+ include "include_for_periodic_conditions.f90"
+!----------------------------------------------------------------------
+ enddo
+ endif
+
+ enddo
+
+! rebuild the mass matrix based on this new numbering
+!
+!---- build the global mass matrix and invert it once and for all
+!
+ rmass_inverse_elastic(:) = 0._CUSTOM_REAL
+ 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/3.d0*mul_relaxed
+ endif
+
+ rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) &
+ + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
+
+ enddo
+ enddo
+ enddo ! do ispec = 1,nspec
+
+! invert the mass matrix once and for all
+! set entries that are equal to zero to something else, e.g. 1, to avoid division by zero
+! these degrees of freedom correspond to points that have been replaced with their periodic counterpart
+! and thus are not used any more
+ where(rmass_inverse_elastic == 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
+ rmass_inverse_elastic(:) = 1._CUSTOM_REAL / rmass_inverse_elastic(:)
+
+ endif ! of if(ADD_PERIODIC_CONDITIONS)
+
+!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
+
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:) = ibool(:,:,:)
+
+ inumber = 0
+
+ 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
+ ! create a new point
+ inumber = inumber + 1
+ ibool(i,j,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
+ else
+ ! use an existing point created previously
+ ibool(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+
+! then reduce cache misses in inner elements, since they are taken second
+! loop over spectral elements
+ do ispec = 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 ! ipass
+
+!---- compute shape functions and their derivatives for regular interpolated display grid
+ do j = 1,pointsdisp
+ do i = 1,pointsdisp
+ xirec = 2.d0*dble(i-1)/dble(pointsdisp-1) - 1.d0
+ gammarec = 2.d0*dble(j-1)/dble(pointsdisp-1) - 1.d0
+ call define_shape_functions(shape2D_display(:,i,j),dershape2D_display(:,:,i,j),xirec,gammarec,ngnod)
+ enddo
+ enddo
+
+!---- compute Lagrange interpolants on a regular interpolated grid in (xi,gamma)
+!---- for display (assumes NGLLX = NGLLZ)
+ do j=1,NGLLX
+ do i=1,pointsdisp
+ xirec = 2.d0*dble(i-1)/dble(pointsdisp-1) - 1.d0
+ flagrange(j,i) = hgll(j-1,xirec,xigll,NGLLX)
+ enddo
+ enddo
+
+! get number of stations from receiver file
+ open(unit=IIN,file='DATA/STATIONS_target',iostat=ios,status='old',action='read')
+ nrec = 0
+ do while(ios == 0)
+ read(IIN,"(a)",iostat=ios) dummystring
+ if(ios == 0) nrec = nrec + 1
+ enddo
+ close(IIN)
+
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Total number of receivers = ',nrec
+ write(IOUT,*)
+ endif
+
+ 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))
+ allocate(xi_receiver(nrec))
+ allocate(gamma_receiver(nrec))
+ allocate(station_name(nrec))
+ 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))
+ allocate(hxis(NGLLX))
+ allocate(hpxir(NGLLX))
+ allocate(hpxis(NGLLX))
+ allocate(hgammar(NGLLZ))
+ allocate(hgammas(NGLLZ))
+ allocate(hpgammar(NGLLZ))
+ allocate(hpgammas(NGLLZ))
+
+! allocate Lagrange interpolators for receivers
+ allocate(hxir_store(nrec,NGLLX))
+ allocate(hgammar_store(nrec,NGLLZ))
+
+! allocate Lagrange interpolators for sources
+ allocate(hxis_store(NSOURCES,NGLLX))
+ allocate(hgammas_store(NSOURCES,NGLLZ))
+
+! allocate other global arrays
+ allocate(coord(NDIM,npoin))
+
+! to display acoustic elements
+ allocate(vector_field_display(3,npoin))
+
+! if(assign_external_model) then
+
+! note: so far, full external array needed/defined in subroutine calls
+ allocate(vpext(NGLLX,NGLLZ,nspec))
+ allocate(vsext(NGLLX,NGLLZ,nspec))
+ allocate(rhoext(NGLLX,NGLLZ,nspec))
+ allocate(Qp_attenuationext(NGLLX,NGLLZ,nspec))
+ allocate(Qs_attenuationext(NGLLX,NGLLZ,nspec))
+ allocate(c11ext(NGLLX,NGLLZ,nspec))
+ allocate(c13ext(NGLLX,NGLLZ,nspec))
+ allocate(c15ext(NGLLX,NGLLZ,nspec))
+ allocate(c33ext(NGLLX,NGLLZ,nspec))
+ allocate(c35ext(NGLLX,NGLLZ,nspec))
+ allocate(c55ext(NGLLX,NGLLZ,nspec))
+! else
+! allocate(vpext(1,1,1))
+! allocate(vsext(1,1,1))
+! allocate(rhoext(1,1,1))
+! allocate(c11ext(1,1,1))
+! allocate(c13ext(1,1,1))
+! allocate(c15ext(1,1,1))
+! allocate(c33ext(1,1,1))
+! allocate(c35ext(1,1,1))
+! allocate(c55ext(1,1,1))
+! endif
+
+ endif
+
+!
+!---- set the coordinates of the points of the global grid
+!
+ found_a_negative_jacobian = .false.
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ xi = xigll(i)
+ gamma = zigll(j)
+
+ call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
+ jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
+ .false.)
+
+ if(jacobianl <= ZERO) found_a_negative_jacobian = .true.
+
+ coord(1,ibool(i,j,ispec)) = x
+ coord(2,ibool(i,j,ispec)) = z
+
+ xix(i,j,ispec) = xixl
+ xiz(i,j,ispec) = xizl
+ gammax(i,j,ispec) = gammaxl
+ gammaz(i,j,ispec) = gammazl
+ jacobian(i,j,ispec) = jacobianl
+
+ enddo
+ enddo
+ enddo
+
+! create an OpenDX file containing all the negative elements displayed in red, if any
+! this allows users to locate problems in a mesh based on the OpenDX file created at the second iteration
+! do not create OpenDX files if no negative Jacobian has been found, or if we are running in parallel
+! (because writing OpenDX routines is much easier in serial)
+ if(found_a_negative_jacobian .and. nproc == 1) then
+ call save_openDX_jacobian(nspec,npgeo,ngnod,knods,coorg,xigll,zigll)
+ endif
+
+! stop the code at the first negative element found, because such a mesh cannot be computed
+ if(found_a_negative_jacobian) then
+
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ xi = xigll(i)
+ gamma = zigll(j)
+
+ call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
+ jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
+ .true.)
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! yang output weights for line, surface integrals !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!define_derivation_matrices(xigll(NGLLX),zigll(NGLLZ),wxgll(NGLLX),wzgll(NGLLZ),hprime_xx(NGLLX,NGLLX),hprime_zz(NGLLZ,NGLLZ),&
+! hprimewgll_xx(NGLLX,NGLLX),hprimewgll_zz(NGLLZ,NGLLZ))
+!xix(NGLLX,NGLLZ,nspec),xiz,gammax,gammaz,jacobian
+!recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl,jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
+! .true.)
+ allocate(weight_line_x(npoin))
+ allocate(weight_line_z(npoin))
+ allocate(weight_surface(npoin))
+ allocate(weight_jacobian(npoin))
+ allocate(weight_gll(npoin))
+ weight_line_x=0.0
+ weight_line_z=0.0
+ weight_surface=0.0
+ zmin_yang=minval(coord(2,:))
+ xmin_yang=minval(coord(1,:))
+ zmax_yang=maxval(coord(2,:))
+ xmax_yang=maxval(coord(1,:))
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob=ibool(i,j,ispec)
+ z=coord(2,ibool(i,j,ispec))
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ if ((j==1 .OR. j==NGLLZ) .AND. ( (abs(z-zmin_yang).GE.1) .AND. (abs(z-zmax_yang)).GE.1) ) xxi=xxi/2.0
+ if ((i==1 .OR. i==NGLLZ) .AND. ( (abs(x-xmin_yang).GE.1) .AND. (abs(x-xmax_yang)).GE.1) ) zgamma=zgamma/2.0
+ weight_line_x(iglob) = weight_line_x(iglob) + xxi * wxgll(i)
+ weight_line_z(iglob) = weight_line_z(iglob) + zgamma * wzgll(j)
+ weight_surface(iglob) = weight_surface(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)
+ weight_jacobian(iglob) = jacobian(i,j,ispec)
+ weight_gll(iglob) = 10*j+i
+ enddo
+ enddo
+ enddo
+ open(unit=55,file='OUTPUT_FILES/x_z_weightLineX_weightLineZ_weightSurface',status='unknown')
+ do n = 1,npoin
+ write(55,*) coord(1,n), coord(2,n), weight_line_x(n), weight_line_z(n), weight_surface(n),weight_jacobian(n),weight_gll(n)
+ enddo
+ close(55)
+ deallocate(weight_line_x)
+ deallocate(weight_line_z)
+ deallocate(weight_surface)
+ deallocate(weight_jacobian)
+ deallocate(weight_gll)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!--- save the grid of points in a file
+!
+ 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')
+ 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 .and. myrank == 0 .and. ipass == 1) &
+ call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
+
+ if(myrank == 0 .and. ipass == 1) &
+ write(IOUT,*) 'assign_external_model = ', assign_external_model
+
+!if ( assign_external_model .and. ipass == 1) then
+ if ( assign_external_model) then
+ call read_external_model(any_acoustic,any_elastic,any_poroelastic, &
+ elastic,poroelastic,anisotropic,nspec,npoin,N_SLS,ibool, &
+ f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
+ inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent, &
+ inv_tau_sigma_nu1,inv_tau_sigma_nu2,phi_nu1,phi_nu2,Mu_nu1,Mu_nu2,&
+ coord,kmato,myrank,rhoext,vpext,vsext, &
+ Qp_attenuationext,Qs_attenuationext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,READ_EXTERNAL_SEP_FILE)
+ end if
+
+!
+!---- perform basic checks on parameters read
+!
+ all_anisotropic = .false.
+ if(count(anisotropic(:) .eqv. .true.) == nspec) all_anisotropic = .true.
+
+ if(all_anisotropic .and. anyabs) &
+ call exit_MPI('Cannot put absorbing boundaries if anisotropic materials along edges')
+
+ if(TURN_ATTENUATION_ON .and. all_anisotropic) then
+ call exit_MPI('Cannot turn attenuation on in anisotropic materials')
+ end if
+
+ ! global domain flags
+ 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
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, &
+ MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ any_acoustic_glob = any_acoustic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(any_acoustic, any_acoustic_glob, 1, MPI_LOGICAL, &
+ MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ ! for acoustic
+ if(TURN_ATTENUATION_ON .and. .not. any_elastic_glob) &
+ call exit_MPI('currently cannot have attenuation if acoustic/poroelastic simulation only')
+
+!
+!---- define coefficients of the Newmark time scheme
+!
+ deltatover2 = HALF*deltat
+ deltatsquareover2 = HALF*deltat*deltat
+
+ if(SIMULATION_TYPE == 2) then
+! define coefficients of the Newmark time scheme for the backward wavefield
+ b_deltat = - deltat
+ b_deltatover2 = HALF*b_deltat
+ b_deltatsquareover2 = HALF*b_deltat*b_deltat
+ endif
+
+!---- define actual location of source and receivers
+
+ call setup_sources_receivers(NSOURCES,initialfield,source_type,&
+ coord,ibool,npoin,nspec,nelem_acoustic_surface,acoustic_surface,elastic,poroelastic, &
+ x_source,z_source,ispec_selected_source,ispec_selected_rec, &
+ is_proc_source,nb_proc_source,ipass,&
+ sourcearray,Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,npgeo,&
+ nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod, &
+ nrec,nrecloc,recloc,which_proc_receiver,st_xval,st_zval, &
+ xi_receiver,gamma_receiver,station_name,network_name,x_final_receiver,z_final_receiver,iglob_source)
+
+! compute source array for adjoint source
+ if(SIMULATION_TYPE == 2) then ! adjoint calculation
+ nadj_rec_local = 0
+ do irec = 1,nrec
+ if(myrank == which_proc_receiver(irec))then
+! check that the source proc number is okay
+ if(which_proc_receiver(irec) < 0 .or. which_proc_receiver(irec) > NPROC-1) &
+ call exit_MPI('something is wrong with the source proc number in adjoint simulation')
+ nadj_rec_local = nadj_rec_local + 1
+ endif
+ enddo
+ if(ipass == 1) allocate(adj_sourcearray(NSTEP,3,NGLLX,NGLLZ))
+ if (nadj_rec_local > 0 .and. ipass == 1) then
+ allocate(adj_sourcearrays(nadj_rec_local,NSTEP,3,NGLLX,NGLLZ))
+ else if (ipass == 1) then
+ allocate(adj_sourcearrays(1,1,1,1,1))
+ endif
+
+ irec_local = 0
+ do irec = 1, nrec
+! compute only adjoint source arrays in the local proc
+ if(myrank == which_proc_receiver(irec))then
+ irec_local = irec_local + 1
+ adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+ call compute_arrays_adj_source(adj_source_file, &
+ xi_receiver(irec), gamma_receiver(irec), &
+ adj_sourcearray, xigll,zigll,NSTEP)
+ adj_sourcearrays(irec_local,:,:,:,:) = adj_sourcearray(:,:,:,:)
+ endif
+ enddo
+ else if (ipass == 1) then
+ allocate(adj_sourcearrays(1,1,1,1,1))
+ 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
+
+ if (rec_normal_to_surface .and. abs(anglerec) > 1.d-6) &
+ stop 'anglerec should be zero when receivers are normal to the topography'
+
+ anglerec_irec(:) = anglerec * pi / 180.d0
+ cosrot_irec(:) = cos(anglerec_irec(:))
+ sinrot_irec(:) = sin(anglerec_irec(:))
+ 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 compute_normal_vector( 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,NSOURCES
+ 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)
+
+ ! in the case of a source force vector
+ ! users can give an angle with respect to the normal to the topography surface,
+ ! in which case we must compute the normal to the topography
+ ! and add it the existing rotation angle
+ call compute_normal_vector( 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,NSOURCES
+ 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 ! force_normal_to_surface
+
+ endif ! ipass
+
+!
+!---
+!
+
+! allocate seismogram arrays
+ if(ipass == 1) then
+ allocate(sisux(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
+ allocate(sisuz(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
+ allocate(siscurl(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
+ endif
+
+! check if acoustic receiver is exactly on the free surface because pressure is zero there
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+ ispec = acoustic_surface(1,ispec_acoustic_surface)
+ ixmin = acoustic_surface(2,ispec_acoustic_surface)
+ ixmax = acoustic_surface(3,ispec_acoustic_surface)
+ izmin = acoustic_surface(4,ispec_acoustic_surface)
+ izmax = acoustic_surface(5,ispec_acoustic_surface)
+ do irecloc = 1,nrecloc
+ irec = recloc(irecloc)
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
+ if ( (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==NGLLX .and. &
+ gamma_receiver(irec) < -0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==NGLLX .and. &
+ gamma_receiver(irec) > 0.99d0) .or.&
+ (izmin==1 .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
+ xi_receiver(irec) < -0.99d0) .or.&
+ (izmin==1 .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ xi_receiver(irec) > 0.99d0) .or.&
+ (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==1 .and. &
+ gamma_receiver(irec) < -0.99d0 .and. xi_receiver(irec) < -0.99d0) .or.&
+ (izmin==1 .and. izmax==1 .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ gamma_receiver(irec) < -0.99d0 .and. xi_receiver(irec) > 0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
+ gamma_receiver(irec) > 0.99d0 .and. xi_receiver(irec) < -0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ gamma_receiver(irec) > 0.99d0 .and. xi_receiver(irec) > 0.99d0) ) then
+ if(seismotype == 4) then
+ call exit_MPI('an acoustic pressure receiver cannot be located exactly '// &
+ 'on the free surface because pressure is zero there')
+ else
+ print *, '**********************************************************************'
+ print *, '*** Warning: acoustic receiver located exactly on the free surface ***'
+ print *, '*** Warning: tangential component will be zero there ***'
+ print *, '**********************************************************************'
+ print *
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+! define and store Lagrange interpolators at all the receivers
+ do irec = 1,nrec
+ call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
+ hxir_store(irec,:) = hxir(:)
+ hgammar_store(irec,:) = hgammar(:)
+ enddo
+
+! define and store Lagrange interpolators at all the sources
+ do i = 1,NSOURCES
+ call lagrange_any(xi_source(i),NGLLX,xigll,hxis,hpxis)
+ call lagrange_any(gamma_source(i),NGLLZ,zigll,hgammas,hpgammas)
+ hxis_store(i,:) = hxis(:)
+ hgammas_store(i,:) = hgammas(:)
+ enddo
+
+! displacement, velocity, acceleration and inverse of the mass matrix for elastic elements
+ if(ipass == 1) then
+
+ if(any_elastic) then
+ npoin_elastic = npoin
+ else
+ ! allocate unused arrays with fictitious size
+ npoin_elastic = 1
+ endif
+ allocate(displ_elastic(3,npoin_elastic))
+ allocate(veloc_elastic(3,npoin_elastic))
+ allocate(accel_elastic(3,npoin_elastic))
+ allocate(rmass_inverse_elastic(npoin_elastic))
+
+ ! extra array if adjoint and kernels calculation
+ if(SIMULATION_TYPE == 2 .and. any_elastic) then
+ allocate(b_displ_elastic(3,npoin))
+ allocate(b_veloc_elastic(3,npoin))
+ allocate(b_accel_elastic(3,npoin))
+ allocate(rho_kl(NGLLX,NGLLZ,nspec))
+ allocate(rho_k(npoin))
+ allocate(rhol_global(npoin))
+ allocate(mu_kl(NGLLX,NGLLZ,nspec))
+ allocate(mu_k(npoin))
+ allocate(mul_global(npoin))
+ allocate(kappa_kl(NGLLX,NGLLZ,nspec))
+ allocate(kappa_k(npoin))
+ allocate(kappal_global(npoin))
+ allocate(rhop_kl(NGLLX,NGLLZ,nspec))
+ allocate(alpha_kl(NGLLX,NGLLZ,nspec))
+ allocate(beta_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhorho_el_hessian_final2(NGLLX,NGLLZ,nspec))
+ allocate(rhorho_el_hessian_temp2(npoin))
+ allocate(rhorho_el_hessian_final1(NGLLX,NGLLZ,nspec))
+ allocate(rhorho_el_hessian_temp1(npoin))
+ else
+ allocate(b_displ_elastic(1,1))
+ allocate(b_veloc_elastic(1,1))
+ allocate(b_accel_elastic(1,1))
+ allocate(rho_kl(1,1,1))
+ allocate(rho_k(1))
+ allocate(rhol_global(1))
+ allocate(mu_kl(1,1,1))
+ allocate(mu_k(1))
+ allocate(mul_global(1))
+ allocate(kappa_kl(1,1,1))
+ allocate(kappa_k(1))
+ allocate(kappal_global(1))
+ allocate(rhop_kl(1,1,1))
+ allocate(alpha_kl(1,1,1))
+ allocate(beta_kl(1,1,1))
+ allocate(rhorho_el_hessian_final2(1,1,1))
+ allocate(rhorho_el_hessian_temp2(1))
+ allocate(rhorho_el_hessian_final1(1,1,1))
+ allocate(rhorho_el_hessian_temp1(1))
+ endif
+
+ if(any_poroelastic) then
+ npoin_poroelastic = npoin
+ else
+ ! allocate unused arrays with fictitious size
+ npoin_poroelastic = 1
+ endif
+ allocate(displs_poroelastic(NDIM,npoin_poroelastic))
+ allocate(velocs_poroelastic(NDIM,npoin_poroelastic))
+ allocate(accels_poroelastic(NDIM,npoin_poroelastic))
+ allocate(rmass_s_inverse_poroelastic(npoin_poroelastic))
+ allocate(displw_poroelastic(NDIM,npoin_poroelastic))
+ allocate(velocw_poroelastic(NDIM,npoin_poroelastic))
+ allocate(accelw_poroelastic(NDIM,npoin_poroelastic))
+ allocate(rmass_w_inverse_poroelastic(npoin_poroelastic))
+
+ ! extra array if adjoint and kernels calculation
+ if(SIMULATION_TYPE == 2 .and. any_poroelastic) then
+ allocate(b_displs_poroelastic(NDIM,npoin))
+ allocate(b_velocs_poroelastic(NDIM,npoin))
+ allocate(b_accels_poroelastic(NDIM,npoin))
+ allocate(b_displw_poroelastic(NDIM,npoin))
+ allocate(b_velocw_poroelastic(NDIM,npoin))
+ allocate(b_accelw_poroelastic(NDIM,npoin))
+ allocate(rhot_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhot_k(npoin))
+ allocate(rhof_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhof_k(npoin))
+ allocate(sm_kl(NGLLX,NGLLZ,nspec))
+ allocate(sm_k(npoin))
+ allocate(eta_kl(NGLLX,NGLLZ,nspec))
+ allocate(eta_k(npoin))
+ allocate(mufr_kl(NGLLX,NGLLZ,nspec))
+ allocate(mufr_k(npoin))
+ allocate(B_kl(NGLLX,NGLLZ,nspec))
+ allocate(B_k(npoin))
+ allocate(C_kl(NGLLX,NGLLZ,nspec))
+ allocate(C_k(npoin))
+ allocate(M_kl(NGLLX,NGLLZ,nspec))
+ allocate(M_k(npoin))
+ allocate(rhob_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhofb_kl(NGLLX,NGLLZ,nspec))
+ allocate(phi_kl(NGLLX,NGLLZ,nspec))
+ allocate(Bb_kl(NGLLX,NGLLZ,nspec))
+ allocate(Cb_kl(NGLLX,NGLLZ,nspec))
+ allocate(Mb_kl(NGLLX,NGLLZ,nspec))
+ allocate(mufrb_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhobb_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhofbb_kl(NGLLX,NGLLZ,nspec))
+ allocate(phib_kl(NGLLX,NGLLZ,nspec))
+ allocate(cpI_kl(NGLLX,NGLLZ,nspec))
+ allocate(cpII_kl(NGLLX,NGLLZ,nspec))
+ allocate(cs_kl(NGLLX,NGLLZ,nspec))
+ allocate(ratio_kl(NGLLX,NGLLZ,nspec))
+ allocate(phil_global(npoin))
+ allocate(mulfr_global(npoin))
+ allocate(etal_f_global(npoin))
+ allocate(rhol_s_global(npoin))
+ allocate(rhol_f_global(npoin))
+ allocate(rhol_bar_global(npoin))
+ allocate(tortl_global(npoin))
+ allocate(permlxx_global(npoin))
+ allocate(permlxz_global(npoin))
+ allocate(permlzz_global(npoin))
+ else
+ allocate(b_displs_poroelastic(1,1))
+ allocate(b_velocs_poroelastic(1,1))
+ allocate(b_accels_poroelastic(1,1))
+ allocate(b_displw_poroelastic(1,1))
+ allocate(b_velocw_poroelastic(1,1))
+ allocate(b_accelw_poroelastic(1,1))
+ allocate(rhot_kl(1,1,1))
+ allocate(rhot_k(1))
+ allocate(rhof_kl(1,1,1))
+ allocate(rhof_k(1))
+ allocate(sm_kl(1,1,1))
+ allocate(sm_k(1))
+ allocate(eta_kl(1,1,1))
+ allocate(eta_k(1))
+ allocate(mufr_kl(1,1,1))
+ allocate(mufr_k(1))
+ allocate(B_kl(1,1,1))
+ allocate(B_k(1))
+ allocate(C_kl(1,1,1))
+ allocate(C_k(1))
+ allocate(M_kl(1,1,1))
+ allocate(M_k(1))
+ allocate(rhob_kl(1,1,1))
+ allocate(rhofb_kl(1,1,1))
+ allocate(phi_kl(1,1,1))
+ allocate(Bb_kl(1,1,1))
+ allocate(Cb_kl(1,1,1))
+ allocate(Mb_kl(1,1,1))
+ allocate(mufrb_kl(1,1,1))
+ allocate(rhobb_kl(1,1,1))
+ allocate(rhofbb_kl(1,1,1))
+ allocate(phib_kl(1,1,1))
+ allocate(cpI_kl(1,1,1))
+ allocate(cpII_kl(1,1,1))
+ allocate(cs_kl(1,1,1))
+ allocate(ratio_kl(1,1,1))
+ allocate(phil_global(1))
+ allocate(mulfr_global(1))
+ allocate(etal_f_global(1))
+ allocate(rhol_s_global(1))
+ allocate(rhol_f_global(1))
+ allocate(rhol_bar_global(1))
+ allocate(tortl_global(1))
+ allocate(permlxx_global(1))
+ allocate(permlxz_global(1))
+ allocate(permlzz_global(1))
+ endif
+
+ if(any_poroelastic .and. any_elastic) then
+ allocate(icount(npoin))
+ else
+ allocate(icount(1))
+ endif
+
+ ! potential, its first and second derivative, and inverse of the mass matrix for acoustic elements
+ if(any_acoustic) then
+ npoin_acoustic = npoin
+ else
+ ! allocate unused arrays with fictitious size
+ npoin_acoustic = 1
+ endif
+ allocate(potential_acoustic(npoin_acoustic))
+ allocate(potential_dot_acoustic(npoin_acoustic))
+ allocate(potential_dot_dot_acoustic(npoin_acoustic))
+ allocate(rmass_inverse_acoustic(npoin_acoustic))
+
+ if(SIMULATION_TYPE == 2 .and. any_acoustic) then
+ allocate(b_potential_acoustic(npoin))
+ allocate(b_potential_dot_acoustic(npoin))
+ allocate(b_potential_dot_dot_acoustic(npoin))
+ allocate(b_displ_ac(2,npoin))
+ allocate(b_accel_ac(2,npoin))
+ allocate(accel_ac(2,npoin))
+ allocate(rho_ac_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhol_ac_global(npoin))
+ allocate(kappa_ac_kl(NGLLX,NGLLZ,nspec))
+ allocate(kappal_ac_global(npoin))
+ allocate(rhop_ac_kl(NGLLX,NGLLZ,nspec))
+ allocate(alpha_ac_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhorho_ac_hessian_final2(NGLLX,NGLLZ,nspec))
+ allocate(rhorho_ac_hessian_final1(NGLLX,NGLLZ,nspec))
+ else
+ ! allocate unused arrays with fictitious size
+ allocate(b_potential_acoustic(1))
+ allocate(b_potential_dot_acoustic(1))
+ allocate(b_potential_dot_dot_acoustic(1))
+ allocate(b_displ_ac(1,1))
+ allocate(b_accel_ac(1,1))
+ allocate(accel_ac(1,1))
+ allocate(rho_ac_kl(1,1,1))
+ allocate(rhol_ac_global(1))
+ allocate(kappa_ac_kl(1,1,1))
+ allocate(kappal_ac_global(1))
+ allocate(rhop_ac_kl(1,1,1))
+ allocate(alpha_ac_kl(1,1,1))
+ allocate(rhorho_ac_hessian_final2(1,1,1))
+ allocate(rhorho_ac_hessian_final1(1,1,1))
+ endif
+
+ endif ! ipass == 1
+
+ !
+ !---- build the global mass matrix
+ !
+ call invert_mass_matrix_init(any_elastic,any_acoustic,any_poroelastic, &
+ rmass_inverse_elastic,npoin_elastic, &
+ rmass_inverse_acoustic,npoin_acoustic, &
+ rmass_s_inverse_poroelastic, &
+ rmass_w_inverse_poroelastic,npoin_poroelastic, &
+ nspec,ibool,kmato,wxgll,wzgll,jacobian, &
+ elastic,poroelastic, &
+ assign_external_model,numat, &
+ density,poroelastcoef,porosity,tortuosity, &
+ vpext,rhoext)
+
+
+
+#ifdef USE_MPI
+ if ( nproc > 1 ) then
+
+ ! preparing for MPI communications
+ if(ipass == 1) allocate(mask_ispec_inner_outer(nspec))
+ mask_ispec_inner_outer(:) = .false.
+
+ call get_MPI(nspec,ibool,knods,ngnod,npoin,elastic,poroelastic, &
+ ninterface, max_interface_size, &
+ my_nelmnts_neighbours,my_interfaces,my_neighbours, &
+ 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, &
+ myrank,ipass,coord)
+
+
+ nspec_outer = count(mask_ispec_inner_outer)
+ nspec_inner = nspec - nspec_outer
+
+ 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
+ if ( mask_ispec_inner_outer(ispec) ) then
+ num_ispec_outer = num_ispec_outer + 1
+ ispec_outer_to_glob(num_ispec_outer) = ispec
+ else
+ num_ispec_inner = num_ispec_inner + 1
+ ispec_inner_to_glob(num_ispec_inner) = ispec
+ endif
+ enddo
+ endif
+
+ ! buffers for MPI communications
+ max_ibool_interfaces_size_ac = maxval(nibool_interfaces_acoustic(:))
+ max_ibool_interfaces_size_el = 3*maxval(nibool_interfaces_elastic(:))
+ max_ibool_interfaces_size_po = NDIM*maxval(nibool_interfaces_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_poro(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
+
+! assembling the mass matrix
+ call assemble_MPI_scalar(rmass_inverse_acoustic,npoin_acoustic, &
+ rmass_inverse_elastic,npoin_elastic, &
+ rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic,npoin_poroelastic, &
+ ninterface, max_interface_size, max_ibool_interfaces_size_ac, &
+ max_ibool_interfaces_size_el, &
+ max_ibool_interfaces_size_po, &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic, &
+ ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic,nibool_interfaces_elastic, &
+ nibool_interfaces_poroelastic,my_neighbours)
+
+ else
+ ninterface_acoustic = 0
+ ninterface_elastic = 0
+ ninterface_poroelastic = 0
+
+ num_ispec_outer = 0
+ num_ispec_inner = 0
+ if(ipass == 1) allocate(mask_ispec_inner_outer(1))
+
+ nspec_outer = 0
+ nspec_inner = nspec
+
+ if(ipass == 1) allocate(ispec_inner_to_glob(nspec_inner))
+ do ispec = 1, nspec
+ ispec_inner_to_glob(ispec) = ispec
+ enddo
+
+ endif ! end of test on wether there is more than one process (nproc > 1)
+
+#else
+ num_ispec_outer = 0
+ num_ispec_inner = 0
+ if(ipass == 1) allocate(mask_ispec_inner_outer(1))
+
+ nspec_outer = 0
+ nspec_inner = nspec
+
+ if(ipass == 1) then
+ allocate(ispec_outer_to_glob(1))
+ allocate(ispec_inner_to_glob(nspec_inner))
+ endif
+ 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 inner/outer passes
+!
+!============================================
+
+!---
+!--- end of section performed in two passes
+!---
+
+ call invert_mass_matrix(any_elastic,any_acoustic,any_poroelastic,&
+ rmass_inverse_elastic,npoin_elastic, &
+ rmass_inverse_acoustic,npoin_acoustic, &
+ rmass_s_inverse_poroelastic, &
+ rmass_w_inverse_poroelastic,npoin_poroelastic)
+
+! check the mesh, stability and number of points per wavelength
+ 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,permeability,ibool,kmato, &
+ coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
+ assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat, &
+ f0,initialfield,time_function_type, &
+ coorg,xinterp,zinterp,shape2D_display,knods,simulation_title, &
+ npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,all_anisotropic, &
+ myrank,nproc,NSOURCES,poroelastic, &
+ freq0,Q0,TURN_VISCATTENUATION_ON)
+
+! convert receiver angle to radians
+ anglerec = anglerec * pi / 180.d0
+
+!
+!---- for color images
+!
+
+ if(output_color_image) then
+ ! prepares dimension of image
+ call prepare_color_image_init(NX_IMAGE_color,NZ_IMAGE_color, &
+ xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image, &
+ coord,npoin,npgeo)
+
+ ! allocate an array for image data
+ allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color))
+ allocate(image_color_vp_display(NX_IMAGE_color,NZ_IMAGE_color))
+
+ ! allocate an array for the grid point that corresponds to a given image data point
+ allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
+ allocate(copy_iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
+
+ ! creates pixels indexing
+ call prepare_color_image_pixels(myrank,NX_IMAGE_color,NZ_IMAGE_color, &
+ xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image, &
+ coord,npoin,coorg,npgeo,nspec,ngnod,knods,ibool, &
+ nb_pixel_loc,iglob_image_color)
+
+
+ ! creating and filling array num_pixel_loc with the positions of each colored
+ ! pixel owned by the local process (useful for parallel jobs)
+ allocate(num_pixel_loc(nb_pixel_loc))
+
+ nb_pixel_loc = 0
+ do i = 1, NX_IMAGE_color
+ do j = 1, NZ_IMAGE_color
+ if ( iglob_image_color(i,j) /= -1 ) then
+ nb_pixel_loc = nb_pixel_loc + 1
+ num_pixel_loc(nb_pixel_loc) = (j-1)*NX_IMAGE_color + i
+ endif
+ enddo
+ enddo
+
+! filling array iglob_image_color, containing info on which process owns which pixels.
+#ifdef USE_MPI
+ allocate(nb_pixel_per_proc(nproc))
+
+ call MPI_GATHER( nb_pixel_loc, 1, MPI_INTEGER, nb_pixel_per_proc(1), &
+ 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ier)
+
+ if ( myrank == 0 ) then
+ allocate(num_pixel_recv(maxval(nb_pixel_per_proc(:)),nproc))
+ allocate(data_pixel_recv(maxval(nb_pixel_per_proc(:))))
+ endif
+
+ allocate(data_pixel_send(nb_pixel_loc))
+ if (nproc > 1) then
+ if (myrank == 0) then
+
+ do iproc = 1, nproc-1
+
+ call MPI_RECV(num_pixel_recv(1,iproc+1),nb_pixel_per_proc(iproc+1), MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ do k = 1, nb_pixel_per_proc(iproc+1)
+ 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
+ iglob_image_color(i,j) = iproc
+
+ enddo
+ enddo
+
+ else
+ call MPI_SEND(num_pixel_loc(1),nb_pixel_loc,MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+ endif
+ endif
+#endif
+
+ if (myrank == 0) write(IOUT,*) 'done locating all the pixels of color images'
+
+ endif ! color_image
+
+!
+!---- initialize seismograms
+!
+ sisux = ZERO ! double precision zero
+ sisuz = ZERO
+
+! initialize arrays to zero
+ displ_elastic = 0._CUSTOM_REAL
+ veloc_elastic = 0._CUSTOM_REAL
+ accel_elastic = 0._CUSTOM_REAL
+
+ displs_poroelastic = 0._CUSTOM_REAL
+ velocs_poroelastic = 0._CUSTOM_REAL
+ accels_poroelastic = 0._CUSTOM_REAL
+ displw_poroelastic = 0._CUSTOM_REAL
+ velocw_poroelastic = 0._CUSTOM_REAL
+ accelw_poroelastic = 0._CUSTOM_REAL
+
+ potential_acoustic = 0._CUSTOM_REAL
+ potential_dot_acoustic = 0._CUSTOM_REAL
+ potential_dot_dot_acoustic = 0._CUSTOM_REAL
+
+!
+!----- Files where viscous damping are saved during forward wavefield calculation
+!
+ if(any_poroelastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE .eq. 2)) then
+ allocate(b_viscodampx(npoin))
+ allocate(b_viscodampz(npoin))
+ write(outputname,'(a,i6.6,a)') 'viscodampingx',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'viscodampingz',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ reclen = CUSTOM_REAL * npoin
+ open(unit=23,file='OUTPUT_FILES/'//outputname,status='old',&
+ action='read',form='unformatted',access='direct',&
+ recl=reclen)
+ open(unit=24,file='OUTPUT_FILES/'//outputname2,status='old',&
+ action='read',form='unformatted',access='direct',&
+ recl=reclen)
+ else
+ reclen = CUSTOM_REAL * npoin
+ open(unit=23,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted',access='direct',&
+ recl=reclen)
+ open(unit=24,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted',access='direct',&
+ recl=reclen)
+ endif
+ else
+ allocate(b_viscodampx(1))
+ allocate(b_viscodampz(1))
+ endif
+
+!
+!----- Files where absorbing signal are saved during forward wavefield calculation
+!
+
+ if( ((SAVE_FORWARD .and. SIMULATION_TYPE ==1) .or. SIMULATION_TYPE == 2) .and. anyabs ) then
+ ! opens files for absorbing boundary data
+ call prepare_absorb_files(myrank,any_elastic,any_poroelastic,any_acoustic, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,SIMULATION_TYPE)
+ endif
+
+ if(anyabs .and. SIMULATION_TYPE == 2) then
+
+ ! reads in absorbing bounday data
+ if(any_elastic) then
+ call prepare_absorb_elastic(NSTEP,p_sv, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_elastic_left,b_absorb_elastic_right, &
+ b_absorb_elastic_bottom,b_absorb_elastic_top)
+
+ endif
+ if(any_poroelastic) then
+ call prepare_absorb_poroelastic(NSTEP, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_poro_s_left,b_absorb_poro_w_left, &
+ b_absorb_poro_s_right,b_absorb_poro_w_right, &
+ b_absorb_poro_s_bottom,b_absorb_poro_w_bottom, &
+ b_absorb_poro_s_top,b_absorb_poro_w_top)
+
+ endif
+ if(any_acoustic) then
+ call prepare_absorb_acoustic(NSTEP, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_acoustic_left,b_absorb_acoustic_right, &
+ b_absorb_acoustic_bottom,b_absorb_acoustic_top)
+ endif
+
+ endif ! if(anyabs .and. SIMULATION_TYPE == 2)
+
+
+
+!
+!----- Read last frame for backward wavefield calculation
+!
+
+ if(SIMULATION_TYPE == 2) then
+
+ if(any_elastic) then
+ write(outputname,'(a,i6.6,a)') 'snapshot_rho_kappa_mu_',myrank
+ open(unit = 97, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_rhop_alpha_beta_',myrank
+ open(unit = 98, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ rho_kl(:,:,:) = 0._CUSTOM_REAL
+ mu_kl(:,:,:) = 0._CUSTOM_REAL
+ kappa_kl(:,:,:) = 0._CUSTOM_REAL
+
+ rhop_kl(:,:,:) = 0._CUSTOM_REAL
+ beta_kl(:,:,:) = 0._CUSTOM_REAL
+ alpha_kl(:,:,:) = 0._CUSTOM_REAL
+ rhorho_el_hessian_final2(:,:,:) = 0._CUSTOM_REAL
+ rhorho_el_hessian_temp2(:) = 0._CUSTOM_REAL
+ rhorho_el_hessian_final1(:,:,:) = 0._CUSTOM_REAL
+ rhorho_el_hessian_temp1(:) = 0._CUSTOM_REAL
+ endif
+
+ if(any_poroelastic) then
+
+ ! Primary kernels
+ write(outputname,'(a,i6.6,a)') 'snapshot_mu_B_C_',myrank
+ open(unit = 144, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_M_rho_rhof_',myrank
+ open(unit = 155, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_m_eta_',myrank
+ open(unit = 16, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ ! Wavespeed kernels
+ write(outputname,'(a,i6.6,a)') 'snapshot_cpI_cpII_cs_',myrank
+ open(unit = 20, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_rhobb_rhofbb_ratio_',myrank
+ open(unit = 21, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_phib_eta_',myrank
+ open(unit = 22, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ ! Density normalized kernels
+ write(outputname,'(a,i6.6,a)') 'snapshot_mub_Bb_Cb_',myrank
+ open(unit = 17, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_Mb_rhob_rhofb_',myrank
+ open(unit = 18, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_mb_etab_',myrank
+ open(unit = 19, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ rhot_kl(:,:,:) = 0._CUSTOM_REAL
+ rhof_kl(:,:,:) = 0._CUSTOM_REAL
+ eta_kl(:,:,:) = 0._CUSTOM_REAL
+ sm_kl(:,:,:) = 0._CUSTOM_REAL
+ mufr_kl(:,:,:) = 0._CUSTOM_REAL
+ B_kl(:,:,:) = 0._CUSTOM_REAL
+ C_kl(:,:,:) = 0._CUSTOM_REAL
+ M_kl(:,:,:) = 0._CUSTOM_REAL
+
+ rhob_kl(:,:,:) = 0._CUSTOM_REAL
+ rhofb_kl(:,:,:) = 0._CUSTOM_REAL
+ phi_kl(:,:,:) = 0._CUSTOM_REAL
+ mufrb_kl(:,:,:) = 0._CUSTOM_REAL
+ Bb_kl(:,:,:) = 0._CUSTOM_REAL
+ Cb_kl(:,:,:) = 0._CUSTOM_REAL
+ Mb_kl(:,:,:) = 0._CUSTOM_REAL
+
+ rhobb_kl(:,:,:) = 0._CUSTOM_REAL
+ rhofbb_kl(:,:,:) = 0._CUSTOM_REAL
+ phib_kl(:,:,:) = 0._CUSTOM_REAL
+ cs_kl(:,:,:) = 0._CUSTOM_REAL
+ cpI_kl(:,:,:) = 0._CUSTOM_REAL
+ cpII_kl(:,:,:) = 0._CUSTOM_REAL
+ ratio_kl(:,:,:) = 0._CUSTOM_REAL
+ endif
+
+ if(any_acoustic) then
+ write(outputname,'(a,i6.6,a)') 'snapshot_rho_kappa_',myrank
+ open(unit = 95, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_rhop_c_',myrank
+ open(unit = 96, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ rho_ac_kl(:,:,:) = 0._CUSTOM_REAL
+ kappa_ac_kl(:,:,:) = 0._CUSTOM_REAL
+
+ rhop_ac_kl(:,:,:) = 0._CUSTOM_REAL
+ alpha_ac_kl(:,:,:) = 0._CUSTOM_REAL
+ rhorho_ac_hessian_final2(:,:,:) = 0._CUSTOM_REAL
+ rhorho_ac_hessian_final1(:,:,:) = 0._CUSTOM_REAL
+ endif
+
+ endif ! if(SIMULATION_TYPE == 2)
+
+!
+!---- read initial fields from external file if needed
+!
+
+! if we are looking a plane wave beyond critical angle we use other method
+ over_critical_angle = .false.
+
+ if(initialfield) then
+
+ ! Calculation of the initial field for a plane wave
+ if( any_elastic ) then
+ call prepare_initialfield(myrank,any_acoustic,any_poroelastic,over_critical_angle, &
+ NSOURCES,source_type,angleforce,x_source,z_source,f0, &
+ npoin,numat,poroelastcoef,density,coord, &
+ angleforce_refl,c_inc,c_refl,cploc,csloc,time_offset, &
+ A_plane, B_plane, C_plane, &
+ accel_elastic,veloc_elastic,displ_elastic)
+ endif
+
+ if( over_critical_angle ) then
+
+ allocate(left_bound(nelemabs*NGLLX))
+ allocate(right_bound(nelemabs*NGLLX))
+ allocate(bot_bound(nelemabs*NGLLZ))
+
+ call prepare_initialfield_paco(myrank,nelemabs,left_bound,right_bound,bot_bound, &
+ numabs,codeabs,ibool,nspec, &
+ source_type,NSOURCES,c_inc,c_refl, &
+ count_bottom,count_left,count_right)
+
+ 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_bottom,NSTEP))
+ allocate(v0z_bot(count_bottom,NSTEP))
+ allocate(t0x_bot(count_bottom,NSTEP))
+ allocate(t0z_bot(count_bottom,NSTEP))
+
+ allocate(displ_paco(NDIM,npoin))
+ allocate(veloc_paco(NDIM,npoin))
+ allocate(accel_paco(NDIM,npoin))
+
+ ! 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_bottom)&
+ ,count_left,count_right,count_bottom,displ_paco,veloc_paco,accel_paco)
+
+ displ_elastic(1,:) = displ_paco(1,:)
+ displ_elastic(3,:) = displ_paco(2,:)
+ veloc_elastic(1,:) = veloc_paco(1,:)
+ veloc_elastic(3,:) = veloc_paco(2,:)
+ accel_elastic(1,:) = accel_paco(1,:)
+ accel_elastic(3,:) = accel_paco(2,:)
+
+ deallocate(left_bound)
+ deallocate(right_bound)
+ deallocate(bot_bound)
+
+ deallocate(displ_paco)
+ deallocate(veloc_paco)
+ deallocate(accel_paco)
+
+ 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(3,:)**2))
+
+ endif ! initialfield
+
+ deltatsquare = deltat * deltat
+ deltatcube = deltatsquare * deltat
+ deltatfourth = deltatsquare * deltatsquare
+
+ twelvedeltat = 12.d0 * deltat
+ fourdeltatsquare = 4.d0 * deltatsquare
+
+! compute the source time function and store it in a text file
+ if(.not. initialfield) then
+
+ allocate(source_time_function(NSOURCES,NSTEP))
+ source_time_function(:,:) = 0._CUSTOM_REAL
+
+ ! computes source time function array
+ call prepare_source_time_function(myrank,NSTEP,NSOURCES,source_time_function, &
+ time_function_type,f0,tshift_src,factor,aval, &
+ t0,nb_proc_source,deltat)
+ else
+ ! uses an initialfield
+ ! dummy allocation
+ allocate(source_time_function(1,1))
+ endif
+
+! determine if coupled fluid-solid simulation
+ coupled_acoustic_elastic = any_acoustic .and. any_elastic
+ coupled_acoustic_poro = any_acoustic .and. any_poroelastic
+
+! fluid/solid (elastic) edge detection
+! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
+! the common nodes forming the edge are computed here
+ if(coupled_acoustic_elastic) then
+
+ if (myrank == 0) then
+ print *
+ print *,'Mixed acoustic/elastic simulation'
+ print *
+ print *,'Beginning of fluid/solid edge detection'
+ endif
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+ do inum = 1, num_fluid_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
+
+! loop on the four edges of the two elements
+ do iedge_acoustic = 1,NEDGES
+ do iedge_elastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
+ fluid_solid_acoustic_iedge(inum) = iedge_acoustic
+ fluid_solid_elastic_iedge(inum) = iedge_elastic
+! print *,'edge ',iedge_acoustic,' of acoustic element ',ispec_acoustic, &
+! ' is in contact with edge ',iedge_elastic,' of elastic element ',ispec_elastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ 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) print *,'Checking fluid/solid edge topology...'
+
+ 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 elastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob2 = ibool(i,j,ispec_acoustic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ call exit_MPI( 'error in fluid/solid coupling buffer')
+
+ enddo
+
+ enddo
+
+ if (myrank == 0) then
+ print *,'End of fluid/solid edge detection'
+ print *
+ endif
+
+ endif
+
+! fluid/solid (poroelastic) edge detection
+! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
+! the common nodes forming the edge are computed here
+ if(coupled_acoustic_poro) then
+ if ( myrank == 0 ) then
+ print *
+ print *,'Mixed acoustic/poroelastic simulation'
+ print *
+ print *,'Beginning of fluid/solid (poroelastic) edge detection'
+ endif
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+ do inum = 1, num_fluid_poro_edges
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+
+! one element must be acoustic and the other must be poroelastic
+ if(ispec_acoustic /= ispec_poroelastic .and. .not. poroelastic(ispec_acoustic) .and. &
+ .not. elastic(ispec_acoustic) .and. poroelastic(ispec_poroelastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_acoustic = 1,NEDGES
+ do iedge_poroelastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic)) then
+ fluid_poro_acoustic_iedge(inum) = iedge_acoustic
+ fluid_poro_poroelastic_iedge(inum) = iedge_poroelastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+
+! make sure fluid/solid (poroelastic) matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
+
+ if ( myrank == 0 ) then
+ print *,'Checking fluid/solid (poroelastic) edge topology...'
+ endif
+
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob2 = ibool(i,j,ispec_acoustic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ call exit_MPI( 'error in fluid/solid (poroelastic) coupling buffer')
+
+ enddo
+
+ enddo
+
+ if ( myrank == 0 ) then
+ print *,'End of fluid/solid (poroelastic) edge detection'
+ print *
+ endif
+
+ endif
+
+! exclude common points between acoustic absorbing edges and acoustic/elastic matching interfaces
+ if(coupled_acoustic_elastic .and. anyabs) then
+
+ if (myrank == 0) &
+ print *,'excluding common points between acoustic absorbing edges and acoustic/elastic matching interfaces, if any'
+
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
+
+! if acoustic absorbing element and acoustic/elastic coupled element is the same
+ if(ispec_acoustic == ispec) then
+
+ if(iedge_acoustic == IBOTTOM) then
+ jbegin_left(ispecabs) = 2
+ jbegin_right(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == ITOP) then
+ jend_left(ispecabs) = NGLLZ - 1
+ jend_right(ispecabs) = NGLLZ - 1
+ endif
+
+ if(iedge_acoustic == ILEFT) then
+ ibegin_bottom(ispecabs) = 2
+ ibegin_top(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == IRIGHT) then
+ iend_bottom(ispecabs) = NGLLX - 1
+ iend_top(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+! exclude common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces
+ if(coupled_acoustic_poro .and. anyabs) then
+
+ if (myrank == 0) &
+ print *,'excluding common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces, if any'
+
+! 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
+
+! 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 == ispec) then
+
+ if(iedge_acoustic == IBOTTOM) then
+ jbegin_left(ispecabs) = 2
+ jbegin_right(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == ITOP) then
+ jend_left(ispecabs) = NGLLZ - 1
+ jend_right(ispecabs) = NGLLZ - 1
+ endif
+
+ if(iedge_acoustic == ILEFT) then
+ ibegin_bottom(ispecabs) = 2
+ ibegin_top(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == IRIGHT) then
+ iend_bottom(ispecabs) = NGLLX - 1
+ iend_top(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+
+! determine if coupled elastic-poroelastic simulation
+ coupled_elastic_poro = any_elastic .and. any_poroelastic
+
+! solid/porous edge detection
+! the two elements forming an edge are already known (computed in meshfem2D),
+! the common nodes forming the edge are computed here
+ if(coupled_elastic_poro) 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'
+ print *
+ print *,'Beginning of solid/porous edge detection'
+ endif
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+
+ do inum = 1, num_solid_poro_edges
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+
+! one element must be elastic and the other must be poroelastic
+ if(ispec_elastic /= ispec_poroelastic .and. elastic(ispec_elastic) .and. &
+ poroelastic(ispec_poroelastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_poroelastic = 1,NEDGES
+ do iedge_elastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic) == &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
+ solid_poro_elastic_iedge(inum) = iedge_elastic
+ solid_poro_poroelastic_iedge(inum) = iedge_poroelastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+! make sure solid/porous matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
+
+ if ( myrank == 0 ) then
+ print *,'Checking solid/porous edge topology...'
+ endif
+
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! get point values for the elastic side
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob2 = ibool(i,j,ispec_poroelastic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ call exit_MPI( 'error in solid/porous coupling buffer')
+
+ enddo
+
+ enddo
+
+ if ( myrank == 0 ) then
+ print *,'End of solid/porous edge detection'
+ print *
+ endif
+
+ endif
+
+! initiation
+ if(any_poroelastic .and. anyabs) then
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+ jbegin_left_poro(ispecabs) = 1
+ jbegin_right_poro(ispecabs) = 1
+
+ jend_left_poro(ispecabs) = NGLLZ
+ jend_right_poro(ispecabs) = NGLLZ
+
+ ibegin_bottom_poro(ispecabs) = 1
+ ibegin_top_poro(ispecabs) = 1
+
+ iend_bottom_poro(ispecabs) = NGLLX
+ iend_top_poro(ispecabs) = NGLLX
+ enddo
+ endif
+
+! exclude common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces
+ if(coupled_elastic_poro .and. anyabs) then
+
+ 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
+
+ ispec = numabs(ispecabs)
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! 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/poroelastic coupled element is the same
+ if(ispec_poroelastic == ispec) then
+
+ if(iedge_poroelastic == IBOTTOM) then
+ jbegin_left_poro(ispecabs) = 2
+ jbegin_right_poro(ispecabs) = 2
+ endif
+
+ if(iedge_poroelastic == ITOP) then
+ jend_left_poro(ispecabs) = NGLLZ - 1
+ jend_right_poro(ispecabs) = NGLLZ - 1
+ endif
+
+ if(iedge_poroelastic == ILEFT) then
+ ibegin_bottom_poro(ispecabs) = 2
+ ibegin_top_poro(ispecabs) = 2
+ endif
+
+ if(iedge_poroelastic == IRIGHT) then
+ iend_bottom_poro(ispecabs) = NGLLX - 1
+ iend_top_poro(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+#ifdef USE_MPI
+ if(OUTPUT_ENERGY) stop 'energy calculation 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=IOUT_ENERGY,file='energy.gnu',status='unknown')
+
+!
+!---- s t a r t t i m e i t e r a t i o n s
+!
+ if (myrank == 0) write(IOUT,400)
+
+ ! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+ ! time_values(1): year
+ ! time_values(2): month of the year
+ ! time_values(3): day of the month
+ ! time_values(5): hour of the day
+ ! time_values(6): minutes of the hour
+ ! time_values(7): seconds of the minute
+ ! time_values(8): milliseconds of the second
+ ! this fails if we cross the end of the month
+ 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
+ month_start = time_values(2)
+ year_start = time_values(1)
+
+ ! prepares image background
+ if(output_color_image) then
+ call prepare_color_image_vp(npoin,image_color_vp_display,iglob_image_color, &
+ NX_IMAGE_color,NZ_IMAGE_color,nb_pixel_loc, &
+ num_pixel_loc,nspec,poroelastic,ibool,kmato, &
+ numat,density,poroelastcoef,porosity,tortuosity, &
+ nproc,myrank,assign_external_model,vpext)
+
+ 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
+
+! Precompute Runge Kutta coefficients if viscous attenuation
+ if(TURN_VISCATTENUATION_ON) then
+ theta_e = (sqrt(Q0**2+1.d0) +1.d0)/(2.d0*pi*freq0*Q0)
+ theta_s = (sqrt(Q0**2+1.d0) -1.d0)/(2.d0*pi*freq0*Q0)
+
+ thetainv = - 1.d0 / theta_s
+ alphaval = 1.d0 + deltat*thetainv + deltat**2*thetainv**2 / 2.d0 + &
+ deltat**3*thetainv**3 / 6.d0 + deltat**4*thetainv**4 / 24.d0
+ betaval = deltat / 2.d0 + deltat**2*thetainv / 3.d0 + deltat**3*thetainv**2 / 8.d0 + deltat**4*thetainv**3 / 24.d0
+ gammaval = deltat / 2.d0 + deltat**2*thetainv / 6.d0 + deltat**3*thetainv**2 / 24.d0
+ print*,'************************************************************'
+ print*,'****** Visco attenuation coefficients (poroelastic) ********'
+ print*,'theta_e = ', theta_e
+ print*,'theta_s = ', theta_s
+ print*,'alpha = ', alphaval
+ print*,'beta = ', betaval
+ print*,'gamma = ', gammaval
+ print*,'************************************************************'
+
+! initialize memory variables for attenuation
+ viscox(:,:,:) = 0.d0
+ viscoz(:,:,:) = 0.d0
+ rx_viscous(:,:,:) = 0.d0
+ rz_viscous(:,:,:) = 0.d0
+
+ 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
+ seismo_current = seismo_current + 1
+
+! compute current time
+ time = (it-1)*deltat
+
+! update displacement using finite-difference time scheme (Newmark)
+ if(any_elastic) then
+ displ_elastic = displ_elastic &
+ + deltat*veloc_elastic &
+ + deltatsquareover2*accel_elastic
+ veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+ accel_elastic = ZERO
+
+ if(SIMULATION_TYPE == 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
+
+ if(any_poroelastic) then
+ !for the solid
+ displs_poroelastic = displs_poroelastic &
+ + deltat*velocs_poroelastic &
+ + deltatsquareover2*accels_poroelastic
+ velocs_poroelastic = velocs_poroelastic + deltatover2*accels_poroelastic
+ accels_poroelastic = ZERO
+ !for the fluid
+ displw_poroelastic = displw_poroelastic &
+ + deltat*velocw_poroelastic &
+ + deltatsquareover2*accelw_poroelastic
+ velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
+ accelw_poroelastic = ZERO
+
+ if(SIMULATION_TYPE == 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
+ b_accels_poroelastic = ZERO
+ !for the fluid
+ b_displw_poroelastic = b_displw_poroelastic &
+ + b_deltat*b_velocw_poroelastic &
+ + b_deltatsquareover2*b_accelw_poroelastic
+ b_velocw_poroelastic = b_velocw_poroelastic + b_deltatover2*b_accelw_poroelastic
+ b_accelw_poroelastic = ZERO
+ endif
+ endif
+
+!--------------------------------------------------------------------------------------------
+! implement viscous attenuation for poroelastic media
+!
+ if(TURN_VISCATTENUATION_ON .and. any_poroelastic) then
+! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+! loop over spectral elements
+
+ do ispec = 1,nspec
+
+ etal_f = poroelastcoef(2,2,kmato(ispec))
+ permlxx = permeability(1,kmato(ispec))
+ permlxz = permeability(2,kmato(ispec))
+ permlzz = permeability(3,kmato(ispec))
+
+ ! calcul of the inverse of k
+
+ detk = permlxx*permlzz - permlxz*permlxz
+
+ if(detk /= ZERO) then
+ invpermlxx = permlzz/detk
+ invpermlxz = -permlxz/detk
+ invpermlzz = permlxx/detk
+ else
+ stop 'Permeability matrix is not invertible'
+ endif
+
+ ! relaxed viscous coef
+ bl_relaxed(1) = etal_f*invpermlxx
+ bl_relaxed(2) = etal_f*invpermlxz
+ bl_relaxed(3) = etal_f*invpermlzz
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ viscox_loc(i,j) = velocw_poroelastic(1,iglob)*bl_relaxed(1) + &
+ velocw_poroelastic(2,iglob)*bl_relaxed(2)
+ viscoz_loc(i,j) = velocw_poroelastic(1,iglob)*bl_relaxed(2) + &
+ velocw_poroelastic(2,iglob)*bl_relaxed(3)
+
+ ! evolution rx_viscous
+ Sn = - (1.d0 - theta_e/theta_s)/theta_s*viscox(i,j,ispec)
+ Snp1 = - (1.d0 - theta_e/theta_s)/theta_s*viscox_loc(i,j)
+ rx_viscous(i,j,ispec) = alphaval * rx_viscous(i,j,ispec) &
+ + betaval * Sn + gammaval * Snp1
+
+ ! evolution rz_viscous
+ Sn = - (1.d0 - theta_e/theta_s)/theta_s*viscoz(i,j,ispec)
+ Snp1 = - (1.d0 - theta_e/theta_s)/theta_s*viscoz_loc(i,j)
+ rz_viscous(i,j,ispec) = alphaval * rz_viscous(i,j,ispec) &
+ + betaval * Sn + gammaval * Snp1
+
+
+ enddo
+ enddo
+
+ ! save visco for Runge-Kutta scheme
+ viscox(:,:,ispec) = viscox_loc(:,:)
+ viscoz(:,:,ispec) = viscoz_loc(:,:)
+
+ enddo ! end of spectral element loop
+ endif ! end of viscous attenuation for porous media
+
+!-----------------------------------------
+ if(any_acoustic) then
+
+ ! Newmark time scheme
+ 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(SIMULATION_TYPE == 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
+ b_potential_dot_dot_acoustic = ZERO
+ endif
+
+ ! free surface for an acoustic medium
+ if ( nelem_acoustic_surface > 0 ) then
+ call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+
+ if(SIMULATION_TYPE == 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)
+ endif
+ endif
+
+! *********************************************************
+! ************* compute forces for the acoustic elements
+! *********************************************************
+
+! 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,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, &
+! SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top)
+
+
+ call compute_forces_acoustic_2(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, &
+ density,poroelastcoef,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, &
+ SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
+ b_absorb_acoustic_left,b_absorb_acoustic_right, &
+ b_absorb_acoustic_bottom,b_absorb_acoustic_top)
+ if( SIMULATION_TYPE == 2 ) then
+ call compute_forces_acoustic_2(npoin,nspec,nelemabs,numat,it,NSTEP, &
+ anyabs,assign_external_model,ibool,kmato,numabs, &
+ elastic,poroelastic,codeabs,b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
+ b_potential_acoustic, &
+ density,poroelastcoef,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, &
+ SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
+ b_absorb_acoustic_left,b_absorb_acoustic_right, &
+ b_absorb_acoustic_bottom,b_absorb_acoustic_top)
+ endif
+
+
+ ! stores absorbing boundary contributions into files
+ if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
+ !--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do i=1,NGLLZ
+ write(65) b_absorb_acoustic_left(i,ispec,it)
+ enddo
+ enddo
+ endif
+ !--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do i=1,NGLLZ
+ write(66) b_absorb_acoustic_right(i,ispec,it)
+ enddo
+ enddo
+ endif
+ !--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do i=1,NGLLX
+ write(67) b_absorb_acoustic_bottom(i,ispec,it)
+ enddo
+ enddo
+ endif
+ !--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do i=1,NGLLX
+ write(68) b_absorb_acoustic_top(i,ispec,it)
+ enddo
+ enddo
+ endif
+ endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
+
+ endif ! end of test if any acoustic element
+
+! *********************************************************
+! ************* add coupling with the elastic 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 elastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+ displ_x = displ_elastic(1,iglob)
+ displ_z = displ_elastic(3,iglob)
+
+ if(SIMULATION_TYPE == 2) then
+ b_displ_x = b_displ_elastic(1,iglob)
+ b_displ_z = b_displ_elastic(3,iglob)
+ endif
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == 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
+
+! compute dot product
+ displ_n = displ_x*nx + displ_z*nz
+
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
+
+ if(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) +&
+ weight*(b_displ_x*nx + b_displ_z*nz)
+ endif !if(SIMULATION_TYPE == 2) then
+
+ enddo
+
+ enddo
+
+ endif
+
+! *********************************************************
+! ************* add coupling with the poroelastic side
+! *********************************************************
+
+ if(coupled_acoustic_poro) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+ displ_x = displs_poroelastic(1,iglob)
+ displ_z = displs_poroelastic(2,iglob)
+
+ phil = porosity(kmato(ispec_poroelastic))
+ displw_x = displw_poroelastic(1,iglob)
+ displw_z = displw_poroelastic(2,iglob)
+
+ if(SIMULATION_TYPE == 2) then
+ b_displ_x = b_displs_poroelastic(1,iglob)
+ b_displ_z = b_displs_poroelastic(2,iglob)
+
+ b_displw_x = b_displw_poroelastic(1,iglob)
+ b_displw_z = b_displw_poroelastic(2,iglob)
+ endif
+
+! get point values for the acoustic side
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == 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
+
+! compute dot product [u_s + w]*n
+ displ_n = (displ_x + displw_x)*nx + (displ_z + displw_z)*nz
+
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
+
+ if(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
+ + weight*((b_displ_x + b_displw_x)*nx + (b_displ_z + b_displw_z)*nz)
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+
+! ************************************************************************************
+! ************************************ add force source
+! ************************************************************************************
+
+ if(any_acoustic) then
+
+! --- add the source
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCES
+ ! 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(SIMULATION_TYPE == 1) then
+ ! forward wavefield
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - source_time_function(i_source,it)*hlagrange
+ enddo
+ enddo
+ else
+ ! backward wavefield
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
+ - source_time_function(i_source,NSTEP-it+1)*hlagrange
+ enddo
+ enddo
+ 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,NSOURCES
+
+ if(SIMULATION_TYPE == 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
+
+ irec_local = irec_local + 1
+ if (.not. elastic(ispec_selected_rec(irec)) .and. &
+ .not. poroelastic(ispec_selected_rec(irec))) then
+ ! 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 element acoustic
+
+ endif ! if this processor carries the adjoint source
+ enddo ! irec = 1,nrec
+ endif ! SIMULATION_TYPE == 2 adjoint wavefield
+
+ endif ! if not using an initial field
+
+ endif !if(any_acoustic)
+
+
+! 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(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, &
+ buffer_recv_faces_vector_ac, my_neighbours)
+
+ if ( SIMULATION_TYPE == 2) then
+ call assemble_MPI_vector_ac(b_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, &
+ buffer_recv_faces_vector_ac, my_neighbours)
+
+ endif
+
+ endif
+
+! if ( nproc > 1 .and. any_acoustic .and. ninterface_acoustic > 0 .and. SIMULATION_TYPE == 2) then
+! call assemble_MPI_vector_ac(b_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, &
+! buffer_recv_faces_vector_ac, my_neighbours)
+! endif
+#endif
+
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
+
+ if(any_acoustic) then
+
+ potential_dot_dot_acoustic = potential_dot_dot_acoustic * rmass_inverse_acoustic
+ potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
+
+ if(SIMULATION_TYPE ==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)
+
+ if(SIMULATION_TYPE == 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)
+ endif
+
+ endif
+
+ endif !if(any_acoustic)
+
+
+! *********************************************************
+! ************* main solver for the elastic elements
+! *********************************************************
+
+ if(any_elastic) then
+ call compute_forces_viscoelastic(p_sv,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,angleforce,deltatcube, &
+ 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,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy, &
+ 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, &
+ 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_bottom,over_critical_angle, &
+ NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,mu_k,kappa_k)
+
+ if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLZ
+ write(35) b_absorb_elastic_left(1,i,ispec,it)
+ enddo
+ do i=1,NGLLZ
+ write(35) b_absorb_elastic_left(3,i,ispec,it)
+ enddo
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ write(35) b_absorb_elastic_left(2,i,ispec,it)
+ enddo
+ endif
+
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLZ
+ write(36) b_absorb_elastic_right(1,i,ispec,it)
+ enddo
+ do i=1,NGLLZ
+ write(36) b_absorb_elastic_right(3,i,ispec,it)
+ enddo
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ write(36) b_absorb_elastic_right(2,i,ispec,it)
+ enddo
+ endif
+
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLX
+ write(37) b_absorb_elastic_bottom(1,i,ispec,it)
+ enddo
+ do i=1,NGLLX
+ write(37) b_absorb_elastic_bottom(3,i,ispec,it)
+ enddo
+ else!SH (membrane) waves
+ do i=1,NGLLX
+ write(37) b_absorb_elastic_bottom(2,i,ispec,it)
+ enddo
+ endif
+
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLX
+ write(38) b_absorb_elastic_top(1,i,ispec,it)
+ enddo
+ do i=1,NGLLX
+ write(38) b_absorb_elastic_top(3,i,ispec,it)
+ enddo
+ else!SH (membrane) waves
+ do i=1,NGLLX
+ write(38) b_absorb_elastic_top(2,i,ispec,it)
+ enddo
+ endif
+
+ enddo
+ endif
+
+ endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
+
+ 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(SIMULATION_TYPE == 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(3,iglob) = accel_elastic(3,iglob) + weight*nz*pressure
+
+ if(SIMULATION_TYPE == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + weight*nx*b_pressure
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) + weight*nz*b_pressure
+ endif !if(SIMULATION_TYPE == 2) then
+
+ enddo
+
+ enddo
+
+ endif
+
+! ****************************************************************************
+! ************* add coupling with the poroelastic side
+! ****************************************************************************
+ if(coupled_elastic_poro) then
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get poroelastic domain paramters
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec_poroelastic))
+ kappal_s = poroelastcoef(3,1,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec_poroelastic))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec_poroelastic))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
+ kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ mul_G = mul_fr
+ lambdal_G = H_biot - 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
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+
+ b_dwx_dxi = ZERO
+ b_dwz_dxi = ZERO
+
+ b_dwx_dgamma = ZERO
+ b_dwz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec_poroelastic)
+ xizl = xiz(i,j,ispec_poroelastic)
+ gammaxl = gammax(i,j,ispec_poroelastic)
+ gammazl = gammaz(i,j,ispec_poroelastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+
+ b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
+ b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
+
+ b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
+ b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
+ endif
+! compute stress tensor (include attenuation or anisotropy if needed)
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_G*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ if(SIMULATION_TYPE == 2) then
+ b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
+ 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
+ ii2 = ivalue(ipoin1D,iedge_elastic)
+ jj2 = jvalue(ipoin1D,iedge_elastic)
+ iglob = ibool(ii2,jj2,ispec_elastic)
+
+! get elastic properties
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec_elastic))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec_elastic))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec_elastic))
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
+ duz_dxi = duz_dxi + displ_elastic(3,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
+ duz_dgamma = duz_dgamma + displ_elastic(3,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
+ b_duz_dxi = b_duz_dxi + b_displ_elastic(3,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
+ b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
+ b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
+ endif
+ enddo
+
+ xixl = xix(ii2,jj2,ispec_elastic)
+ xizl = xiz(ii2,jj2,ispec_elastic)
+ gammaxl = gammax(ii2,jj2,ispec_elastic)
+ gammazl = gammaz(ii2,jj2,ispec_elastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+ endif
+! compute stress tensor
+! full anisotropy
+ if(kmato(ispec_elastic) == 2) then
+! implement anisotropy in 2D
+ if(assign_external_model) then
+ c11 = c11ext(ii2,jj2,ispec_elastic)
+ c13 = c13ext(ii2,jj2,ispec_elastic)
+ c15 = c15ext(ii2,jj2,ispec_elastic)
+ c33 = c33ext(ii2,jj2,ispec_elastic)
+ c35 = c35ext(ii2,jj2,ispec_elastic)
+ c55 = c55ext(ii2,jj2,ispec_elastic)
+ else
+ c11 = anisotropy(1,kmato(ispec_elastic))
+ c13 = anisotropy(2,kmato(ispec_elastic))
+ c15 = anisotropy(3,kmato(ispec_elastic))
+ c33 = anisotropy(4,kmato(ispec_elastic))
+ c35 = anisotropy(5,kmato(ispec_elastic))
+ c55 = anisotropy(6,kmato(ispec_elastic))
+ end if
+
+ sigma_xx = sigma_xx + c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
+ sigma_zz = sigma_zz + c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
+ sigma_xz = sigma_xz + c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
+ else
+! no attenuation
+ sigma_xx = sigma_xx + lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
+ sigma_xz = sigma_xz + mul_relaxed*(duz_dxl + dux_dzl)
+ sigma_zz = sigma_zz + lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+ endif
+
+ if(SIMULATION_TYPE == 2) then
+ b_sigma_xx = b_sigma_xx + lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
+ b_sigma_xz = b_sigma_xz + mul_relaxed*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = b_sigma_zz + lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
+ endif
+
+! 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_poroelastic == ITOP)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_poroelastic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - weight* &
+ (sigma_xx*nx + sigma_xz*nz)/2.d0
+
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - weight* &
+ (sigma_xz*nx + sigma_zz*nz)/2.d0
+
+ if(SIMULATION_TYPE == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - weight* &
+ (b_sigma_xx*nx + b_sigma_xz*nz)/2.d0
+
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - weight* &
+ (b_sigma_xz*nx + b_sigma_zz*nz)/2.d0
+ endif !if(SIMULATION_TYPE == 2) then
+
+ enddo
+
+ enddo
+
+ endif
+
+
+! ************************************************************************************
+! ************************************ add force source
+! ************************************************************************************
+
+ if(any_elastic) then
+
+! --- add the source if it is a collocated force
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCES
+! 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(SIMULATION_TYPE == 1) then ! forward wavefield
+
+ if(p_sv) then ! P-SV calculation
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) &
+ - sin(angleforce(i_source))*source_time_function(i_source,it)*hlagrange
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) &
+ + cos(angleforce(i_source))*source_time_function(i_source,it)*hlagrange
+ enddo
+ enddo
+ else ! SH (membrane) calculation
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) &
+ + source_time_function(i_source,it)*hlagrange
+ enddo
+ enddo
+ endif
+
+ else ! backward wavefield
+
+ if(p_sv) then ! P-SV calculation
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) &
+ - sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1) &
+ *hlagrange
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) &
+ + cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1) &
+ *hlagrange
+ enddo
+ enddo
+ else ! SH (membrane) calculation
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) &
+ + source_time_function(i_source,NSTEP-it+1)*hlagrange
+ enddo
+ enddo
+
+ endif
+
+ endif !endif SIMULATION_TYPE == 1
+ endif
+
+ endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCES
+
+ endif ! if not using an initial field
+ endif !if(any_elastic)
+
+! 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(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
+
+ if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0 .and. SIMULATION_TYPE == 2) then
+ call assemble_MPI_vector_el(b_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
+
+
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
+
+ if(any_elastic) then
+ accel_elastic(1,:) = accel_elastic(1,:) * rmass_inverse_elastic
+ accel_elastic(2,:) = accel_elastic(2,:) * rmass_inverse_elastic
+ accel_elastic(3,:) = accel_elastic(3,:) * rmass_inverse_elastic
+
+ veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+
+ if(SIMULATION_TYPE == 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_accel_elastic(3,:) = b_accel_elastic(3,:) * rmass_inverse_elastic(:)
+
+ b_veloc_elastic = b_veloc_elastic + b_deltatover2*b_accel_elastic
+ endif
+
+ endif !if(any_elastic)
+
+
+! ******************************************************************************************************************
+! ************* main solver for the poroelastic elements: first the solid (u_s) than the fluid (w)
+! ******************************************************************************************************************
+
+ if(any_poroelastic) then
+
+ if(SIMULATION_TYPE == 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_poro_solid(npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,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_displw_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ 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_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,&
+ mufr_k,B_k,NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,f0(1),freq0,Q0)
+
+
+
+ call compute_forces_poro_fluid(npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
+ accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
+ b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,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_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,&
+ C_k,M_k,NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,f0(1),freq0,Q0)
+
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
+! if inviscid fluid, comment
+! write(23,rec=it) b_viscodampx
+! write(24,rec=it) b_viscodampz
+ endif
+
+ if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ write(45) b_absorb_poro_s_left(id,i,ispec,it)
+ write(25) b_absorb_poro_w_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ write(46) b_absorb_poro_s_right(id,i,ispec,it)
+ write(26) b_absorb_poro_w_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ write(47) b_absorb_poro_s_bottom(id,i,ispec,it)
+ write(29) b_absorb_poro_w_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ write(48) b_absorb_poro_s_top(id,i,ispec,it)
+ write(28) b_absorb_poro_w_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
+
+ endif !if(any_poroelastic) then
+
+! *********************************************************
+! ************* add coupling with the acoustic side
+! *********************************************************
+
+ if(coupled_acoustic_poro) 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(SIMULATION_TYPE == 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(SIMULATION_TYPE == 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(SIMULATION_TYPE == 2) then
+
+ enddo ! do ipoin1D = 1,NGLLX
+
+ enddo ! do inum = 1,num_fluid_poro_edges
+
+ endif ! if(coupled_acoustic_poro)
+
+! ****************************************************************************
+! ************* add coupling with the elastic side
+! ****************************************************************************
+
+ if(coupled_elastic_poro) then
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the elastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! get elastic properties
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec_elastic))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec_elastic))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec_elastic))
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,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(3,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+
+ if(SIMULATION_TYPE == 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(3,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec_elastic)
+ xizl = xiz(i,j,ispec_elastic)
+ gammaxl = gammax(i,j,ispec_elastic)
+ gammazl = gammaz(i,j,ispec_elastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+ endif
+! compute stress tensor
+! full anisotropy
+ if(kmato(ispec_elastic) == 2) then
+! implement anisotropy in 2D
+ if(assign_external_model) then
+ c11 = c11ext(i,j,ispec_elastic)
+ c13 = c13ext(i,j,ispec_elastic)
+ c15 = c15ext(i,j,ispec_elastic)
+ c33 = c33ext(i,j,ispec_elastic)
+ c35 = c35ext(i,j,ispec_elastic)
+ c55 = c55ext(i,j,ispec_elastic)
+ else
+ c11 = anisotropy(1,kmato(ispec_elastic))
+ c13 = anisotropy(2,kmato(ispec_elastic))
+ c15 = anisotropy(3,kmato(ispec_elastic))
+ c33 = anisotropy(4,kmato(ispec_elastic))
+ c35 = anisotropy(5,kmato(ispec_elastic))
+ c55 = anisotropy(6,kmato(ispec_elastic))
+ end if
+ sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
+ sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
+ sigma_xz = c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
+ else
+! 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
+ endif
+
+ if(SIMULATION_TYPE == 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 ! if(SIMULATION_TYPE == 2)
+
+! get point values for the poroelastic side
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get poroelastic domain paramters
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec_poroelastic))
+ kappal_s = poroelastcoef(3,1,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec_poroelastic))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec_poroelastic))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
+ kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ mul_G = mul_fr
+ lambdal_G = H_biot - 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
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+
+ b_dwx_dxi = ZERO
+ b_dwz_dxi = ZERO
+
+ b_dwx_dgamma = ZERO
+ b_dwz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec_poroelastic)
+ xizl = xiz(i,j,ispec_poroelastic)
+ gammaxl = gammax(i,j,ispec_poroelastic)
+ gammazl = gammaz(i,j,ispec_poroelastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+
+ b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
+ b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
+
+ b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
+ b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
+ endif
+! compute stress tensor
+
+! no attenuation
+ sigma_xx = sigma_xx + lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = sigma_xz + mul_G*(duz_dxl + dux_dzl)
+ sigma_zz = sigma_zz + lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+ if(SIMULATION_TYPE == 2) then
+ b_sigma_xx = b_sigma_xx + lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigma_xz = b_sigma_xz + mul_G*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = b_sigma_zz + lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
+ endif
+
+! 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_poroelastic == ITOP)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_poroelastic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+! contribution to the solid phase
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + &
+ weight*((sigma_xx*nx + sigma_xz*nz)/2.d0 -phil/tortl*sigmap*nx)
+
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + &
+ weight*((sigma_xz*nx + sigma_zz*nz)/2.d0 -phil/tortl*sigmap*nz)
+
+! contribution to the fluid phase
+! w = 0
+
+ if(SIMULATION_TYPE == 2) then
+! contribution to the solid phase
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + &
+ weight*((b_sigma_xx*nx + b_sigma_xz*nz)/2.d0 -phil/tortl*b_sigmap*nx)
+
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + &
+ weight*((b_sigma_xz*nx + b_sigma_zz*nz)/2.d0 -phil/tortl*b_sigmap*nz)
+
+! contribution to the fluid phase
+! w = 0
+ endif !if(SIMULATION_TYPE == 2) then
+
+ enddo
+
+ enddo
+
+ endif ! if(coupled_elastic_poro)
+
+
+! ************************************************************************************
+! ******************************** add force source
+! ************************************************************************************
+
+ if(any_poroelastic) then
+
+
+! --- add the source if it is a collocated force
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCES
+! 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
+
+ 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
+
+! collocated force
+ if(source_type(i_source) == 1) then
+ if(SIMULATION_TYPE == 1) then ! forward wavefield
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+! s
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - hlagrange * &
+ (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,it)
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + hlagrange * &
+ (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,it)
+! w
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - hlagrange * &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,it)
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + hlagrange * &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,it)
+ enddo
+ enddo
+ else ! backward wavefield
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+! b_s
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - hlagrange * &
+ (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + hlagrange * &
+ (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+!b_w
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - hlagrange * &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + hlagrange * &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ enddo
+ enddo
+ endif !endif SIMULATION_TYPE == 1
+ endif
+
+ endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCES
+
+ endif ! if not using an initial field
+ endif !if(any_poroelastic)
+
+! 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_poro,buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
+ my_neighbours)
+ endif
+
+ if (nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0 .and. SIMULATION_TYPE == 2) then
+ call assemble_MPI_vector_po(b_accels_poroelastic,b_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_poro,buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
+ my_neighbours)
+ endif
+#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(SIMULATION_TYPE == 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)
+
+!*******************************************************************************
+! assembling the displacements on the elastic-poro boundaries
+!*******************************************************************************
+ if(coupled_elastic_poro) then
+ icount(:)=ZERO
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+ do ipoin1D = 1,NGLLX
+! recovering original velocities and accelerations on boundaries (elastic side)
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+ icount(iglob) = icount(iglob) + 1
+
+ if(icount(iglob) ==1)then
+ veloc_elastic(1,iglob) = veloc_elastic(1,iglob) - deltatover2*accel_elastic(1,iglob)
+ veloc_elastic(3,iglob) = veloc_elastic(3,iglob) - deltatover2*accel_elastic(3,iglob)
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) / rmass_inverse_elastic(iglob)
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) / rmass_inverse_elastic(iglob)
+! recovering original velocities and accelerations on boundaries (poro side)
+ velocs_poroelastic(1,iglob) = velocs_poroelastic(1,iglob) - deltatover2*accels_poroelastic(1,iglob)
+ velocs_poroelastic(2,iglob) = velocs_poroelastic(2,iglob) - deltatover2*accels_poroelastic(2,iglob)
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) / rmass_s_inverse_poroelastic(iglob)
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) / rmass_s_inverse_poroelastic(iglob)
+! assembling accelerations
+ accel_elastic(1,iglob) = ( accel_elastic(1,iglob) + accels_poroelastic(1,iglob) ) / &
+ ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
+ accel_elastic(3,iglob) = ( accel_elastic(3,iglob) + accels_poroelastic(2,iglob) ) / &
+ ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
+ accels_poroelastic(1,iglob) = accel_elastic(1,iglob)
+ accels_poroelastic(2,iglob) = accel_elastic(3,iglob)
+! updating velocities
+ velocs_poroelastic(1,iglob) = velocs_poroelastic(1,iglob) + deltatover2*accels_poroelastic(1,iglob)
+ velocs_poroelastic(2,iglob) = velocs_poroelastic(2,iglob) + deltatover2*accels_poroelastic(2,iglob)
+ veloc_elastic(1,iglob) = veloc_elastic(1,iglob) + deltatover2*accel_elastic(1,iglob)
+ veloc_elastic(3,iglob) = veloc_elastic(3,iglob) + deltatover2*accel_elastic(3,iglob)
+! zeros w
+ accelw_poroelastic(1,iglob) = ZERO
+ accelw_poroelastic(2,iglob) = ZERO
+ velocw_poroelastic(1,iglob) = ZERO
+ velocw_poroelastic(2,iglob) = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_veloc_elastic(1,iglob) = b_veloc_elastic(1,iglob) - b_deltatover2*b_accel_elastic(1,iglob)
+ b_veloc_elastic(3,iglob) = b_veloc_elastic(3,iglob) - b_deltatover2*b_accel_elastic(3,iglob)
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) / rmass_inverse_elastic(iglob)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) / rmass_inverse_elastic(iglob)
+! recovering original velocities and accelerations on boundaries (poro side)
+ b_velocs_poroelastic(1,iglob) = b_velocs_poroelastic(1,iglob) - b_deltatover2*b_accels_poroelastic(1,iglob)
+ b_velocs_poroelastic(2,iglob) = b_velocs_poroelastic(2,iglob) - b_deltatover2*b_accels_poroelastic(2,iglob)
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) / rmass_s_inverse_poroelastic(iglob)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) / rmass_s_inverse_poroelastic(iglob)
+! assembling accelerations
+ b_accel_elastic(1,iglob) = ( b_accel_elastic(1,iglob) + b_accels_poroelastic(1,iglob) ) / &
+ ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
+ b_accel_elastic(3,iglob) = ( b_accel_elastic(3,iglob) + b_accels_poroelastic(2,iglob) ) / &
+ ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
+ b_accels_poroelastic(1,iglob) = b_accel_elastic(1,iglob)
+ b_accels_poroelastic(2,iglob) = b_accel_elastic(3,iglob)
+! updating velocities
+ b_velocs_poroelastic(1,iglob) = b_velocs_poroelastic(1,iglob) + b_deltatover2*b_accels_poroelastic(1,iglob)
+ b_velocs_poroelastic(2,iglob) = b_velocs_poroelastic(2,iglob) + b_deltatover2*b_accels_poroelastic(2,iglob)
+ b_veloc_elastic(1,iglob) = b_veloc_elastic(1,iglob) + b_deltatover2*b_accel_elastic(1,iglob)
+ b_veloc_elastic(3,iglob) = b_veloc_elastic(3,iglob) + b_deltatover2*b_accel_elastic(3,iglob)
+! zeros w
+ b_accelw_poroelastic(1,iglob) = ZERO
+ b_accelw_poroelastic(2,iglob) = ZERO
+ b_velocw_poroelastic(1,iglob) = ZERO
+ b_velocw_poroelastic(2,iglob) = ZERO
+ endif !if(SIMULATION_TYPE == 2)
+
+ endif !if(icount(iglob) ==1)
+
+ enddo
+
+ enddo
+ endif
+
+! ********************************************************************************************
+! reading lastframe for adjoint/kernels calculation
+! ********************************************************************************************
+ if(it == 1 .and. SIMULATION_TYPE == 2) then
+
+! acoustic medium
+ if(any_acoustic) then
+ write(outputname,'(a,i6.6,a)') 'lastframe_acoustic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ do j=1,npoin
+ read(55) b_potential_acoustic(j),&
+ b_potential_dot_acoustic(j),&
+ b_potential_dot_dot_acoustic(j)
+ enddo
+ close(55)
+
+! free surface for an acoustic medium
+ if ( nelem_acoustic_surface > 0 ) 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)
+ endif
+ endif
+
+! elastic medium
+ if(any_elastic) then
+ write(outputname,'(a,i6.6,a)') 'lastframe_elastic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ if(p_sv)then !P-SV waves
+ do j=1,npoin
+ read(55) (b_displ_elastic(i,j), i=1,NDIM), &
+ (b_veloc_elastic(i,j), i=1,NDIM), &
+ (b_accel_elastic(i,j), i=1,NDIM)
+ enddo
+ b_displ_elastic(3,:) = b_displ_elastic(2,:)
+ b_displ_elastic(2,:) = 0._CUSTOM_REAL
+ b_veloc_elastic(3,:) = b_veloc_elastic(2,:)
+ b_veloc_elastic(2,:) = 0._CUSTOM_REAL
+ b_accel_elastic(3,:) = b_accel_elastic(2,:)
+ b_accel_elastic(2,:) = 0._CUSTOM_REAL
+ else !SH (membrane) waves
+ do j=1,npoin
+ read(55) b_displ_elastic(2,j), &
+ b_veloc_elastic(2,j), &
+ b_accel_elastic(2,j)
+ enddo
+ b_displ_elastic(1,:) = 0._CUSTOM_REAL
+ b_displ_elastic(3,:) = 0._CUSTOM_REAL
+ b_veloc_elastic(1,:) = 0._CUSTOM_REAL
+ b_veloc_elastic(3,:) = 0._CUSTOM_REAL
+ b_accel_elastic(1,:) = 0._CUSTOM_REAL
+ b_accel_elastic(3,:) = 0._CUSTOM_REAL
+ endif
+ close(55)
+ endif
+
+! poroelastic medium
+ if(any_poroelastic) then
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_w',myrank,'.bin'
+ open(unit=56,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ do j=1,npoin
+ read(55) (b_displs_poroelastic(i,j), i=1,NDIM), &
+ (b_velocs_poroelastic(i,j), i=1,NDIM), &
+ (b_accels_poroelastic(i,j), i=1,NDIM)
+ read(56) (b_displw_poroelastic(i,j), i=1,NDIM), &
+ (b_velocw_poroelastic(i,j), i=1,NDIM), &
+ (b_accelw_poroelastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+ close(56)
+ endif
+
+ endif ! if(it == 1 .and. SIMULATION_TYPE == 2)
+
+! ********************************************************************************************
+! kernels calculation
+! ********************************************************************************************
+ if(any_elastic .and. SIMULATION_TYPE == 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(3,iglob)*b_displ_elastic(3,iglob)
+ rhorho_el_hessian_temp1(iglob) = accel_elastic(1,iglob)*accel_elastic(1,iglob) +&
+ accel_elastic(2,iglob)*accel_elastic(2,iglob) +&
+ accel_elastic(3,iglob)*accel_elastic(3,iglob)
+ rhorho_el_hessian_temp2(iglob) = accel_elastic(1,iglob)*b_accel_elastic(1,iglob) +&
+ accel_elastic(2,iglob)*b_accel_elastic(2,iglob) +&
+ accel_elastic(3,iglob)*b_accel_elastic(3,iglob)
+ enddo
+ endif
+
+ if(any_poroelastic .and. SIMULATION_TYPE ==2) then
+ do iglob =1,npoin
+ rhot_k(iglob) = accels_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
+ accels_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob)
+ rhof_k(iglob) = accelw_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
+ accelw_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob) + &
+ accels_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ accels_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ sm_k(iglob) = accelw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ accelw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ eta_k(iglob) = velocw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ velocw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ enddo
+ endif
+
+!---- compute kinetic and potential energy
+ if(OUTPUT_ENERGY) &
+ call compute_energy(displ_elastic,veloc_elastic, &
+ displs_poroelastic,velocs_poroelastic, &
+ displw_poroelastic,velocw_poroelastic, &
+ xix,xiz,gammax,gammaz,jacobian,ibool,elastic,poroelastic,hprime_xx,hprime_zz, &
+ nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ assign_external_model,it,deltat,t0,kmato,poroelastcoef,density, &
+ porosity,tortuosity, &
+ vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext, &
+ anisotropic,anisotropy,wxgll,wzgll,numat, &
+ pressure_element,vector_field_element,e1,e11, &
+ potential_dot_acoustic,potential_dot_dot_acoustic, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS,p_sv)
+
+!---- display time step and max of norm of displacement
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
+ call check_stability(myrank,time,it,NSTEP, &
+ npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ any_elastic_glob,any_elastic,displ_elastic, &
+ any_poroelastic_glob,any_poroelastic, &
+ displs_poroelastic,displw_poroelastic, &
+ any_acoustic_glob,any_acoustic,potential_acoustic, &
+ year_start,month_start,time_start)
+ endif
+
+! loop on all the receivers to compute and store the seismograms
+ do irecloc = 1,nrecloc
+
+ 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_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
+ TURN_ATTENUATION_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_acoustic,npoin_elastic,npoin_poroelastic, &
+ 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_acoustic,npoin_elastic,npoin_poroelastic, &
+ 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_acoustic,npoin_elastic,npoin_poroelastic, &
+ 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_elastic,npoin_poroelastic,ispec)
+ endif
+
+! perform the general interpolation using Lagrange polynomials
+ valux = ZERO
+ valuy = ZERO
+ valuz = ZERO
+ valcurl = ZERO
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ 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 /= 6) then
+
+ dxd = vector_field_element(1,i,j)
+ dzd = vector_field_element(3,i,j)
+
+ else if(seismotype == 6) then
+
+ dxd = potential_acoustic(iglob)
+ dzd = ZERO
+
+ else if(seismotype == 1) then
+
+ if(poroelastic(ispec)) then
+ dxd = displs_poroelastic(1,iglob)
+ dzd = displs_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
+ dxd = displ_elastic(1,iglob)
+ dyd = displ_elastic(2,iglob)
+ dzd = displ_elastic(3,iglob)
+ endif
+
+ else if(seismotype == 2) then
+
+ if(poroelastic(ispec)) then
+ dxd = velocs_poroelastic(1,iglob)
+ dzd = velocs_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
+ dxd = veloc_elastic(1,iglob)
+ dyd = veloc_elastic(2,iglob)
+ dzd = veloc_elastic(3,iglob)
+ endif
+
+ else if(seismotype == 3) then
+
+ if(poroelastic(ispec)) then
+ dxd = accels_poroelastic(1,iglob)
+ dzd = accels_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
+ dxd = accel_elastic(1,iglob)
+ dyd = accel_elastic(2,iglob)
+ dzd = accel_elastic(3,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
+ if(elastic(ispec)) valuy = valuy + dyd*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 /= 6) then
+ if(p_sv) 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) = valuy
+ sisuz(seismo_current,irecloc) = ZERO
+ endif
+ else
+ sisux(seismo_current,irecloc) = valux
+ sisuz(seismo_current,irecloc) = ZERO
+ endif
+ siscurl(seismo_current,irecloc) = valcurl
+
+ enddo
+
+
+!----- writing the kernels
+!
+! kernels output
+ if(SIMULATION_TYPE == 2) then
+
+ if(any_acoustic) then
+
+ do ispec = 1, nspec
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ kappal_ac_global(iglob) = poroelastcoef(3,1,kmato(ispec))
+ rhol_ac_global(iglob) = density(1,kmato(ispec))
+
+! calcul the displacement by computing the gradient of potential / rho
+! and calcul the acceleration by computing the gradient of potential_dot_dot / rho
+ tempx1l = ZERO
+ tempx2l = ZERO
+ b_tempx1l = ZERO
+ b_tempx2l = ZERO
+ do k = 1,NGLLX
+! derivative along x
+ tempx1l = tempx1l + potential_dot_dot_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+ b_tempx1l = b_tempx1l + b_potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+ bb_tempx1l = bb_tempx1l + b_potential_dot_dot_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+! derivative along z
+ tempx2l = tempx2l + potential_dot_dot_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+ b_tempx2l = b_tempx2l + b_potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+ bb_tempx2l = bb_tempx2l + b_potential_dot_dot_acoustic(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)
+
+ if(assign_external_model) rhol_ac_global(iglob) = rhoext(i,j,ispec)
+
+! derivatives of potential
+ accel_ac(1,iglob) = (tempx1l*xixl + tempx2l*gammaxl) / rhol_ac_global(iglob)
+ accel_ac(2,iglob) = (tempx1l*xizl + tempx2l*gammazl) / rhol_ac_global(iglob)
+ b_displ_ac(1,iglob) = (b_tempx1l*xixl + b_tempx2l*gammaxl) / rhol_ac_global(iglob)
+ b_displ_ac(2,iglob) = (b_tempx1l*xizl + b_tempx2l*gammazl) / rhol_ac_global(iglob)
+ b_accel_ac(1,iglob) = (bb_tempx1l*xixl + bb_tempx2l*gammaxl) / rhol_ac_global(iglob)
+ b_accel_ac(2,iglob) = (bb_tempx1l*xizl + bb_tempx2l*gammazl) / rhol_ac_global(iglob)
+
+ enddo !i = 1, NGLLX
+ enddo !j = 1, NGLLZ
+ endif
+ enddo
+
+ do ispec = 1,nspec
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ rho_ac_kl(i,j,ispec) = rho_ac_kl(i,j,ispec) - rhol_ac_global(iglob) * &
+ dot_product(accel_ac(:,iglob),b_displ_ac(:,iglob)) * deltat
+ kappa_ac_kl(i,j,ispec) = kappa_ac_kl(i,j,ispec) - kappal_ac_global(iglob) * &
+ potential_dot_dot_acoustic(iglob)/kappal_ac_global(iglob) * &
+ b_potential_dot_dot_acoustic(iglob)/kappal_ac_global(iglob)&
+ * deltat
+!
+ rhop_ac_kl(i,j,ispec) = rho_ac_kl(i,j,ispec) + kappa_ac_kl(i,j,ispec)
+ alpha_ac_kl(i,j,ispec) = TWO * kappa_ac_kl(i,j,ispec)
+ rhorho_ac_hessian_final1(i,j,ispec) = rhorho_ac_hessian_final1(i,j,ispec) + &
+ dot_product(accel_ac(:,iglob),accel_ac(:,iglob)) * deltat
+ rhorho_ac_hessian_final2(i,j,ispec) = rhorho_ac_hessian_final2(i,j,ispec) + &
+ dot_product(accel_ac(:,iglob),b_accel_ac(:,iglob)) * deltat
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif !if(any_acoustic)
+
+ if(any_elastic) then
+
+ do ispec = 1, nspec
+ if(elastic(ispec)) then
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ mul_global(iglob) = poroelastcoef(2,1,kmato(ispec))
+ kappal_global(iglob) = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_global(iglob)/3._CUSTOM_REAL
+ rhol_global(iglob) = density(1,kmato(ispec))
+
+ rho_kl(i,j,ispec) = rho_kl(i,j,ispec) - rhol_global(iglob) * rho_k(iglob) * deltat
+ mu_kl(i,j,ispec) = mu_kl(i,j,ispec) - TWO * mul_global(iglob) * mu_k(iglob) * deltat
+ kappa_kl(i,j,ispec) = kappa_kl(i,j,ispec) - kappal_global(iglob) * kappa_k(iglob) * deltat
+!
+ rhop_kl(i,j,ispec) = rho_kl(i,j,ispec) + kappa_kl(i,j,ispec) + mu_kl(i,j,ispec)
+ beta_kl(i,j,ispec) = TWO * (mu_kl(i,j,ispec) - 4._CUSTOM_REAL * mul_global(iglob) &
+ / (3._CUSTOM_REAL * kappal_global(iglob)) * kappa_kl(i,j,ispec))
+ alpha_kl(i,j,ispec) = TWO * (1._CUSTOM_REAL + 4._CUSTOM_REAL * mul_global(iglob)/&
+ (3._CUSTOM_REAL * kappal_global(iglob))) * kappa_kl(i,j,ispec)
+ rhorho_el_hessian_final1(i,j,ispec) = rhorho_el_hessian_final1(i,j,ispec) + rhorho_el_hessian_temp1(iglob) * deltat
+ rhorho_el_hessian_final2(i,j,ispec) = rhorho_el_hessian_final2(i,j,ispec) + rhorho_el_hessian_temp2(iglob) * deltat
+
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif !if(any_elastic)
+
+ if(any_poroelastic) then
+
+ do ispec = 1, nspec
+ if(poroelastic(ispec)) then
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ phil_global(iglob) = porosity(kmato(ispec))
+ tortl_global(iglob) = tortuosity(kmato(ispec))
+ rhol_s_global(iglob) = density(1,kmato(ispec))
+ rhol_f_global(iglob) = density(2,kmato(ispec))
+ rhol_bar_global(iglob) = (1._CUSTOM_REAL - phil_global(iglob))*rhol_s_global(iglob) &
+ + phil_global(iglob)*rhol_f_global(iglob)
+ etal_f_global(iglob) = poroelastcoef(2,2,kmato(ispec))
+ permlxx_global(iglob) = permeability(1,kmato(ispec))
+ permlxz_global(iglob) = permeability(2,kmato(ispec))
+ permlzz_global(iglob) = permeability(3,kmato(ispec))
+ mulfr_global(iglob) = poroelastcoef(2,3,kmato(ispec))
+
+ rhot_kl(i,j,ispec) = rhot_kl(i,j,ispec) - deltat * rhol_bar_global(iglob) * rhot_k(iglob)
+ rhof_kl(i,j,ispec) = rhof_kl(i,j,ispec) - deltat * rhol_f_global(iglob) * rhof_k(iglob)
+ sm_kl(i,j,ispec) = sm_kl(i,j,ispec) - deltat * rhol_f_global(iglob)*tortl_global(iglob)/phil_global(iglob) * sm_k(iglob)
+!at the moment works with constant permeability
+ eta_kl(i,j,ispec) = eta_kl(i,j,ispec) - deltat * etal_f_global(iglob)/permlxx_global(iglob) * eta_k(iglob)
+ B_kl(i,j,ispec) = B_kl(i,j,ispec) - deltat * B_k(iglob)
+ C_kl(i,j,ispec) = C_kl(i,j,ispec) - deltat * C_k(iglob)
+ M_kl(i,j,ispec) = M_kl(i,j,ispec) - deltat * M_k(iglob)
+ mufr_kl(i,j,ispec) = mufr_kl(i,j,ispec) - TWO * deltat * mufr_k(iglob)
+! density kernels
+ rholb = rhol_bar_global(iglob) - phil_global(iglob)*rhol_f_global(iglob)/tortl_global(iglob)
+ rhob_kl(i,j,ispec) = rhot_kl(i,j,ispec) + B_kl(i,j,ispec) + mufr_kl(i,j,ispec)
+ rhofb_kl(i,j,ispec) = rhof_kl(i,j,ispec) + C_kl(i,j,ispec) + M_kl(i,j,ispec) + sm_kl(i,j,ispec)
+ Bb_kl(i,j,ispec) = B_kl(i,j,ispec)
+ Cb_kl(i,j,ispec) = C_kl(i,j,ispec)
+ Mb_kl(i,j,ispec) = M_kl(i,j,ispec)
+ mufrb_kl(i,j,ispec) = mufr_kl(i,j,ispec)
+ phi_kl(i,j,ispec) = - sm_kl(i,j,ispec) - M_kl(i,j,ispec)
+! wave speed kernels
+ dd1 = (1._CUSTOM_REAL+rholb/rhol_f_global(iglob))*ratio**2 + 2._CUSTOM_REAL*ratio +&
+ tortl_global(iglob)/phil_global(iglob)
+ rhobb_kl(i,j,ispec) = rhob_kl(i,j,ispec) - &
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIIsquare + (cpIsquare - cpIIsquare)*( (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1+&
+ (rhol_bar_global(iglob)**2*ratio**2/rhol_f_global(iglob)**2*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+1)*(phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*&
+ (1+rhol_f_global(iglob)/rhol_bar_global(iglob))-1) )/dd1**2 )- FOUR_THIRDS*cssquare )*&
+ Bb_kl(i,j,ispec) - &
+ rhol_bar_global(iglob)*ratio**2/M_biot * (cpIsquare - cpIIsquare)* &
+ (phil_global(iglob)/tortl_global(iglob)*ratio + 1._CUSTOM_REAL)**2/dd1**2*Mb_kl(i,j,ispec) + &
+ rhol_bar_global(iglob)*ratio/C_biot * (cpIsquare - cpIIsquare)* (&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ phil_global(iglob)*ratio/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
+ (1+rhol_bar_global(iglob)*ratio/rhol_f_global(iglob))/dd1**2)*Cb_kl(i,j,ispec)+ &
+ phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
+ rhofbb_kl(i,j,ispec) = rhofb_kl(i,j,ispec) + &
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIIsquare + (cpIsquare - cpIIsquare)*( (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1+&
+ (rhol_bar_global(iglob)**2*ratio**2/rhol_f_global(iglob)**2*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+1)*(phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*&
+ (1+rhol_f_global(iglob)/rhol_bar_global(iglob))-1) )/dd1**2 )- FOUR_THIRDS*cssquare )*&
+ Bb_kl(i,j,ispec) + &
+ rhol_bar_global(iglob)*ratio**2/M_biot * (cpIsquare - cpIIsquare)* &
+ (phil_global(iglob)/tortl_global(iglob)*ratio + 1._CUSTOM_REAL)**2/dd1**2*Mb_kl(i,j,ispec) - &
+ rhol_bar_global(iglob)*ratio/C_biot * (cpIsquare - cpIIsquare)* (&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ phil_global(iglob)*ratio/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
+ (1+rhol_bar_global(iglob)*ratio/rhol_f_global(iglob))/dd1**2)*Cb_kl(i,j,ispec)- &
+ phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
+ phib_kl(i,j,ispec) = phi_kl(i,j,ispec) - &
+ phil_global(iglob)*rhol_bar_global(iglob)/(tortl_global(iglob)*B_biot) * ( cpIsquare - rhol_f_global(iglob)/&
+ rhol_bar_global(iglob)*cpIIsquare- &
+ (cpIsquare-cpIIsquare)*( (TWO*ratio**2*phil_global(iglob)/tortl_global(iglob) + (1._CUSTOM_REAL+&
+ rhol_f_global(iglob)/rhol_bar_global(iglob))*(TWO*ratio*phil_global(iglob)/tortl_global(iglob)+&
+ 1._CUSTOM_REAL))/dd1 + (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)*&
+ ratio/tortl_global(iglob)+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/&
+ rhol_bar_global(iglob))-1._CUSTOM_REAL)*((1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-&
+ TWO*phil_global(iglob)/tortl_global(iglob))*ratio**2+TWO*ratio)/dd1**2 ) - &
+ FOUR_THIRDS*rhol_f_global(iglob)*cssquare/rhol_bar_global(iglob) )*Bb_kl(i,j,ispec) + &
+ rhol_f_global(iglob)/M_biot * (cpIsquare-cpIIsquare)*(&
+ TWO*ratio*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2*((1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)-TWO*phil_global(iglob)/tortl_global(iglob))*ratio**2+TWO*ratio)/dd1**2&
+ )*Mb_kl(i,j,ispec) + &
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*C_biot)*(cpIsquare-cpIIsquare)*ratio* (&
+ (1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob)*ratio)/dd1 - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)*ratio)*((1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-TWO*&
+ phil_global(iglob)/tortl_global(iglob))*ratio+TWO)/dd1**2&
+ )*Cb_kl(i,j,ispec) -&
+ phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
+ cpI_kl(i,j,ispec) = 2._CUSTOM_REAL*cpIsquare/B_biot*rhol_bar_global(iglob)*( &
+ 1._CUSTOM_REAL-phil_global(iglob)/tortl_global(iglob) + &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-&
+ 1._CUSTOM_REAL)/dd1 &
+ )* Bb_kl(i,j,ispec) +&
+ 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) *&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2/dd1*Mb_kl(i,j,ispec)+&
+ 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)/C_biot * &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)*ratio)/dd1*Cb_kl(i,j,ispec)
+ cpII_kl(i,j,ispec) = 2._CUSTOM_REAL*cpIIsquare*rhol_bar_global(iglob)/B_biot * (&
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*rhol_bar_global(iglob)) - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-&
+ 1._CUSTOM_REAL)/dd1 ) * Bb_kl(i,j,ispec) +&
+ 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) * (&
+ 1._CUSTOM_REAL - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2/dd1 )*Mb_kl(i,j,ispec) + &
+ 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)/C_biot * (&
+ 1._CUSTOM_REAL - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+&
+ rhol_bar_global(iglob)/rhol_f_global(iglob)*ratio)/dd1 )*Cb_kl(i,j,ispec)
+ cs_kl(i,j,ispec) = - 8._CUSTOM_REAL/3._CUSTOM_REAL*cssquare*rhol_bar_global(iglob)/B_biot*(1._CUSTOM_REAL-&
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*rhol_bar_global(iglob)))*Bb_kl(i,j,ispec) + &
+ 2._CUSTOM_REAL*(rhol_bar_global(iglob)-rhol_f_global(iglob)*phil_global(iglob)/tortl_global(iglob))/&
+ mulfr_global(iglob)*cssquare*mufrb_kl(i,j,ispec)
+ ratio_kl(i,j,ispec) = ratio*rhol_bar_global(iglob)*phil_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIsquare-cpIIsquare) * ( &
+ phil_global(iglob)/tortl_global(iglob)*(2._CUSTOM_REAL*ratio+1._CUSTOM_REAL+rhol_f_global(iglob)/ &
+ rhol_bar_global(iglob))/dd1 - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*(&
+ 1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-1._CUSTOM_REAL)*(2._CUSTOM_REAL*ratio*(&
+ 1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob)) +&
+ 2._CUSTOM_REAL)/dd1**2 )*Bb_kl(i,j,ispec) + &
+ ratio*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot)*(cpIsquare-cpIIsquare) * &
+ 2._CUSTOM_REAL*phil_global(iglob)/tortl_global(iglob) * (&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2*((1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob))*ratio+1._CUSTOM_REAL)/dd1**2 )*Mb_kl(i,j,ispec) +&
+ ratio*rhol_f_global(iglob)/C_biot*(cpIsquare-cpIIsquare) * (&
+ (2._CUSTOM_REAL*phil_global(iglob)*rhol_bar_global(iglob)*ratio/(tortl_global(iglob)*rhol_f_global(iglob))+&
+ phil_global(iglob)/tortl_global(iglob)+rhol_bar_global(iglob)/rhol_f_global(iglob))/dd1 - &
+ 2._CUSTOM_REAL*phil_global(iglob)/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+&
+ 1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)*ratio)*((1._CUSTOM_REAL+&
+ rhol_bar_global(iglob)/rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob))*ratio+1._CUSTOM_REAL)/&
+ dd1**2 )*Cb_kl(i,j,ispec)
+
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif ! if(any_poroelastic)
+
+ endif ! if(SIMULATION_TYPE == 2)
+
+!
+!---- display results at given time steps
+!
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
+
+!
+! kernels output files
+!
+
+ if(SIMULATION_TYPE == 2 .and. it == NSTEP) then
+
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Writing Kernels file'
+ endif
+
+ if(any_acoustic) then
+ do ispec = 1, nspec
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ xx = coord(1,iglob)
+ zz = coord(2,iglob)
+ write(95,'(5e11.3)')xx,zz,rho_ac_kl(i,j,ispec),kappa_ac_kl(i,j,ispec)
+ write(96,'(5e11.3)')rhorho_ac_hessian_final1(i,j,ispec), rhorho_ac_hessian_final2(i,j,ispec),&
+ rhop_ac_kl(i,j,ispec),alpha_ac_kl(i,j,ispec)
+ enddo
+ enddo
+ enddo
+ close(95)
+ close(96)
+ endif
+
+ if(any_elastic) then
+ do ispec = 1, nspec
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ xx = coord(1,iglob)
+ zz = coord(2,iglob)
+ write(97,'(5e11.3)')xx,zz,rho_kl(i,j,ispec),kappa_kl(i,j,ispec),mu_kl(i,j,ispec)
+ write(98,'(5e11.3)')xx,zz,rhop_kl(i,j,ispec),alpha_kl(i,j,ispec),beta_kl(i,j,ispec)
+ !write(98,'(5e11.3)')rhorho_el_hessian_final1(i,j,ispec), rhorho_el_hessian_final2(i,j,ispec),&
+ ! rhop_kl(i,j,ispec),alpha_kl(i,j,ispec),beta_kl(i,j,ispec)
+ enddo
+ enddo
+ enddo
+ close(97)
+ close(98)
+ endif
+
+ if(any_poroelastic) then
+ do ispec = 1, nspec
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ xx = coord(1,iglob)
+ zz = coord(2,iglob)
+ write(144,'(5e11.3)')xx,zz,mufr_kl(i,j,ispec),B_kl(i,j,ispec),C_kl(i,j,ispec)
+ write(155,'(5e11.3)')xx,zz,M_kl(i,j,ispec),rhot_kl(i,j,ispec),rhof_kl(i,j,ispec)
+ write(16,'(5e11.3)')xx,zz,sm_kl(i,j,ispec),eta_kl(i,j,ispec)
+ write(17,'(5e11.3)')xx,zz,mufrb_kl(i,j,ispec),Bb_kl(i,j,ispec),Cb_kl(i,j,ispec)
+ write(18,'(5e11.3)')xx,zz,Mb_kl(i,j,ispec),rhob_kl(i,j,ispec),rhofb_kl(i,j,ispec)
+ write(19,'(5e11.3)')xx,zz,phi_kl(i,j,ispec),eta_kl(i,j,ispec)
+ write(20,'(5e11.3)')xx,zz,cpI_kl(i,j,ispec),cpII_kl(i,j,ispec),cs_kl(i,j,ispec)
+ write(21,'(5e11.3)')xx,zz,rhobb_kl(i,j,ispec),rhofbb_kl(i,j,ispec),ratio_kl(i,j,ispec)
+ write(22,'(5e11.3)')xx,zz,phib_kl(i,j,ispec),eta_kl(i,j,ispec)
+ enddo
+ enddo
+ enddo
+ close(144)
+ close(155)
+ close(16)
+ close(17)
+ close(18)
+ close(19)
+ close(20)
+ close(21)
+ close(22)
+ endif
+
+ endif
+
+!
+!---- PostScript display
+!
+ if(output_postscript_snapshot) then
+
+ if (myrank == 0) write(IOUT,*) 'Writing PostScript file'
+
+ if(imagetype == 1 .and. p_sv) then
+
+ 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
+ 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, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
+ 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 .and. p_sv) then
+
+ 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
+ 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, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
+ 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 .and. p_sv) then
+
+ 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
+ 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, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
+ 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 == 4 .or. .not. p_sv) then
+
+ if (myrank == 0) write(IOUT,*) 'cannot draw scalar pressure field or y-component field as a vector plot, skipping...'
+
+ else
+ call exit_MPI('wrong type for snapshots')
+ endif
+
+ if (myrank == 0 .and. imagetype /= 4 .and. p_sv) write(IOUT,*) 'PostScript file written'
+
+ endif
+
+!
+!---- display color image
+!
+ if(output_color_image) then
+
+ if (myrank == 0) write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color,' for time step ',it
+
+ if(imagetype == 1) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ else if(imagetype == 2) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ else if(imagetype == 3) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ else if(imagetype == 4 .and. p_sv) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing image of pressure field...'
+
+ 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,npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,e1,e11, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
+
+ else if(imagetype == 4 .and. .not. p_sv) then
+ call exit_MPI('cannot draw pressure field for SH (membrane) waves')
+ else
+ call exit_MPI('wrong type for snapshots')
+ endif
+
+ image_color_data(:,:) = 0.d0
+
+ 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
+ if(p_sv) then !P-SH waves, plot vertical component or pressure
+ image_color_data(i,j) = vector_field_display(3,iglob_image_color(i,j))
+ else !SH (membrane) waves, plot y-component
+ image_color_data(i,j) = vector_field_display(2,iglob_image_color(i,j))
+ endif
+ enddo
+
+! assembling array image_color_data on process zero for color output
+#ifdef USE_MPI
+ 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)
+
+ do k = 1, nb_pixel_per_proc(iproc+1)
+ 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
+
+ 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
+ if(p_sv) then !P-SH waves, plot vertical component or pressure
+ data_pixel_send(k) = vector_field_display(3,iglob_image_color(i,j))
+ else !SH (membrane) waves, plot y-component
+ data_pixel_send(k) = vector_field_display(2,iglob_image_color(i,j))
+ endif
+ enddo
+
+ call MPI_SEND(data_pixel_send(1),nb_pixel_loc,MPI_DOUBLE_PRECISION, 0, 43, MPI_COMM_WORLD, ier)
+
+ endif
+ endif
+
+#endif
+
+ 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
+
+!---- save temporary or final seismograms
+! 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,p_sv)
+
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+
+ 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. SIMULATION_TYPE==1) .or. SIMULATION_TYPE ==2) then
+ if(any_acoustic) then
+ close(65)
+ close(66)
+ close(67)
+ close(68)
+ endif
+ if(any_elastic) then
+ close(35)
+ close(36)
+ close(37)
+ close(38)
+ endif
+ if(any_poroelastic) then
+ close(25)
+ close(45)
+ close(26)
+ close(46)
+ close(29)
+ close(47)
+ close(28)
+ close(48)
+ endif
+ endif
+
+!
+!--- save last frame
+!
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_elastic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving elastic last frame...'
+ write(IOUT,*)
+ endif
+ write(outputname,'(a,i6.6,a)') 'lastframe_elastic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ if(p_sv)then !P-SV waves
+ do j=1,npoin
+ write(55) displ_elastic(1,j), displ_elastic(3,j), &
+ veloc_elastic(1,j), veloc_elastic(3,j), &
+ accel_elastic(1,j), accel_elastic(3,j)
+ enddo
+ else !SH (membrane) waves
+ do j=1,npoin
+ write(55) displ_elastic(2,j), &
+ veloc_elastic(2,j), &
+ accel_elastic(2,j)
+ enddo
+ endif
+ close(55)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_poroelastic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving poroelastic last frame...'
+ write(IOUT,*)
+ endif
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_w',myrank,'.bin'
+ open(unit=56,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ do j=1,npoin
+ write(55) (displs_poroelastic(i,j), i=1,NDIM), &
+ (velocs_poroelastic(i,j), i=1,NDIM), &
+ (accels_poroelastic(i,j), i=1,NDIM)
+ write(56) (displw_poroelastic(i,j), i=1,NDIM), &
+ (velocw_poroelastic(i,j), i=1,NDIM), &
+ (accelw_poroelastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+ close(56)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_acoustic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving acoustic last frame...'
+ write(IOUT,*)
+ endif
+ write(outputname,'(a,i6.6,a)') 'lastframe_acoustic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ do j=1,npoin
+ write(55) potential_acoustic(j),&
+ potential_dot_acoustic(j),&
+ potential_dot_dot_acoustic(j)
+ enddo
+ 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 .and. myrank == 0) then
+ close(IOUT_ENERGY)
+ open(unit=IOUT_ENERGY,file='plotenergy',status='unknown')
+ write(IOUT_ENERGY,*) 'set term postscript landscape color solid "Helvetica" 22'
+ write(IOUT_ENERGY,*) 'set output "energy.ps"'
+ write(IOUT_ENERGY,*) 'set xlabel "Time (s)"'
+ write(IOUT_ENERGY,*) 'set ylabel "Energy (J)"'
+ write(IOUT_ENERGY,*) 'plot "energy.gnu" us 1:4 t ''Total Energy'' w l 1, "energy.gnu" us 1:3 t ''Potential Energy'' w l 2'
+ close(IOUT_ENERGY)
+ endif
+
+ if (.not. any_poroelastic) then
+open(unit=1001,file='DATA/model_velocity.dat_output',status='unknown')
+ if ( .NOT. assign_external_model) then
+allocate(rho_local(ngllx,ngllz,nspec)); rho_local=0.
+allocate(vp_local(ngllx,ngllz,nspec)); vp_local=0.
+allocate(vs_local(ngllx,ngllz,nspec)); vs_local=0.
+!! write(1001,*) npoin
+!! do iglob = 1,npoin
+!! write(1001,*) coord(1,iglob),coord(2,iglob),rho_global(iglob),vp_global(iglob),vs_global(iglob)
+!! end do
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ rho_local(i,j,ispec) = density(1,kmato(ispec))
+ vp_local(i,j,ispec) = sqrt(poroelastcoef(3,1,kmato(ispec))/density(1,kmato(ispec)))
+ vs_local(i,j,ispec) = sqrt(poroelastcoef(2,1,kmato(ispec))/density(1,kmato(ispec)))
+ write(1001,'(I10, 5F13.4)') iglob, coord(1,iglob),coord(2,iglob),&
+ rho_local(i,j,ispec),vp_local(i,j,ispec),vs_local(i,j,ispec)
+ end do
+ end do
+ end do
+ else
+!! write(1001,*) npoin
+!! do iglob = 1,npoin
+!! write(1001,*) coord(1,iglob),coord(2,iglob),rhoext_global(iglob),vpext_global(iglob),vsext_global(iglob)
+!! end do
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ write(1001,'(I10,5F13.4)') iglob, coord(1,iglob),coord(2,iglob),&
+ rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec)
+ end do
+ end do
+ end do
+ endif
+close(1001)
+ endif
+
+! print exit banner
+ if (myrank == 0) call datim(simulation_title)
+
+!
+!---- close output file
+!
+ if(IOUT /= ISTANDARD_OUTPUT) close(IOUT)
+
+!
+!---- end MPI
+!
+#ifdef USE_MPI
+ call MPI_FINALIZE(ier)
+#endif
+
+!
+!---- formats
+!
+
+ 400 format(/1x,41('=')/,' = T i m e e v o l u t i o n l o o p ='/1x,41('=')/)
+
+ end program specfem2D
+
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D/write_seismograms.F90 (from rev 17990, seismo/2D/SPECFEM2D/trunk/src/write_seismograms.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D/write_seismograms.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D/write_seismograms.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -0,0 +1,396 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! 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 princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! write seismograms to text files
+
+ 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,p_sv &
+ )
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: nrec,NSTEP,seismotype
+ integer :: NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current
+ double precision :: t0,deltat
+
+ logical :: p_sv
+
+ integer, intent(in) :: nrecloc,myrank
+ integer, dimension(nrec),intent(in) :: which_proc_receiver
+
+ double precision, dimension(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc), intent(in) :: sisux,sisuz,siscurl
+
+ double precision st_xval(nrec)
+
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ integer irec,length_station_name,length_network_name,iorientation,isample,number_of_components
+
+ character(len=4) chn
+ character(len=1) component
+ character(len=150) sisname
+
+! to write seismograms in single precision SEP and double precision binary format
+ double precision, dimension(:,:), allocatable :: buffer_binary
+
+! scaling factor for Seismic Unix xsu dislay
+ double precision, parameter :: FACTORXSU = 1.d0
+
+
+ integer :: irecloc
+
+#ifdef USE_MPI
+ integer :: ierror
+ integer, dimension(MPI_STATUS_SIZE) :: status
+#endif
+
+!----
+
+! write seismograms in ASCII format
+
+! save displacement, velocity, acceleration or pressure
+ if(seismotype == 1) then
+ component = 'd'
+ else if(seismotype == 2) then
+ component = 'v'
+ else if(seismotype == 3) then
+ component = 'a'
+ else if(seismotype == 4 .or. seismotype == 6) 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 pressures or SH (membrane) waves
+ if(seismotype == 4 .or. seismotype == 6 .or. .not. p_sv) then
+ number_of_components = 1
+ else if(seismotype == 5) then
+ number_of_components = NDIM+1
+ else
+ number_of_components = NDIM
+ endif
+
+ allocate(buffer_binary(NTSTEP_BETWEEN_OUTPUT_SEISMO,number_of_components))
+
+
+ if ( myrank == 0 .and. seismo_offset == 0 ) then
+
+! delete the old files
+ open(unit=11,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown')
+ close(11,status='delete')
+
+ 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 == 6) then
+ open(unit=12,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown',access='direct',recl=4)
+ elseif(.not.p_sv) then
+ open(unit=12,file='OUTPUT_FILES/Uy_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 == 6) then
+ open(unit=13,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown',access='direct',recl=8)
+ elseif(.not.p_sv) then
+ open(unit=13,file='OUTPUT_FILES/Uz_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 /= 6 .and. p_sv) 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
+
+
+ irecloc = 0
+ do irec = 1,nrec
+
+ if ( myrank == 0 ) then
+
+ if ( which_proc_receiver(irec) == myrank ) then
+ irecloc = irecloc + 1
+ 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
+ else
+ call MPI_RECV(buffer_binary(1,1),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
+ if ( number_of_components == 2 ) 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)
+ 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
+ end if
+
+! write trace
+ do iorientation = 1,number_of_components
+
+ if(iorientation == 1) then
+ 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 == 6) chn = 'PRE'
+ ! in case of SH (membrane) waves, use different abbreviation
+ if(.not.p_sv) chn = 'BHY'
+
+ ! create the name of the seismogram file for each slice
+ ! file name includes the name of the station, the network and the component
+ length_station_name = len_trim(station_name(irec))
+ length_network_name = len_trim(network_name(irec))
+
+ ! check that length conforms to standard
+ if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) then
+ call exit_MPI('wrong length of station name')
+ end if
+ if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) then
+ call exit_MPI('wrong length of network name')
+ end if
+
+ write(sisname,"('OUTPUT_FILES/',a,'.',a,'.',a3,'.sem',a1)") station_name(irec)(1:length_station_name),&
+ network_name(irec)(1:length_network_name),chn,component
+
+ ! save seismograms in text format with no subsampling.
+ ! Because we do not subsample the output, this can result in large files
+ ! if the simulation uses many time steps. However, subsampling the output
+ ! here would result in a loss of accuracy when one later convolves
+ ! the results with the source time function
+ if ( seismo_offset == 0 ) then
+ open(unit=11,file=sisname(1:len_trim(sisname)),status='unknown')
+ close(11,status='delete')
+ endif
+ open(unit=11,file=sisname(1:len_trim(sisname)),status='unknown',position='append')
+
+ ! make sure we never write more than the maximum number of time steps
+ ! subtract offset of the source to make sure travel time is correct
+ do isample = 1,seismo_current
+ if(iorientation == 1) then
+ write(11,*) sngl(dble(seismo_offset+isample-1)*deltat - t0),' ', &
+ sngl(buffer_binary(isample,iorientation))
+ else
+ write(11,*) sngl(dble(seismo_offset+isample-1)*deltat - t0),' ', &
+ sngl(buffer_binary(isample,iorientation))
+ endif
+ enddo
+
+ close(11)
+ end do
+
+! write binary seismogram
+ 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 /= 6 .and. p_sv) 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
+
+ else
+ 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
+ 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
+
+ end if
+
+ enddo
+
+ close(12)
+ close(13)
+ if ( seismotype /= 4 .and. seismotype /= 6 .and. p_sv) then
+ close(14)
+ close(15)
+ end if
+ if ( seismotype == 5 ) then
+ close(16)
+ close(17)
+ end if
+
+!----
+
+ deallocate(buffer_binary)
+
+!----
+ if ( myrank == 0 ) then
+
+! ligne de recepteurs pour Xsu
+ open(unit=11,file='OUTPUT_FILES/receiver_line_Xsu_XWindow',status='unknown')
+
+! subtract t0 from seismograms to get correct zero time
+ write(11,110) FACTORXSU,NSTEP,deltat,-t0,nrec
+
+ do irec=1,nrec
+ ! this format statement might now work for larger meshes
+ !write(11,"(f12.5)") st_xval(irec)
+ write(11,*) st_xval(irec)
+ if(irec < nrec) write(11,*) ','
+ enddo
+
+ if(seismotype == 1) then
+ write(11,*) '@title="Ux at displacement@component"@<@Ux_file_single.bin'
+ else if(seismotype == 2) then
+ write(11,*) '@title="Ux at velocity@component"@<@Ux_file_single.bin'
+ else
+ write(11,*) '@title="Ux at acceleration@component"@<@Ux_file_single.bin'
+ endif
+
+ close(11)
+
+! script de visualisation
+ open(unit=11,file='OUTPUT_FILES/show_receiver_line_Xsu',status='unknown')
+ write(11,"('#!/bin/csh')")
+ write(11,*)
+ write(11,*) '/bin/rm -f tempfile receiver_line_Xsu_postscript'
+ write(11,*) '# concatener toutes les lignes'
+ write(11,*) 'tr -d ''\012'' <receiver_line_Xsu_XWindow >tempfile'
+ write(11,*) '# remettre fin de ligne'
+ write(11,*) 'echo " " >> tempfile'
+ write(11,*) '# supprimer espaces, changer arobas, dupliquer'
+ write(11,120)
+ write(11,*) '/bin/rm -f tempfile'
+ write(11,*) '# copier fichier pour sortie postscript'
+ write(11,130)
+ write(11,*) '/bin/rm -f tempfile'
+ write(11,*) 'echo ''rm -f uxpoly.ps uzpoly.ps'' > tempfile'
+ write(11,*) 'cat tempfile receiver_line_Xsu_postscript > tempfile2'
+ write(11,*) '/bin/mv -f tempfile2 receiver_line_Xsu_postscript'
+ write(11,*) '/bin/rm -f tempfile'
+ write(11,*) '# executer commande xsu'
+ write(11,*) 'sh receiver_line_Xsu_XWindow'
+ write(11,*) '/bin/rm -f tempfile tempfile2'
+ close(11)
+
+end if
+
+! formats
+ 110 format('xwigb at xcur=',f8.2,'@n1=',i6,'@d1=',f15.8,'@f1=',f15.8,'@label1="Time@(s)"@label2="x@(m)"@n2=',i6,'@x2=')
+
+ 120 format('sed -e ''1,$s/ //g'' -e ''1,$s/@/ /g'' -e ''1,1p'' -e ''$,$s/Ux/Uz/g'' <tempfile > receiver_line_Xsu_XWindow')
+
+ 130 format('sed -e ''1,$s/xwigb/pswigp/g'' ', &
+ '-e ''1,$s/Ux_file_single.bin/Ux_file_single.bin > uxpoly.ps/g'' ', &
+ '-e ''1,$s/Uz_file_single.bin/Uz_file_single.bin > uzpoly.ps/g'' receiver_line_Xsu_XWindow > receiver_line_Xsu_postscript')
+
+ end subroutine write_seismograms
+
Deleted: seismo/2D/SPECFEM2D/trunk/src/specfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,6863 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!====================================================================================
-!
-! An explicit 2D parallel MPI spectral element solver
-! for the anelastic anisotropic or poroelastic wave equation.
-!
-!====================================================================================
-
-! If you use this code for your own research, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{VaCaSaKoVi99,
-! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
-! D. Komatitsch and J. P. Vilotte},
-! title = {Elastic wave propagation in an irregularly layered medium},
-! journal = {Soil Dynamics and Earthquake Engineering},
-! year = {1999},
-! volume = {18},
-! pages = {11-18},
-! number = {1},
-! doi = {10.1016/S0267-7261(98)00027-X}}
-!
-! @ARTICLE{LeChKoHuTr09,
-! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
-! Shouh Huang and Jeroen Tromp},
-! title = {Effects of realistic surface topography on seismic ground motion
-! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
-! method and {LiDAR DTM}},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {681-693},
-! number = {2A},
-! doi = {10.1785/0120080264}}
-!
-! @ARTICLE{LeChLiKoHuTr08,
-! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
-! and Bor Shouh Huang and Jeroen Tromp},
-! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
-! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2008},
-! volume = {98},
-! pages = {253-264},
-! number = {1},
-! doi = {10.1785/0120070033}}
-!
-! @ARTICLE{LeKoHuTr09,
-! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
-! title = {Effects of topography on seismic wave propagation: An example from
-! northern {T}aiwan},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {314-325},
-! number = {1},
-! doi = {10.1785/0120080020}}
-!
-! @ARTICLE{KoErGoMi10,
-! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
-! David Mich\'ea},
-! title = {High-order finite-element seismic wave propagation modeling with
-! {MPI} on a large {GPU} cluster},
-! journal = {J. Comput. Phys.},
-! year = {2010},
-! volume = {229},
-! pages = {7692-7714},
-! number = {20},
-! doi = {10.1016/j.jcp.2010.06.024}}
-!
-! @ARTICLE{KoGoErMi10,
-! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
-! David Mich\'ea},
-! title = {Modeling the propagation of elastic waves using spectral elements
-! on a cluster of 192 {GPU}s},
-! journal = {Computer Science Research and Development},
-! year = {2010},
-! volume = {25},
-! pages = {75-82},
-! number = {1-2},
-! doi = {10.1007/s00450-010-0109-1}}
-!
-! @ARTICLE{KoMiEr09,
-! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
-! title = {Porting a high-order finite-element earthquake modeling application
-! to {NVIDIA} graphics cards using {CUDA}},
-! journal = {Journal of Parallel and Distributed Computing},
-! year = {2009},
-! volume = {69},
-! pages = {451-460},
-! number = {5},
-! doi = {10.1016/j.jpdc.2009.01.006}}
-!
-! @ARTICLE{LiPoKoTr04,
-! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
-! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
-! journal={Bull. Seismol. Soc. Am.},
-! year = {2004},
-! volume = {94},
-! pages = {1748-1761},
-! number = {5},
-! doi = {10.1785/012004038}}
-!
-! @INCOLLECTION{ChKoViCaVaFe07,
-! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
-! Yann Capdeville and Bernard Valette and Gaetano Festa},
-! title = {Spectral Element Analysis in Seismology},
-! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
-! publisher = {Elsevier - Academic Press},
-! year = {2007},
-! editor = {Ru-Shan Wu and Val\'erie Maupin},
-! volume = {48},
-! series = {Advances in Geophysics},
-! pages = {365-419}}
-!
-! @ARTICLE{KoVi98,
-! author={D. Komatitsch and J. P. Vilotte},
-! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
-! journal={Bull. Seismol. Soc. Am.},
-! year=1998,
-! volume=88,
-! number=2,
-! pages={368-392}}
-!
-! @ARTICLE{KoTr99,
-! author={D. Komatitsch and J. Tromp},
-! year=1999,
-! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
-! journal={Geophys. J. Int.},
-! volume=139,
-! number=3,
-! pages={806-822},
-! doi={10.1046/j.1365-246x.1999.00967.x}}
-!
-! @ARTICLE{KoLiTrSuStSh04,
-! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
-! and Christiane Stidham and John H. Shaw},
-! year=2004,
-! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
-! based upon the Spectral-Element Method},
-! journal={Bull. Seism. Soc. Am.},
-! volume=94,
-! number=1,
-! pages={187-206}}
-!
-! @ARTICLE{MoTr08,
-! author={C. Morency and J. Tromp},
-! title={Spectral-element simulations of wave propagation in poroelastic media},
-! journal={Geophys. J. Int.},
-! year=2008,
-! volume=175,
-! pages={301-345}}
-!
-! and/or other articles from http://web.univ-pau.fr/~dkomati1/publications.html
-!
-! If you use the kernel capabilities of the code, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{LiTr06,
-! author={Qinya Liu and Jeroen Tromp},
-! title={Finite-frequency kernels based on adjoint methods},
-! journal={Bull. Seismol. Soc. Am.},
-! year=2006,
-! volume=96,
-! number=6,
-! pages={2383-2397},
-! doi={10.1785/0120060041}}
-!
-! @ARTICLE{MoLuTr09,
-! author={C. Morency and Y. Luo and J. Tromp},
-! title={Finite-frequency kernels for wave propagation in porous media based upon adjoint methods},
-! year=2009,
-! journal={Geophys. J. Int.},
-! doi={10.1111/j.1365-246X.2009.04332}}
-!
-! If you use the METIS / SCOTCH / CUBIT non-structured capabilities, please also cite:
-!
-! @ARTICLE{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},
-! journal = {Lecture Notes in Computer Science},
-! year = {2008},
-! volume = {5336},
-! pages = {350-363}}
-!
-! version 6.1, Christina Morency and Pieyre Le Loher, March 2010:
-! - added SH (membrane) waves calculation for elastic media
-! - added support for external fully anisotropic media
-! - fixed some bugs in acoustic kernels
-!
-! version 6.0, Christina Morency and Yang Luo, August 2009:
-! - support for poroelastic media
-! - adjoint method for acoustic/elastic/poroelastic
-!
-! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, February 2008:
-! - support for CUBIT and GiD meshes
-! - 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)
-! - merged loops in the solver for efficiency
-! - simplified input of external model
-! - added CPU time information
-! - translated many comments from French to English
-!
-! version 5.1, Dimitri Komatitsch, January 2005:
-! - more general mesher with any number of curved layers
-! - Dirac and Gaussian time sources and corresponding convolution routine
-! - option for acoustic medium instead of elastic
-! - receivers at any location, not only grid points
-! - moment-tensor source at any location, not only a grid point
-! - color snapshots
-! - more flexible DATA/Par_file with any number of comment lines
-! - Xsu scripts for seismograms
-! - subtract t0 from seismograms
-! - seismograms and snapshots in pressure in addition to vector field
-!
-! version 5.0, Dimitri Komatitsch, May 2004:
-! - got rid of useless routines, suppressed commons etc.
-! - weak formulation based explicitly on stress tensor
-! - implementation of full anisotropy
-! - implementation of attenuation based on memory variables
-!
-! based on SPECFEM2D version 4.2, June 1998
-! (c) by Dimitri Komatitsch, Harvard University, USA
-! and Jean-Pierre Vilotte, Institut de Physique du Globe de Paris, France
-!
-! itself based on SPECFEM2D version 1.0, 1995
-! (c) by Dimitri Komatitsch and Jean-Pierre Vilotte,
-! Institut de Physique du Globe de Paris, France
-!
-
-! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
-! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
-! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
-! This permits acoustic-elastic coupling based on a non-iterative time scheme.
-! Displacement is then: u = grad(Chi) / rho
-! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
-! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
-! The source in an acoustic element is a pressure source.
-! First-order acoustic-acoustic discontinuities are also handled automatically
-! because pressure is continuous at such an interface, therefore Chi_dot_dot
-! is continuous, therefore Chi is also continuous, which is consistent with
-! the spectral-element basis functions and with the assembling process.
-! This is the reason why a simple displacement potential u = grad(Chi) would
-! not work because it would be discontinuous at such an interface and would
-! therefore not be consistent with the basis functions.
-
- program specfem2D
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
-! character(len=80) datlin
-
- integer NSOURCES,i_source
- integer, dimension(:), allocatable :: source_type,time_function_type
- double precision, dimension(:), allocatable :: x_source,z_source,xi_source,gamma_source,&
- Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: sourcearray
- double precision :: t0
-
- double precision, dimension(:,:), allocatable :: coorg
-
-! for P-SV or SH (membrane) waves calculation
- logical :: p_sv
-
-! receiver information
- integer :: nrec,ios
- integer, dimension(:), allocatable :: ispec_selected_rec
- double precision, dimension(:), allocatable :: xi_receiver,gamma_receiver,st_xval,st_zval
- character(len=150) dummystring
-
-! for seismograms
- double precision, dimension(:,:), allocatable :: sisux,sisuz,siscurl
- integer :: seismo_offset, seismo_current
-
-! vector field in an element
- real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
-
-! pressure in an element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
-
-! curl in an element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
-
- integer :: i,j,k,it,irec,id,n,ispec,npoin,npgeo,iglob
- integer :: npoin_acoustic
- integer :: npoin_elastic
- integer :: npoin_poroelastic
- logical :: anyabs
- double precision :: dxd,dyd,dzd,dcurld,valux,valuy,valuz,valcurl,hlagrange,rhol,xi,gamma,x,z
-
-! coefficients of the explicit Newmark time scheme
- integer NSTEP
- double precision :: deltatover2,deltatsquareover2,time
- double precision :: deltat
-
-! Gauss-Lobatto-Legendre points and weights
- double precision, dimension(NGLLX) :: xigll
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- double precision, dimension(NGLLZ) :: zigll
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wzgll
-
-! 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
-
-! Jacobian matrix and determinant
- double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the elastic medium
- 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
-
-! material properties of the poroelastic medium (solid phase:s and fluid phase [defined as w=phi(u_f-u_s)]: w)
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- accels_poroelastic,velocs_poroelastic,displs_poroelastic
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- accelw_poroelastic,velocw_poroelastic,displw_poroelastic
- double precision, dimension(:), allocatable :: porosity,tortuosity
- double precision, dimension(:,:), allocatable :: density,permeability
-
-! poroelastic and elastic coefficients
- double precision, dimension(:,:,:), allocatable :: poroelastcoef
-
-! anisotropy parameters
- logical :: all_anisotropic
- double precision :: c11,c13,c15,c33,c35,c55
- logical, dimension(:), allocatable :: anisotropic
- double precision, dimension(:,:), allocatable :: anisotropy
-
-! 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
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: 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
- real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr
- real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,B_biot,cpIsquare,cpIIsquare,cssquare
- real(kind=CUSTOM_REAL) :: ratio,dd1
-
- double precision, dimension(:,:,:), allocatable :: vpext,vsext,rhoext
- double precision, dimension(:,:,:), allocatable :: Qp_attenuationext,Qs_attenuationext
- double precision, dimension(:,:,:), allocatable :: c11ext,c13ext,c15ext,c33ext,c35ext,c55ext
-
- 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,ibool_outer,ibool_inner
- integer, dimension(:,:), allocatable :: knods
- integer, dimension(:), allocatable :: kmato,numabs, &
- ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
-
- integer, dimension(:), allocatable :: ispec_selected_source,iglob_source,&
- is_proc_source,nb_proc_source
- 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,UPPER_LIMIT_DISPLAY
-
- logical interpol,meshvect,modelvect,boundvect,assign_external_model,initialfield, &
- outputgrid,gnuplot,TURN_ATTENUATION_ON,output_postscript_snapshot,output_color_image, &
- plot_lowerleft_corner_only,add_Bielak_conditions,OUTPUT_ENERGY,READ_EXTERNAL_SEP_FILE
-
- double precision :: cutsnaps,sizemax_arrows,anglerec,xirec,gammarec
-
-! for absorbing and acoustic free surface conditions
- integer :: ispec_acoustic_surface,inum
- real(kind=CUSTOM_REAL) :: nx,nz,weight,xxi,zgamma
-
- logical, dimension(:,:), allocatable :: codeabs
-
-! for attenuation
- integer :: N_SLS
- 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, 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
-
-! for viscous attenuation
- double precision, dimension(:,:,:), allocatable :: &
- rx_viscous,rz_viscous,viscox,viscoz
- double precision :: theta_e,theta_s
- double precision :: Q0,freq0
- double precision :: alphaval,betaval,gammaval,thetainv
- logical :: TURN_VISCATTENUATION_ON
- double precision, dimension(NGLLX,NGLLZ) :: viscox_loc,viscoz_loc
- double precision :: Sn,Snp1,etal_f
- double precision, dimension(3):: bl_relaxed
- double precision :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
-! adjoint
- double precision, dimension(:), allocatable :: b_viscodampx,b_viscodampz
- integer reclen
-
-! for fluid/solid coupling and edge detection
- logical, dimension(:), allocatable :: elastic
- integer, dimension(NEDGES) :: i_begin,j_begin,i_end,j_end
- 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 :: num_fluid_solid_edges,ispec_acoustic,ispec_elastic, &
- iedge_acoustic,iedge_elastic,ipoin1D,iglob2
- logical :: any_acoustic,any_acoustic_glob,any_elastic,any_elastic_glob,coupled_acoustic_elastic
- real(kind=CUSTOM_REAL) :: displ_x,displ_z,displ_n,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
- logical :: any_fluid_solid_edges
-
-! for fluid/porous medium coupling and edge detection
- logical, dimension(:), allocatable :: poroelastic
- logical :: any_poroelastic,any_poroelastic_glob
- integer, dimension(:), allocatable :: fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge, &
- fluid_poro_poroelastic_ispec,fluid_poro_poroelastic_iedge
- integer :: num_fluid_poro_edges,iedge_poroelastic
- logical :: coupled_acoustic_poro
- double precision :: mul_G,lambdal_G,lambdalplus2mul_G
- double precision :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
- double precision :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
- double precision :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- double precision :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
- double precision :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
- double precision :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
- double precision :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
- double precision :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
- logical :: any_fluid_poro_edges
-
-! for solid/porous medium coupling and edge detection
- integer, dimension(:), allocatable :: solid_poro_elastic_ispec,solid_poro_elastic_iedge, &
- solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge
- integer :: num_solid_poro_edges,ispec_poroelastic,ii2,jj2
- logical :: coupled_elastic_poro
- integer, dimension(:), allocatable :: icount
- double precision :: sigma_xx,sigma_xz,sigma_zz,sigmap
- double precision :: b_sigma_xx,b_sigma_xz,b_sigma_zz,b_sigmap
- integer, dimension(:), allocatable :: ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,&
- iend_top_poro,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro
- logical :: any_solid_poro_edges
-
-! for adjoint method
- logical :: SAVE_FORWARD ! whether or not the last frame is saved to reconstruct the forward field
- integer :: SIMULATION_TYPE ! 1 = forward wavefield, 2 = backward and adjoint wavefields and kernels
- double precision :: b_deltatover2,b_deltatsquareover2,b_deltat ! coefficients of the explicit Newmark time scheme
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accels_poroelastic,b_velocs_poroelastic,b_displs_poroelastic
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accelw_poroelastic,b_velocw_poroelastic,b_displw_poroelastic
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accel_elastic,b_veloc_elastic,b_displ_elastic
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_potential_dot_dot_acoustic,b_potential_dot_acoustic,b_potential_acoustic
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_ac,b_displ_ac,b_accel_ac
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rho_kl, mu_kl, kappa_kl
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_global, mul_global, kappal_global
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: mu_k, kappa_k,rho_k
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhop_kl, beta_kl, alpha_kl
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rho_ac_kl, kappa_ac_kl
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_ac_global, kappal_ac_global
- 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
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhot_k, rhof_k, sm_k, eta_k, mufr_k, B_k, &
- C_k, M_k
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: phil_global,etal_f_global,rhol_s_global,rhol_f_global,rhol_bar_global, &
- tortl_global,mulfr_global
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: permlxx_global,permlxz_global,permlzz_global
- character(len=150) :: adj_source_file
- integer :: irec_local,nadj_rec_local
- double precision :: xx,zz,rholb,tempx1l,tempx2l,b_tempx1l,b_tempx2l,bb_tempx1l,bb_tempx2l
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: adj_sourcearray
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearrays
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_left,b_absorb_poro_s_left,b_absorb_poro_w_left
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_right,b_absorb_poro_s_right,b_absorb_poro_w_right
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_bottom,b_absorb_poro_s_bottom,b_absorb_poro_w_bottom
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_top,b_absorb_poro_s_top,b_absorb_poro_w_top
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_absorb_acoustic_left,b_absorb_acoustic_right,&
- b_absorb_acoustic_bottom, b_absorb_acoustic_top
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(:), allocatable :: ib_left,ib_right,ib_bottom,ib_top
-
-! for color images
- integer :: NX_IMAGE_color,NZ_IMAGE_color
- double precision :: xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image
- integer, dimension(:,:), allocatable :: iglob_image_color,copy_iglob_image_color
- double precision, dimension(:,:), allocatable :: image_color_data
- double precision, dimension(:,:), allocatable :: image_color_vp_display
- integer :: nb_pixel_loc
- integer, dimension(:), allocatable :: num_pixel_loc
-
-#ifdef USE_MPI
- integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
- integer, dimension(:), allocatable :: nb_pixel_per_proc
- integer, dimension(:,:), allocatable :: num_pixel_recv
- double precision, dimension(:), allocatable :: data_pixel_recv
- double precision, dimension(:), allocatable :: data_pixel_send
-#endif
-
-! timing information for the stations
- character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
-
-! title of the plot
- character(len=60) simulation_title
-
-! Lagrange interpolators at receivers
- double precision, dimension(:), allocatable :: hxir,hgammar,hpxir,hpgammar
- double precision, dimension(:,:), allocatable :: hxir_store,hgammar_store
-
-! Lagrange interpolators at sources
- double precision, dimension(:), allocatable :: hxis,hgammas,hpxis,hpgammas
- double precision, dimension(:,:), allocatable :: hxis_store,hgammas_store
-
-! for Lagrange interpolants
- double precision, external :: hgll
-
-! timer to count elapsed time
- double precision :: time_start
- integer :: year_start,month_start
-
- ! to determine date and time at which the run will finish
- character(len=8) datein
- character(len=10) timein
- character(len=5) :: zone
- integer, dimension(8) :: time_values
-
-! for MPI and partitioning
- integer :: ier
- integer :: nproc
- integer :: myrank
- character(len=150) :: outputname,outputname2
-
- integer :: ninterface
- integer :: max_interface_size
- integer, dimension(:), allocatable :: my_neighbours
- integer, dimension(:), allocatable :: my_nelmnts_neighbours
- integer, dimension(:,:,:), allocatable :: my_interfaces
- integer, dimension(:,:), allocatable :: ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
- integer, dimension(:), allocatable :: nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
-
- integer :: ninterface_acoustic, ninterface_elastic,ninterface_poroelastic
- integer, dimension(:), allocatable :: inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
-
-#ifdef USE_MPI
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_ac
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_ac
- integer, dimension(:), allocatable :: tab_requests_send_recv_acoustic
- 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,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_poro
- integer :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, max_ibool_interfaces_size_po
- integer :: iproc
-#endif
-
-! for overlapping MPI communications with computation
- integer :: nspec_outer, nspec_inner, num_ispec_outer, num_ispec_inner
- integer, dimension(:), allocatable :: ispec_outer_to_glob, ispec_inner_to_glob
- logical, dimension(:), allocatable :: mask_ispec_inner_outer
-
- integer, dimension(:,:), allocatable :: acoustic_surface
- integer, dimension(:,:), allocatable :: acoustic_edges
- logical :: any_acoustic_edges
-
- integer :: ixmin, ixmax, izmin, izmax
-
- integer :: nrecloc, irecloc
- integer, dimension(:), allocatable :: recloc, which_proc_receiver
-
-! mask to sort ibool
- integer, dimension(:), allocatable :: mask_ibool
- integer, dimension(:,:,:), allocatable :: copy_ibool_ori
- integer :: inumber
-
-! to compute analytical initial plane wave field
- double precision :: angleforce_refl, c_inc, c_refl, cploc, csloc
- double precision, dimension(2) :: A_plane, B_plane, C_plane
- double precision :: z0_source, x0_source, time_offset
-
-! beyond critical angle
- integer , dimension(:), allocatable :: left_bound,right_bound,bot_bound
- double precision , dimension(:,:), allocatable :: v0x_left,v0z_left,v0x_right,v0z_right,v0x_bot,v0z_bot
- double precision , dimension(:,:), allocatable :: t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_paco,veloc_paco,displ_paco
- integer count_left,count_right,count_bottom
- 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
- integer :: npoin_outer,npoin_inner
- 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, dimension(:), allocatable :: source_courbe_eros
-
- integer :: nnodes_tangential_curve
- double precision, dimension(:,:), allocatable :: nodes_tangential_curve
- logical :: any_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
-!!!!!!!!!!
- double precision, dimension(:,:,:),allocatable:: rho_local,vp_local,vs_local
-!!!! hessian
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhorho_el_hessian_final1, rhorho_el_hessian_final2
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhorho_el_hessian_temp1, rhorho_el_hessian_temp2
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhorho_ac_hessian_final1, rhorho_ac_hessian_final2
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: weight_line_x, weight_line_z, weight_surface,weight_jacobian
- integer, dimension(:), allocatable :: weight_gll
- real(kind=CUSTOM_REAL) :: zmin_yang, zmax_yang, xmin_yang, xmax_yang
-
-! to help locate elements with a negative Jacobian using OpenDX
- logical :: found_a_negative_jacobian
-
-!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
- logical, parameter :: ADD_PERIODIC_CONDITIONS = .false.
-
-!! DK DK the periodic conditions below are currently specific to a Gmsh model designed by Paul Cristini
-
-!! DK DK the horizontal periodicity distance is:
- double precision, parameter :: PERIODIC_horiz_dist = 0.3597d0
-
-!! DK DK the length of an edge is about 1d-003, thus use e.g. 1/300 of that
- double precision, parameter :: PERIODIC_DETECT_TOL = 1d-003 / 300.d0
-
- integer, parameter :: NSPEC_PERIO = 670 / 2 ! 414 / 2
-
- integer, dimension(NSPEC_PERIO) :: numperio_left
- integer, dimension(NSPEC_PERIO) :: numperio_right
-
- logical, dimension(4,NSPEC_PERIO) :: codeabs_perio_left
- logical, dimension(4,NSPEC_PERIO) :: codeabs_perio_right
-
- integer :: idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
- integer :: ispecperio, ispecperio2, ispec2, i2, j2
- integer :: iglob_target_to_replace, ispec3, i3, j3
-
-!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
-
-!***********************************************************************
-!
-! i n i t i a l i z a t i o n p h a s e
-!
-!***********************************************************************
- call initialize_simulation(nproc,myrank,NUMBER_OF_PASSES, &
- ninterface_acoustic,ninterface_elastic,ninterface_poroelastic)
-
-
- ! reduction of cache misses inner/outer in two passes
- do ipass = 1,NUMBER_OF_PASSES
-
- ! starts reading in Database file
- call read_databases_init(myrank,ipass, &
- simulation_title,SIMULATION_TYPE,SAVE_FORWARD,npgeo, &
- gnuplot,interpol,NTSTEP_BETWEEN_OUTPUT_INFO, &
- output_postscript_snapshot,output_color_image,colors,numbers, &
- meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows, &
- anglerec,initialfield,add_Bielak_conditions, &
- seismotype,imagetype,assign_external_model,READ_EXTERNAL_SEP_FILE, &
- outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON, &
- TURN_VISCATTENUATION_ON,Q0,freq0,p_sv, &
- NSTEP,deltat,NTSTEP_BETWEEN_OUTPUT_SEISMO,NSOURCES)
-
- !
- !--- source information
- !
- if(ipass == 1) then
- allocate( source_type(NSOURCES) )
- allocate( time_function_type(NSOURCES) )
- allocate( x_source(NSOURCES) )
- allocate( z_source(NSOURCES) )
- allocate( f0(NSOURCES) )
- allocate( tshift_src(NSOURCES) )
- allocate( factor(NSOURCES) )
- allocate( angleforce(NSOURCES) )
- allocate( Mxx(NSOURCES) )
- allocate( Mxz(NSOURCES) )
- allocate( Mzz(NSOURCES) )
- allocate( aval(NSOURCES) )
- allocate( ispec_selected_source(NSOURCES) )
- allocate( iglob_source(NSOURCES) )
- allocate( source_courbe_eros(NSOURCES) )
- allocate( xi_source(NSOURCES) )
- allocate( gamma_source(NSOURCES) )
- allocate( is_proc_source(NSOURCES) )
- allocate( nb_proc_source(NSOURCES) )
- allocate( sourcearray(NSOURCES,NDIM,NGLLX,NGLLZ) )
- endif
-
- ! reads in source infos
- call read_databases_sources(NSOURCES,source_type,time_function_type, &
- x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce)
-
- ! sets source parameters
- call set_sources(myrank,NSOURCES,source_type,time_function_type, &
- x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce,aval, &
- t0,initialfield,ipass,deltat)
-
- !
- !---- read attenuation information
- !
- call read_databases_atten(N_SLS,f0_attenuation)
-
- ! 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
-
-
- !
- !---- read the spectral macrobloc nodal coordinates
- !
- if(ipass == 1) allocate(coorg(NDIM,npgeo))
-
- ! reads the spectral macrobloc nodal coordinates
- ! and basic properties of the spectral elements
- call read_databases_coorg_elem(myrank,ipass,npgeo,coorg,numat,ngnod,nspec, &
- pointsdisp,plot_lowerleft_corner_only, &
- 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))
- allocate(dershape2D_display(NDIM,ngnod,pointsdisp,pointsdisp))
- allocate(xix(NGLLX,NGLLZ,nspec))
- allocate(xiz(NGLLX,NGLLZ,nspec))
- allocate(gammax(NGLLX,NGLLZ,nspec))
- allocate(gammaz(NGLLX,NGLLZ,nspec))
- allocate(jacobian(NGLLX,NGLLZ,nspec))
- allocate(flagrange(NGLLX,pointsdisp))
- allocate(xinterp(pointsdisp,pointsdisp))
- allocate(zinterp(pointsdisp,pointsdisp))
- allocate(Uxinterp(pointsdisp,pointsdisp))
- allocate(Uzinterp(pointsdisp,pointsdisp))
- allocate(density(2,numat))
- allocate(anisotropy(6,numat))
- allocate(porosity(numat))
- 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(anisotropic(nspec))
- 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
-
- !
- !---- read the material properties
- !
- call gmat01(density,porosity,tortuosity,anisotropy,permeability,poroelastcoef,numat,&
- myrank,ipass,Qp_attenuation,Qs_attenuation,freq0,Q0,f0(1),TURN_VISCATTENUATION_ON)
- !
- !---- read spectral macrobloc data
- !
- if(ipass == 1) then
- allocate(antecedent_list(nspec))
- allocate(perm(nspec))
- endif
- call read_databases_mato(ipass,nspec,ngnod,kmato,knods, &
- perm,antecedent_list)
-
-
-!-------------------------------------------------------------------------------
-!---- determine if each spectral element is elastic, poroelastic, or acoustic
-!-------------------------------------------------------------------------------
- ! initializes
- any_acoustic = .false.
- any_elastic = .false.
- any_poroelastic = .false.
-
- anisotropic(:) = .false.
- elastic(:) = .false.
- poroelastic(:) = .false.
-
- ! loops over all elements
- do ispec = 1,nspec
-
- if( nint(porosity(kmato(ispec))) == 1 ) then
- ! acoustic domain
- elastic(ispec) = .false.
- poroelastic(ispec) = .false.
- any_acoustic = .true.
- elseif( porosity(kmato(ispec)) < TINYVAL) then
- ! elastic domain
- elastic(ispec) = .true.
- poroelastic(ispec) = .false.
- any_elastic = .true.
- if(any(anisotropy(:,kmato(ispec)) /= 0)) then
- anisotropic(ispec) = .true.
- end if
- else
- ! poroelastic domain
- elastic(ispec) = .false.
- poroelastic(ispec) = .true.
- any_poroelastic = .true.
- endif
-
- enddo !do ispec = 1,nspec
-
-
- if(.not. p_sv .and. .not. any_elastic) then
- print*, '*************** WARNING ***************'
- print*, 'Surface (membrane) waves calculation needs an elastic medium'
- print*, '*************** WARNING ***************'
- stop
- endif
- if(.not. p_sv .and. (TURN_ATTENUATION_ON)) then
- print*, '*************** WARNING ***************'
- print*, 'Attenuation and anisotropy are not implemented for surface (membrane) waves calculation'
- print*, '*************** WARNING ***************'
- stop
- endif
-
-
- if(TURN_ATTENUATION_ON) then
- nspec_allocate = nspec
- else
- nspec_allocate = 1
- 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))
- e1(:,:,:,:) = 0._CUSTOM_REAL
- e11(:,:,:,:) = 0._CUSTOM_REAL
- e13(:,:,:,:) = 0._CUSTOM_REAL
-
- allocate(dux_dxl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(duz_dzl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(duz_dxl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(dux_dzl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(dux_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
- 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 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))
- allocate(viscox(NGLLX,NGLLZ,nspec))
- allocate(viscoz(NGLLX,NGLLZ,nspec))
- else
- allocate(rx_viscous(NGLLX,NGLLZ,1))
- allocate(rz_viscous(NGLLX,NGLLZ,1))
- allocate(viscox(NGLLX,NGLLZ,1))
- allocate(viscoz(NGLLX,NGLLZ,1))
- endif
- endif
-
- !
- !---- read interfaces data
- !
- call read_databases_ninterface(ninterface,max_interface_size)
- 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))
- allocate(ibool_interfaces_acoustic(NGLLX*max_interface_size,ninterface))
- allocate(ibool_interfaces_elastic(NGLLX*max_interface_size,ninterface))
- allocate(ibool_interfaces_poroelastic(NGLLX*max_interface_size,ninterface))
- allocate(nibool_interfaces_acoustic(ninterface))
- allocate(nibool_interfaces_elastic(ninterface))
- allocate(nibool_interfaces_poroelastic(ninterface))
- allocate(inum_interfaces_acoustic(ninterface))
- allocate(inum_interfaces_elastic(ninterface))
- allocate(inum_interfaces_poroelastic(ninterface))
- endif
- call read_databases_interfaces(ipass,ninterface,nspec,max_interface_size, &
- my_neighbours,my_nelmnts_neighbours,my_interfaces, &
- perm,antecedent_list)
-
- endif
-
-
-! --- allocate arrays for absorbing boundary conditions
-
- if(nelemabs <= 0) then
- nelemabs = 1
- anyabs = .false.
- else
- anyabs = .true.
- endif
-
- if(ipass == 1) then
- allocate(numabs(nelemabs))
- allocate(codeabs(4,nelemabs))
-
- allocate(ibegin_bottom(nelemabs))
- allocate(iend_bottom(nelemabs))
- allocate(ibegin_top(nelemabs))
- allocate(iend_top(nelemabs))
-
- allocate(jbegin_left(nelemabs))
- allocate(jend_left(nelemabs))
- allocate(jbegin_right(nelemabs))
- allocate(jend_right(nelemabs))
-
- allocate(ibegin_bottom_poro(nelemabs))
- allocate(iend_bottom_poro(nelemabs))
- allocate(ibegin_top_poro(nelemabs))
- allocate(iend_top_poro(nelemabs))
-
- allocate(jbegin_left_poro(nelemabs))
- allocate(jend_left_poro(nelemabs))
- allocate(jbegin_right_poro(nelemabs))
- allocate(jend_right_poro(nelemabs))
-
- allocate(ib_left(nelemabs))
- allocate(ib_right(nelemabs))
- allocate(ib_bottom(nelemabs))
- allocate(ib_top(nelemabs))
-
- endif
-
- !
- !---- read absorbing boundary data
- !
- call read_databases_absorbing(myrank,ipass,nelemabs,nspec,anyabs, &
- ibegin_bottom,iend_bottom,jbegin_right,jend_right, &
- ibegin_top,iend_top,jbegin_left,jend_left, &
- numabs,codeabs,perm,antecedent_list, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- ib_right,ib_left,ib_bottom,ib_top)
-
-
- if( anyabs ) then
- ! Files to save absorbed waves needed to reconstruct backward wavefield for adjoint method
- if(ipass == 1) then
- if(any_elastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 2)) then
- allocate(b_absorb_elastic_left(3,NGLLZ,nspec_xmin,NSTEP))
- allocate(b_absorb_elastic_right(3,NGLLZ,nspec_xmax,NSTEP))
- allocate(b_absorb_elastic_bottom(3,NGLLX,nspec_zmin,NSTEP))
- allocate(b_absorb_elastic_top(3,NGLLX,nspec_zmax,NSTEP))
- else
- allocate(b_absorb_elastic_left(1,1,1,1))
- allocate(b_absorb_elastic_right(1,1,1,1))
- allocate(b_absorb_elastic_bottom(1,1,1,1))
- allocate(b_absorb_elastic_top(1,1,1,1))
- endif
- if(any_poroelastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 2)) then
- allocate(b_absorb_poro_s_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
- allocate(b_absorb_poro_s_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
- allocate(b_absorb_poro_s_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
- allocate(b_absorb_poro_s_top(NDIM,NGLLX,nspec_zmax,NSTEP))
- allocate(b_absorb_poro_w_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
- allocate(b_absorb_poro_w_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
- allocate(b_absorb_poro_w_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
- allocate(b_absorb_poro_w_top(NDIM,NGLLX,nspec_zmax,NSTEP))
- else
- allocate(b_absorb_poro_s_left(1,1,1,1))
- allocate(b_absorb_poro_s_right(1,1,1,1))
- allocate(b_absorb_poro_s_bottom(1,1,1,1))
- allocate(b_absorb_poro_s_top(1,1,1,1))
- allocate(b_absorb_poro_w_left(1,1,1,1))
- allocate(b_absorb_poro_w_right(1,1,1,1))
- allocate(b_absorb_poro_w_bottom(1,1,1,1))
- allocate(b_absorb_poro_w_top(1,1,1,1))
- endif
- if(any_acoustic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 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))
- else
- allocate(b_absorb_acoustic_left(1,1,1))
- allocate(b_absorb_acoustic_right(1,1,1))
- allocate(b_absorb_acoustic_bottom(1,1,1))
- allocate(b_absorb_acoustic_top(1,1,1))
- endif
- endif
-
- else
-
- if(.not. allocated(b_absorb_elastic_left)) then
- allocate(b_absorb_elastic_left(1,1,1,1))
- allocate(b_absorb_elastic_right(1,1,1,1))
- allocate(b_absorb_elastic_bottom(1,1,1,1))
- allocate(b_absorb_elastic_top(1,1,1,1))
- endif
-
- if(.not. allocated(b_absorb_poro_s_left)) then
- allocate(b_absorb_poro_s_left(1,1,1,1))
- allocate(b_absorb_poro_s_right(1,1,1,1))
- allocate(b_absorb_poro_s_bottom(1,1,1,1))
- allocate(b_absorb_poro_s_top(1,1,1,1))
- allocate(b_absorb_poro_w_left(1,1,1,1))
- allocate(b_absorb_poro_w_right(1,1,1,1))
- allocate(b_absorb_poro_w_bottom(1,1,1,1))
- allocate(b_absorb_poro_w_top(1,1,1,1))
- endif
-
- if(.not. allocated(b_absorb_acoustic_left)) then
- allocate(b_absorb_acoustic_left(1,1,1))
- allocate(b_absorb_acoustic_right(1,1,1))
- allocate(b_absorb_acoustic_bottom(1,1,1))
- allocate(b_absorb_acoustic_top(1,1,1))
- endif
-
- endif
-
-!
-!---- read acoustic free surface data
-!
- if(nelem_acoustic_surface > 0) then
- any_acoustic_edges = .true.
- else
- any_acoustic_edges = .false.
- nelem_acoustic_surface = 1
- endif
- if( ipass == 1 ) then
- allocate(acoustic_edges(4,nelem_acoustic_surface))
- allocate(acoustic_surface(5,nelem_acoustic_surface))
- endif
- call read_databases_free_surf(ipass,nelem_acoustic_surface,nspec, &
- acoustic_edges,perm,antecedent_list,any_acoustic_edges)
- ! resets nelem_acoustic_surface
- if( any_acoustic_edges .eqv. .false. ) nelem_acoustic_surface = 0
-
- ! constructs acoustic surface
- if(nelem_acoustic_surface > 0) then
- call construct_acoustic_surface ( nspec, ngnod, knods, nelem_acoustic_surface, &
- acoustic_edges, acoustic_surface)
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
- endif
- endif
-
-
- !
- !---- read coupled edges
- !
- if( num_fluid_solid_edges > 0 ) then
- any_fluid_solid_edges = .true.
- else
- any_fluid_solid_edges = .false.
- num_fluid_solid_edges = 1
- endif
- 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
- if( num_fluid_poro_edges > 0 ) then
- any_fluid_poro_edges = .true.
- else
- any_fluid_poro_edges = .false.
- num_fluid_poro_edges = 1
- endif
- 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
- if ( num_solid_poro_edges > 0 ) then
- any_solid_poro_edges = .true.
- else
- any_solid_poro_edges = .false.
- num_solid_poro_edges = 1
- endif
- 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
-
- call read_databases_coupled(ipass,nspec,num_fluid_solid_edges,any_fluid_solid_edges, &
- fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec, &
- num_fluid_poro_edges,any_fluid_poro_edges, &
- fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec, &
- num_solid_poro_edges,any_solid_poro_edges, &
- solid_poro_elastic_ispec,solid_poro_poroelastic_ispec, &
- perm,antecedent_list)
-
- ! resets counters
- if( any_fluid_solid_edges .eqv. .false. ) num_fluid_solid_edges = 0
- if( any_fluid_poro_edges .eqv. .false. ) num_fluid_poro_edges = 0
- if( any_solid_poro_edges .eqv. .false. ) num_solid_poro_edges = 0
-
-
- !
- !---- read tangential detection curve
- ! and close Database file
- !
- if (nnodes_tangential_curve > 0) then
- any_tangential_curve = .true.
- else
- any_tangential_curve = .false.
- nnodes_tangential_curve = 1
- endif
- if (ipass == 1) then
- allocate(nodes_tangential_curve(2,nnodes_tangential_curve))
- allocate(dist_tangential_detection_curve(nnodes_tangential_curve))
- endif
- call read_databases_final(nnodes_tangential_curve,nodes_tangential_curve, &
- force_normal_to_surface,rec_normal_to_surface, &
- any_tangential_curve)
- ! resets nnode_tangential_curve
- if( any_tangential_curve .eqv. .false. ) nnodes_tangential_curve = 0
-
-!
-!---- compute shape functions and their derivatives for SEM grid
-!
-
-! set up Gauss-Lobatto-Legendre derivation matrices
- call define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
- call define_shape_functions(shape2D(:,i,j),dershape2D(:,:,i,j),xigll(i),zigll(j),ngnod)
- enddo
- enddo
-
-!
-!---- generate the global numbering
-!
-
-! "slow and clean" or "quick and dirty" version
- if(FAST_NUMBERING) then
- call createnum_fast(knods,ibool,shape2D,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
- else
- call createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
- endif
-
-! 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))
-
- print *
- print *,'Xmin,Xmax of the whole mesh = ',minval(coord(1,:)),maxval(coord(1,:))
- print *,'Zmin,Zmax of the whole mesh = ',minval(coord(2,:)),maxval(coord(2,:))
- print *
-
-!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
-
- if(ADD_PERIODIC_CONDITIONS) then
-
-#ifdef USE_MPI
- stop 'periodic conditions currently implemented for a serial simulation only (due e.g. to mass matrix rebuilding)'
-#endif
-
- if(any_poroelastic .or. any_acoustic) stop 'periodic conditions currently implemented for purely elastic models only'
-
- if(ACTUALLY_IMPLEMENT_PERM_OUT .or. ACTUALLY_IMPLEMENT_PERM_INN .or. ACTUALLY_IMPLEMENT_PERM_WHOLE) &
- stop 'currently, all permutations should be off for periodic conditions'
-
-print *
-open(unit=123,file='Database00000_left_edge_only',status='old')
-do ispecperio = 1,NSPEC_PERIO
- read(123,*) numperio_left(ispecperio), &
- codeabs_perio_left(IBOTTOM,ispecperio), &
- codeabs_perio_left(IRIGHT,ispecperio), &
- codeabs_perio_left(ITOP,ispecperio), &
- codeabs_perio_left(ILEFT,ispecperio), &
- idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
-enddo
-close(123)
-print *,'read ',NSPEC_PERIO,' elements for left periodic edge'
-
-open(unit=123,file='Database00000_right_edge_only',status='old')
-do ispecperio = 1,NSPEC_PERIO
- read(123,*) numperio_right(ispecperio), &
- codeabs_perio_right(IBOTTOM,ispecperio), &
- codeabs_perio_right(IRIGHT,ispecperio), &
- codeabs_perio_right(ITOP,ispecperio), &
- codeabs_perio_right(ILEFT,ispecperio), &
- idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
-enddo
-close(123)
-print *,'read ',NSPEC_PERIO,' elements for right periodic edge'
-print *
-
-print *,'because of periodic conditions, values computed by checkgrid() are not reliable'
-print *
-
-!---------------------------------------------------------------------------
-
- do ispecperio = 1,NSPEC_PERIO
-
- ispec = numperio_left(ispecperio)
-
-! print *,'dist of edge is ',sqrt((coord(2,ibool(1,1,ispec)) - coord(2,ibool(1,NGLLZ,ispec))) ** 2 + &
-! (coord(1,ibool(1,1,ispec)) - coord(1,ibool(1,NGLLZ,ispec))) ** 2)
-
- if(codeabs_perio_left(ILEFT,ispecperio)) then
- i = 1
- do j = 1,NGLLZ
- iglob = ibool(i,j,ispec)
-!----------------------------------------------------------------------
- include "include_for_periodic_conditions.f90"
-!----------------------------------------------------------------------
- enddo
- endif
-
- if(codeabs_perio_left(IRIGHT,ispecperio)) then
- i = NGLLX
- do j = 1,NGLLZ
- iglob = ibool(i,j,ispec)
-!----------------------------------------------------------------------
- include "include_for_periodic_conditions.f90"
-!----------------------------------------------------------------------
- enddo
- endif
-
- if(codeabs_perio_left(IBOTTOM,ispecperio)) then
- j = 1
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
-!----------------------------------------------------------------------
- include "include_for_periodic_conditions.f90"
-!----------------------------------------------------------------------
- enddo
- endif
-
- if(codeabs_perio_left(ITOP,ispecperio)) then
- j = NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
-!----------------------------------------------------------------------
- include "include_for_periodic_conditions.f90"
-!----------------------------------------------------------------------
- enddo
- endif
-
- enddo
-
-! rebuild the mass matrix based on this new numbering
-!
-!---- build the global mass matrix and invert it once and for all
-!
- rmass_inverse_elastic(:) = 0._CUSTOM_REAL
- 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/3.d0*mul_relaxed
- endif
-
- rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) &
- + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
-
- enddo
- enddo
- enddo ! do ispec = 1,nspec
-
-! invert the mass matrix once and for all
-! set entries that are equal to zero to something else, e.g. 1, to avoid division by zero
-! these degrees of freedom correspond to points that have been replaced with their periodic counterpart
-! and thus are not used any more
- where(rmass_inverse_elastic == 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
- rmass_inverse_elastic(:) = 1._CUSTOM_REAL / rmass_inverse_elastic(:)
-
- endif ! of if(ADD_PERIODIC_CONDITIONS)
-
-!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
-
- mask_ibool(:) = -1
- copy_ibool_ori(:,:,:) = ibool(:,:,:)
-
- inumber = 0
-
- 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
- ! create a new point
- inumber = inumber + 1
- ibool(i,j,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
- else
- ! use an existing point created previously
- ibool(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
- endif
- enddo
- enddo
- enddo
-
-! then reduce cache misses in inner elements, since they are taken second
-! loop over spectral elements
- do ispec = 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 ! ipass
-
-!---- compute shape functions and their derivatives for regular interpolated display grid
- do j = 1,pointsdisp
- do i = 1,pointsdisp
- xirec = 2.d0*dble(i-1)/dble(pointsdisp-1) - 1.d0
- gammarec = 2.d0*dble(j-1)/dble(pointsdisp-1) - 1.d0
- call define_shape_functions(shape2D_display(:,i,j),dershape2D_display(:,:,i,j),xirec,gammarec,ngnod)
- enddo
- enddo
-
-!---- compute Lagrange interpolants on a regular interpolated grid in (xi,gamma)
-!---- for display (assumes NGLLX = NGLLZ)
- do j=1,NGLLX
- do i=1,pointsdisp
- xirec = 2.d0*dble(i-1)/dble(pointsdisp-1) - 1.d0
- flagrange(j,i) = hgll(j-1,xirec,xigll,NGLLX)
- enddo
- enddo
-
-! get number of stations from receiver file
- open(unit=IIN,file='DATA/STATIONS_target',iostat=ios,status='old',action='read')
- nrec = 0
- do while(ios == 0)
- read(IIN,"(a)",iostat=ios) dummystring
- if(ios == 0) nrec = nrec + 1
- enddo
- close(IIN)
-
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Total number of receivers = ',nrec
- write(IOUT,*)
- endif
-
- 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))
- allocate(xi_receiver(nrec))
- allocate(gamma_receiver(nrec))
- allocate(station_name(nrec))
- 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))
- allocate(hxis(NGLLX))
- allocate(hpxir(NGLLX))
- allocate(hpxis(NGLLX))
- allocate(hgammar(NGLLZ))
- allocate(hgammas(NGLLZ))
- allocate(hpgammar(NGLLZ))
- allocate(hpgammas(NGLLZ))
-
-! allocate Lagrange interpolators for receivers
- allocate(hxir_store(nrec,NGLLX))
- allocate(hgammar_store(nrec,NGLLZ))
-
-! allocate Lagrange interpolators for sources
- allocate(hxis_store(NSOURCES,NGLLX))
- allocate(hgammas_store(NSOURCES,NGLLZ))
-
-! allocate other global arrays
- allocate(coord(NDIM,npoin))
-
-! to display acoustic elements
- allocate(vector_field_display(3,npoin))
-
-! if(assign_external_model) then
-
-! note: so far, full external array needed/defined in subroutine calls
- allocate(vpext(NGLLX,NGLLZ,nspec))
- allocate(vsext(NGLLX,NGLLZ,nspec))
- allocate(rhoext(NGLLX,NGLLZ,nspec))
- allocate(Qp_attenuationext(NGLLX,NGLLZ,nspec))
- allocate(Qs_attenuationext(NGLLX,NGLLZ,nspec))
- allocate(c11ext(NGLLX,NGLLZ,nspec))
- allocate(c13ext(NGLLX,NGLLZ,nspec))
- allocate(c15ext(NGLLX,NGLLZ,nspec))
- allocate(c33ext(NGLLX,NGLLZ,nspec))
- allocate(c35ext(NGLLX,NGLLZ,nspec))
- allocate(c55ext(NGLLX,NGLLZ,nspec))
-! else
-! allocate(vpext(1,1,1))
-! allocate(vsext(1,1,1))
-! allocate(rhoext(1,1,1))
-! allocate(c11ext(1,1,1))
-! allocate(c13ext(1,1,1))
-! allocate(c15ext(1,1,1))
-! allocate(c33ext(1,1,1))
-! allocate(c35ext(1,1,1))
-! allocate(c55ext(1,1,1))
-! endif
-
- endif
-
-!
-!---- set the coordinates of the points of the global grid
-!
- found_a_negative_jacobian = .false.
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- xi = xigll(i)
- gamma = zigll(j)
-
- call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
- jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
- .false.)
-
- if(jacobianl <= ZERO) found_a_negative_jacobian = .true.
-
- coord(1,ibool(i,j,ispec)) = x
- coord(2,ibool(i,j,ispec)) = z
-
- xix(i,j,ispec) = xixl
- xiz(i,j,ispec) = xizl
- gammax(i,j,ispec) = gammaxl
- gammaz(i,j,ispec) = gammazl
- jacobian(i,j,ispec) = jacobianl
-
- enddo
- enddo
- enddo
-
-! create an OpenDX file containing all the negative elements displayed in red, if any
-! this allows users to locate problems in a mesh based on the OpenDX file created at the second iteration
-! do not create OpenDX files if no negative Jacobian has been found, or if we are running in parallel
-! (because writing OpenDX routines is much easier in serial)
- if(found_a_negative_jacobian .and. nproc == 1) then
- call save_openDX_jacobian(nspec,npgeo,ngnod,knods,coorg,xigll,zigll)
- endif
-
-! stop the code at the first negative element found, because such a mesh cannot be computed
- if(found_a_negative_jacobian) then
-
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- xi = xigll(i)
- gamma = zigll(j)
-
- call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
- jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
- .true.)
-
- enddo
- enddo
- enddo
-
- endif
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! yang output weights for line, surface integrals !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!define_derivation_matrices(xigll(NGLLX),zigll(NGLLZ),wxgll(NGLLX),wzgll(NGLLZ),hprime_xx(NGLLX,NGLLX),hprime_zz(NGLLZ,NGLLZ),&
-! hprimewgll_xx(NGLLX,NGLLX),hprimewgll_zz(NGLLZ,NGLLZ))
-!xix(NGLLX,NGLLZ,nspec),xiz,gammax,gammaz,jacobian
-!recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl,jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
-! .true.)
- allocate(weight_line_x(npoin))
- allocate(weight_line_z(npoin))
- allocate(weight_surface(npoin))
- allocate(weight_jacobian(npoin))
- allocate(weight_gll(npoin))
- weight_line_x=0.0
- weight_line_z=0.0
- weight_surface=0.0
- zmin_yang=minval(coord(2,:))
- xmin_yang=minval(coord(1,:))
- zmax_yang=maxval(coord(2,:))
- xmax_yang=maxval(coord(1,:))
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob=ibool(i,j,ispec)
- z=coord(2,ibool(i,j,ispec))
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- if ((j==1 .OR. j==NGLLZ) .AND. ( (abs(z-zmin_yang).GE.1) .AND. (abs(z-zmax_yang)).GE.1) ) xxi=xxi/2.0
- if ((i==1 .OR. i==NGLLZ) .AND. ( (abs(x-xmin_yang).GE.1) .AND. (abs(x-xmax_yang)).GE.1) ) zgamma=zgamma/2.0
- weight_line_x(iglob) = weight_line_x(iglob) + xxi * wxgll(i)
- weight_line_z(iglob) = weight_line_z(iglob) + zgamma * wzgll(j)
- weight_surface(iglob) = weight_surface(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)
- weight_jacobian(iglob) = jacobian(i,j,ispec)
- weight_gll(iglob) = 10*j+i
- enddo
- enddo
- enddo
- open(unit=55,file='OUTPUT_FILES/x_z_weightLineX_weightLineZ_weightSurface',status='unknown')
- do n = 1,npoin
- write(55,*) coord(1,n), coord(2,n), weight_line_x(n), weight_line_z(n), weight_surface(n),weight_jacobian(n),weight_gll(n)
- enddo
- close(55)
- deallocate(weight_line_x)
- deallocate(weight_line_z)
- deallocate(weight_surface)
- deallocate(weight_jacobian)
- deallocate(weight_gll)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!--- save the grid of points in a file
-!
- 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')
- 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 .and. myrank == 0 .and. ipass == 1) &
- call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
-
- if(myrank == 0 .and. ipass == 1) &
- write(IOUT,*) 'assign_external_model = ', assign_external_model
-
-!if ( assign_external_model .and. ipass == 1) then
- if ( assign_external_model) then
- call read_external_model(any_acoustic,any_elastic,any_poroelastic, &
- elastic,poroelastic,anisotropic,nspec,npoin,N_SLS,ibool, &
- f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
- inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent, &
- inv_tau_sigma_nu1,inv_tau_sigma_nu2,phi_nu1,phi_nu2,Mu_nu1,Mu_nu2,&
- coord,kmato,myrank,rhoext,vpext,vsext, &
- Qp_attenuationext,Qs_attenuationext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,READ_EXTERNAL_SEP_FILE)
- end if
-
-!
-!---- perform basic checks on parameters read
-!
- all_anisotropic = .false.
- if(count(anisotropic(:) .eqv. .true.) == nspec) all_anisotropic = .true.
-
- if(all_anisotropic .and. anyabs) &
- call exit_MPI('Cannot put absorbing boundaries if anisotropic materials along edges')
-
- if(TURN_ATTENUATION_ON .and. all_anisotropic) then
- call exit_MPI('Cannot turn attenuation on in anisotropic materials')
- end if
-
- ! global domain flags
- 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
-#ifdef USE_MPI
- call MPI_ALLREDUCE(any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, &
- MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- any_acoustic_glob = any_acoustic
-#ifdef USE_MPI
- call MPI_ALLREDUCE(any_acoustic, any_acoustic_glob, 1, MPI_LOGICAL, &
- MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- ! for acoustic
- if(TURN_ATTENUATION_ON .and. .not. any_elastic_glob) &
- call exit_MPI('currently cannot have attenuation if acoustic/poroelastic simulation only')
-
-!
-!---- define coefficients of the Newmark time scheme
-!
- deltatover2 = HALF*deltat
- deltatsquareover2 = HALF*deltat*deltat
-
- if(SIMULATION_TYPE == 2) then
-! define coefficients of the Newmark time scheme for the backward wavefield
- b_deltat = - deltat
- b_deltatover2 = HALF*b_deltat
- b_deltatsquareover2 = HALF*b_deltat*b_deltat
- endif
-
-!---- define actual location of source and receivers
-
- call setup_sources_receivers(NSOURCES,initialfield,source_type,&
- coord,ibool,npoin,nspec,nelem_acoustic_surface,acoustic_surface,elastic,poroelastic, &
- x_source,z_source,ispec_selected_source,ispec_selected_rec, &
- is_proc_source,nb_proc_source,ipass,&
- sourcearray,Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,npgeo,&
- nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod, &
- nrec,nrecloc,recloc,which_proc_receiver,st_xval,st_zval, &
- xi_receiver,gamma_receiver,station_name,network_name,x_final_receiver,z_final_receiver,iglob_source)
-
-! compute source array for adjoint source
- if(SIMULATION_TYPE == 2) then ! adjoint calculation
- nadj_rec_local = 0
- do irec = 1,nrec
- if(myrank == which_proc_receiver(irec))then
-! check that the source proc number is okay
- if(which_proc_receiver(irec) < 0 .or. which_proc_receiver(irec) > NPROC-1) &
- call exit_MPI('something is wrong with the source proc number in adjoint simulation')
- nadj_rec_local = nadj_rec_local + 1
- endif
- enddo
- if(ipass == 1) allocate(adj_sourcearray(NSTEP,3,NGLLX,NGLLZ))
- if (nadj_rec_local > 0 .and. ipass == 1) then
- allocate(adj_sourcearrays(nadj_rec_local,NSTEP,3,NGLLX,NGLLZ))
- else if (ipass == 1) then
- allocate(adj_sourcearrays(1,1,1,1,1))
- endif
-
- irec_local = 0
- do irec = 1, nrec
-! compute only adjoint source arrays in the local proc
- if(myrank == which_proc_receiver(irec))then
- irec_local = irec_local + 1
- adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
- call compute_arrays_adj_source(adj_source_file, &
- xi_receiver(irec), gamma_receiver(irec), &
- adj_sourcearray, xigll,zigll,NSTEP)
- adj_sourcearrays(irec_local,:,:,:,:) = adj_sourcearray(:,:,:,:)
- endif
- enddo
- else if (ipass == 1) then
- allocate(adj_sourcearrays(1,1,1,1,1))
- 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
-
- if (rec_normal_to_surface .and. abs(anglerec) > 1.d-6) &
- stop 'anglerec should be zero when receivers are normal to the topography'
-
- anglerec_irec(:) = anglerec * pi / 180.d0
- cosrot_irec(:) = cos(anglerec_irec(:))
- sinrot_irec(:) = sin(anglerec_irec(:))
- 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 compute_normal_vector( 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,NSOURCES
- 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)
-
- ! in the case of a source force vector
- ! users can give an angle with respect to the normal to the topography surface,
- ! in which case we must compute the normal to the topography
- ! and add it the existing rotation angle
- call compute_normal_vector( 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,NSOURCES
- 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 ! force_normal_to_surface
-
- endif ! ipass
-
-!
-!---
-!
-
-! allocate seismogram arrays
- if(ipass == 1) then
- allocate(sisux(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
- allocate(sisuz(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
- allocate(siscurl(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
- endif
-
-! check if acoustic receiver is exactly on the free surface because pressure is zero there
- do ispec_acoustic_surface = 1,nelem_acoustic_surface
- ispec = acoustic_surface(1,ispec_acoustic_surface)
- ixmin = acoustic_surface(2,ispec_acoustic_surface)
- ixmax = acoustic_surface(3,ispec_acoustic_surface)
- izmin = acoustic_surface(4,ispec_acoustic_surface)
- izmax = acoustic_surface(5,ispec_acoustic_surface)
- do irecloc = 1,nrecloc
- irec = recloc(irecloc)
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
- if ( (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==NGLLX .and. &
- gamma_receiver(irec) < -0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==NGLLX .and. &
- gamma_receiver(irec) > 0.99d0) .or.&
- (izmin==1 .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
- xi_receiver(irec) < -0.99d0) .or.&
- (izmin==1 .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- xi_receiver(irec) > 0.99d0) .or.&
- (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==1 .and. &
- gamma_receiver(irec) < -0.99d0 .and. xi_receiver(irec) < -0.99d0) .or.&
- (izmin==1 .and. izmax==1 .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- gamma_receiver(irec) < -0.99d0 .and. xi_receiver(irec) > 0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
- gamma_receiver(irec) > 0.99d0 .and. xi_receiver(irec) < -0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- gamma_receiver(irec) > 0.99d0 .and. xi_receiver(irec) > 0.99d0) ) then
- if(seismotype == 4) then
- call exit_MPI('an acoustic pressure receiver cannot be located exactly '// &
- 'on the free surface because pressure is zero there')
- else
- print *, '**********************************************************************'
- print *, '*** Warning: acoustic receiver located exactly on the free surface ***'
- print *, '*** Warning: tangential component will be zero there ***'
- print *, '**********************************************************************'
- print *
- endif
- endif
- endif
- enddo
- enddo
-
-! define and store Lagrange interpolators at all the receivers
- do irec = 1,nrec
- call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
- call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
- hxir_store(irec,:) = hxir(:)
- hgammar_store(irec,:) = hgammar(:)
- enddo
-
-! define and store Lagrange interpolators at all the sources
- do i = 1,NSOURCES
- call lagrange_any(xi_source(i),NGLLX,xigll,hxis,hpxis)
- call lagrange_any(gamma_source(i),NGLLZ,zigll,hgammas,hpgammas)
- hxis_store(i,:) = hxis(:)
- hgammas_store(i,:) = hgammas(:)
- enddo
-
-! displacement, velocity, acceleration and inverse of the mass matrix for elastic elements
- if(ipass == 1) then
-
- if(any_elastic) then
- npoin_elastic = npoin
- else
- ! allocate unused arrays with fictitious size
- npoin_elastic = 1
- endif
- allocate(displ_elastic(3,npoin_elastic))
- allocate(veloc_elastic(3,npoin_elastic))
- allocate(accel_elastic(3,npoin_elastic))
- allocate(rmass_inverse_elastic(npoin_elastic))
-
- ! extra array if adjoint and kernels calculation
- if(SIMULATION_TYPE == 2 .and. any_elastic) then
- allocate(b_displ_elastic(3,npoin))
- allocate(b_veloc_elastic(3,npoin))
- allocate(b_accel_elastic(3,npoin))
- allocate(rho_kl(NGLLX,NGLLZ,nspec))
- allocate(rho_k(npoin))
- allocate(rhol_global(npoin))
- allocate(mu_kl(NGLLX,NGLLZ,nspec))
- allocate(mu_k(npoin))
- allocate(mul_global(npoin))
- allocate(kappa_kl(NGLLX,NGLLZ,nspec))
- allocate(kappa_k(npoin))
- allocate(kappal_global(npoin))
- allocate(rhop_kl(NGLLX,NGLLZ,nspec))
- allocate(alpha_kl(NGLLX,NGLLZ,nspec))
- allocate(beta_kl(NGLLX,NGLLZ,nspec))
- allocate(rhorho_el_hessian_final2(NGLLX,NGLLZ,nspec))
- allocate(rhorho_el_hessian_temp2(npoin))
- allocate(rhorho_el_hessian_final1(NGLLX,NGLLZ,nspec))
- allocate(rhorho_el_hessian_temp1(npoin))
- else
- allocate(b_displ_elastic(1,1))
- allocate(b_veloc_elastic(1,1))
- allocate(b_accel_elastic(1,1))
- allocate(rho_kl(1,1,1))
- allocate(rho_k(1))
- allocate(rhol_global(1))
- allocate(mu_kl(1,1,1))
- allocate(mu_k(1))
- allocate(mul_global(1))
- allocate(kappa_kl(1,1,1))
- allocate(kappa_k(1))
- allocate(kappal_global(1))
- allocate(rhop_kl(1,1,1))
- allocate(alpha_kl(1,1,1))
- allocate(beta_kl(1,1,1))
- allocate(rhorho_el_hessian_final2(1,1,1))
- allocate(rhorho_el_hessian_temp2(1))
- allocate(rhorho_el_hessian_final1(1,1,1))
- allocate(rhorho_el_hessian_temp1(1))
- endif
-
- if(any_poroelastic) then
- npoin_poroelastic = npoin
- else
- ! allocate unused arrays with fictitious size
- npoin_poroelastic = 1
- endif
- allocate(displs_poroelastic(NDIM,npoin_poroelastic))
- allocate(velocs_poroelastic(NDIM,npoin_poroelastic))
- allocate(accels_poroelastic(NDIM,npoin_poroelastic))
- allocate(rmass_s_inverse_poroelastic(npoin_poroelastic))
- allocate(displw_poroelastic(NDIM,npoin_poroelastic))
- allocate(velocw_poroelastic(NDIM,npoin_poroelastic))
- allocate(accelw_poroelastic(NDIM,npoin_poroelastic))
- allocate(rmass_w_inverse_poroelastic(npoin_poroelastic))
-
- ! extra array if adjoint and kernels calculation
- if(SIMULATION_TYPE == 2 .and. any_poroelastic) then
- allocate(b_displs_poroelastic(NDIM,npoin))
- allocate(b_velocs_poroelastic(NDIM,npoin))
- allocate(b_accels_poroelastic(NDIM,npoin))
- allocate(b_displw_poroelastic(NDIM,npoin))
- allocate(b_velocw_poroelastic(NDIM,npoin))
- allocate(b_accelw_poroelastic(NDIM,npoin))
- allocate(rhot_kl(NGLLX,NGLLZ,nspec))
- allocate(rhot_k(npoin))
- allocate(rhof_kl(NGLLX,NGLLZ,nspec))
- allocate(rhof_k(npoin))
- allocate(sm_kl(NGLLX,NGLLZ,nspec))
- allocate(sm_k(npoin))
- allocate(eta_kl(NGLLX,NGLLZ,nspec))
- allocate(eta_k(npoin))
- allocate(mufr_kl(NGLLX,NGLLZ,nspec))
- allocate(mufr_k(npoin))
- allocate(B_kl(NGLLX,NGLLZ,nspec))
- allocate(B_k(npoin))
- allocate(C_kl(NGLLX,NGLLZ,nspec))
- allocate(C_k(npoin))
- allocate(M_kl(NGLLX,NGLLZ,nspec))
- allocate(M_k(npoin))
- allocate(rhob_kl(NGLLX,NGLLZ,nspec))
- allocate(rhofb_kl(NGLLX,NGLLZ,nspec))
- allocate(phi_kl(NGLLX,NGLLZ,nspec))
- allocate(Bb_kl(NGLLX,NGLLZ,nspec))
- allocate(Cb_kl(NGLLX,NGLLZ,nspec))
- allocate(Mb_kl(NGLLX,NGLLZ,nspec))
- allocate(mufrb_kl(NGLLX,NGLLZ,nspec))
- allocate(rhobb_kl(NGLLX,NGLLZ,nspec))
- allocate(rhofbb_kl(NGLLX,NGLLZ,nspec))
- allocate(phib_kl(NGLLX,NGLLZ,nspec))
- allocate(cpI_kl(NGLLX,NGLLZ,nspec))
- allocate(cpII_kl(NGLLX,NGLLZ,nspec))
- allocate(cs_kl(NGLLX,NGLLZ,nspec))
- allocate(ratio_kl(NGLLX,NGLLZ,nspec))
- allocate(phil_global(npoin))
- allocate(mulfr_global(npoin))
- allocate(etal_f_global(npoin))
- allocate(rhol_s_global(npoin))
- allocate(rhol_f_global(npoin))
- allocate(rhol_bar_global(npoin))
- allocate(tortl_global(npoin))
- allocate(permlxx_global(npoin))
- allocate(permlxz_global(npoin))
- allocate(permlzz_global(npoin))
- else
- allocate(b_displs_poroelastic(1,1))
- allocate(b_velocs_poroelastic(1,1))
- allocate(b_accels_poroelastic(1,1))
- allocate(b_displw_poroelastic(1,1))
- allocate(b_velocw_poroelastic(1,1))
- allocate(b_accelw_poroelastic(1,1))
- allocate(rhot_kl(1,1,1))
- allocate(rhot_k(1))
- allocate(rhof_kl(1,1,1))
- allocate(rhof_k(1))
- allocate(sm_kl(1,1,1))
- allocate(sm_k(1))
- allocate(eta_kl(1,1,1))
- allocate(eta_k(1))
- allocate(mufr_kl(1,1,1))
- allocate(mufr_k(1))
- allocate(B_kl(1,1,1))
- allocate(B_k(1))
- allocate(C_kl(1,1,1))
- allocate(C_k(1))
- allocate(M_kl(1,1,1))
- allocate(M_k(1))
- allocate(rhob_kl(1,1,1))
- allocate(rhofb_kl(1,1,1))
- allocate(phi_kl(1,1,1))
- allocate(Bb_kl(1,1,1))
- allocate(Cb_kl(1,1,1))
- allocate(Mb_kl(1,1,1))
- allocate(mufrb_kl(1,1,1))
- allocate(rhobb_kl(1,1,1))
- allocate(rhofbb_kl(1,1,1))
- allocate(phib_kl(1,1,1))
- allocate(cpI_kl(1,1,1))
- allocate(cpII_kl(1,1,1))
- allocate(cs_kl(1,1,1))
- allocate(ratio_kl(1,1,1))
- allocate(phil_global(1))
- allocate(mulfr_global(1))
- allocate(etal_f_global(1))
- allocate(rhol_s_global(1))
- allocate(rhol_f_global(1))
- allocate(rhol_bar_global(1))
- allocate(tortl_global(1))
- allocate(permlxx_global(1))
- allocate(permlxz_global(1))
- allocate(permlzz_global(1))
- endif
-
- if(any_poroelastic .and. any_elastic) then
- allocate(icount(npoin))
- else
- allocate(icount(1))
- endif
-
- ! potential, its first and second derivative, and inverse of the mass matrix for acoustic elements
- if(any_acoustic) then
- npoin_acoustic = npoin
- else
- ! allocate unused arrays with fictitious size
- npoin_acoustic = 1
- endif
- allocate(potential_acoustic(npoin_acoustic))
- allocate(potential_dot_acoustic(npoin_acoustic))
- allocate(potential_dot_dot_acoustic(npoin_acoustic))
- allocate(rmass_inverse_acoustic(npoin_acoustic))
-
- if(SIMULATION_TYPE == 2 .and. any_acoustic) then
- allocate(b_potential_acoustic(npoin))
- allocate(b_potential_dot_acoustic(npoin))
- allocate(b_potential_dot_dot_acoustic(npoin))
- allocate(b_displ_ac(2,npoin))
- allocate(b_accel_ac(2,npoin))
- allocate(accel_ac(2,npoin))
- allocate(rho_ac_kl(NGLLX,NGLLZ,nspec))
- allocate(rhol_ac_global(npoin))
- allocate(kappa_ac_kl(NGLLX,NGLLZ,nspec))
- allocate(kappal_ac_global(npoin))
- allocate(rhop_ac_kl(NGLLX,NGLLZ,nspec))
- allocate(alpha_ac_kl(NGLLX,NGLLZ,nspec))
- allocate(rhorho_ac_hessian_final2(NGLLX,NGLLZ,nspec))
- allocate(rhorho_ac_hessian_final1(NGLLX,NGLLZ,nspec))
- else
- ! allocate unused arrays with fictitious size
- allocate(b_potential_acoustic(1))
- allocate(b_potential_dot_acoustic(1))
- allocate(b_potential_dot_dot_acoustic(1))
- allocate(b_displ_ac(1,1))
- allocate(b_accel_ac(1,1))
- allocate(accel_ac(1,1))
- allocate(rho_ac_kl(1,1,1))
- allocate(rhol_ac_global(1))
- allocate(kappa_ac_kl(1,1,1))
- allocate(kappal_ac_global(1))
- allocate(rhop_ac_kl(1,1,1))
- allocate(alpha_ac_kl(1,1,1))
- allocate(rhorho_ac_hessian_final2(1,1,1))
- allocate(rhorho_ac_hessian_final1(1,1,1))
- endif
-
- endif ! ipass == 1
-
- !
- !---- build the global mass matrix
- !
- call invert_mass_matrix_init(any_elastic,any_acoustic,any_poroelastic, &
- rmass_inverse_elastic,npoin_elastic, &
- rmass_inverse_acoustic,npoin_acoustic, &
- rmass_s_inverse_poroelastic, &
- rmass_w_inverse_poroelastic,npoin_poroelastic, &
- nspec,ibool,kmato,wxgll,wzgll,jacobian, &
- elastic,poroelastic, &
- assign_external_model,numat, &
- density,poroelastcoef,porosity,tortuosity, &
- vpext,rhoext)
-
-
-
-#ifdef USE_MPI
- if ( nproc > 1 ) then
-
- ! preparing for MPI communications
- if(ipass == 1) allocate(mask_ispec_inner_outer(nspec))
- mask_ispec_inner_outer(:) = .false.
-
- call get_MPI(nspec,ibool,knods,ngnod,npoin,elastic,poroelastic, &
- ninterface, max_interface_size, &
- my_nelmnts_neighbours,my_interfaces,my_neighbours, &
- 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, &
- myrank,ipass,coord)
-
-
- nspec_outer = count(mask_ispec_inner_outer)
- nspec_inner = nspec - nspec_outer
-
- 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
- if ( mask_ispec_inner_outer(ispec) ) then
- num_ispec_outer = num_ispec_outer + 1
- ispec_outer_to_glob(num_ispec_outer) = ispec
- else
- num_ispec_inner = num_ispec_inner + 1
- ispec_inner_to_glob(num_ispec_inner) = ispec
- endif
- enddo
- endif
-
- ! buffers for MPI communications
- max_ibool_interfaces_size_ac = maxval(nibool_interfaces_acoustic(:))
- max_ibool_interfaces_size_el = 3*maxval(nibool_interfaces_elastic(:))
- max_ibool_interfaces_size_po = NDIM*maxval(nibool_interfaces_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_poro(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
-
-! assembling the mass matrix
- call assemble_MPI_scalar(rmass_inverse_acoustic,npoin_acoustic, &
- rmass_inverse_elastic,npoin_elastic, &
- rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic,npoin_poroelastic, &
- ninterface, max_interface_size, max_ibool_interfaces_size_ac, &
- max_ibool_interfaces_size_el, &
- max_ibool_interfaces_size_po, &
- ibool_interfaces_acoustic,ibool_interfaces_elastic, &
- ibool_interfaces_poroelastic, &
- nibool_interfaces_acoustic,nibool_interfaces_elastic, &
- nibool_interfaces_poroelastic,my_neighbours)
-
- else
- ninterface_acoustic = 0
- ninterface_elastic = 0
- ninterface_poroelastic = 0
-
- num_ispec_outer = 0
- num_ispec_inner = 0
- if(ipass == 1) allocate(mask_ispec_inner_outer(1))
-
- nspec_outer = 0
- nspec_inner = nspec
-
- if(ipass == 1) allocate(ispec_inner_to_glob(nspec_inner))
- do ispec = 1, nspec
- ispec_inner_to_glob(ispec) = ispec
- enddo
-
- endif ! end of test on wether there is more than one process (nproc > 1)
-
-#else
- num_ispec_outer = 0
- num_ispec_inner = 0
- if(ipass == 1) allocate(mask_ispec_inner_outer(1))
-
- nspec_outer = 0
- nspec_inner = nspec
-
- if(ipass == 1) then
- allocate(ispec_outer_to_glob(1))
- allocate(ispec_inner_to_glob(nspec_inner))
- endif
- 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 inner/outer passes
-!
-!============================================
-
-!---
-!--- end of section performed in two passes
-!---
-
- call invert_mass_matrix(any_elastic,any_acoustic,any_poroelastic,&
- rmass_inverse_elastic,npoin_elastic, &
- rmass_inverse_acoustic,npoin_acoustic, &
- rmass_s_inverse_poroelastic, &
- rmass_w_inverse_poroelastic,npoin_poroelastic)
-
-! check the mesh, stability and number of points per wavelength
- 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,permeability,ibool,kmato, &
- coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
- assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat, &
- f0,initialfield,time_function_type, &
- coorg,xinterp,zinterp,shape2D_display,knods,simulation_title, &
- npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,all_anisotropic, &
- myrank,nproc,NSOURCES,poroelastic, &
- freq0,Q0,TURN_VISCATTENUATION_ON)
-
-! convert receiver angle to radians
- anglerec = anglerec * pi / 180.d0
-
-!
-!---- for color images
-!
-
- if(output_color_image) then
- ! prepares dimension of image
- call prepare_color_image_init(NX_IMAGE_color,NZ_IMAGE_color, &
- xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image, &
- coord,npoin,npgeo)
-
- ! allocate an array for image data
- allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color))
- allocate(image_color_vp_display(NX_IMAGE_color,NZ_IMAGE_color))
-
- ! allocate an array for the grid point that corresponds to a given image data point
- allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
- allocate(copy_iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
-
- ! creates pixels indexing
- call prepare_color_image_pixels(myrank,NX_IMAGE_color,NZ_IMAGE_color, &
- xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image, &
- coord,npoin,coorg,npgeo,nspec,ngnod,knods,ibool, &
- nb_pixel_loc,iglob_image_color)
-
-
- ! creating and filling array num_pixel_loc with the positions of each colored
- ! pixel owned by the local process (useful for parallel jobs)
- allocate(num_pixel_loc(nb_pixel_loc))
-
- nb_pixel_loc = 0
- do i = 1, NX_IMAGE_color
- do j = 1, NZ_IMAGE_color
- if ( iglob_image_color(i,j) /= -1 ) then
- nb_pixel_loc = nb_pixel_loc + 1
- num_pixel_loc(nb_pixel_loc) = (j-1)*NX_IMAGE_color + i
- endif
- enddo
- enddo
-
-! filling array iglob_image_color, containing info on which process owns which pixels.
-#ifdef USE_MPI
- allocate(nb_pixel_per_proc(nproc))
-
- call MPI_GATHER( nb_pixel_loc, 1, MPI_INTEGER, nb_pixel_per_proc(1), &
- 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ier)
-
- if ( myrank == 0 ) then
- allocate(num_pixel_recv(maxval(nb_pixel_per_proc(:)),nproc))
- allocate(data_pixel_recv(maxval(nb_pixel_per_proc(:))))
- endif
-
- allocate(data_pixel_send(nb_pixel_loc))
- if (nproc > 1) then
- if (myrank == 0) then
-
- do iproc = 1, nproc-1
-
- call MPI_RECV(num_pixel_recv(1,iproc+1),nb_pixel_per_proc(iproc+1), MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- do k = 1, nb_pixel_per_proc(iproc+1)
- 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
- iglob_image_color(i,j) = iproc
-
- enddo
- enddo
-
- else
- call MPI_SEND(num_pixel_loc(1),nb_pixel_loc,MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- endif
- endif
-#endif
-
- if (myrank == 0) write(IOUT,*) 'done locating all the pixels of color images'
-
- endif ! color_image
-
-!
-!---- initialize seismograms
-!
- sisux = ZERO ! double precision zero
- sisuz = ZERO
-
-! initialize arrays to zero
- displ_elastic = 0._CUSTOM_REAL
- veloc_elastic = 0._CUSTOM_REAL
- accel_elastic = 0._CUSTOM_REAL
-
- displs_poroelastic = 0._CUSTOM_REAL
- velocs_poroelastic = 0._CUSTOM_REAL
- accels_poroelastic = 0._CUSTOM_REAL
- displw_poroelastic = 0._CUSTOM_REAL
- velocw_poroelastic = 0._CUSTOM_REAL
- accelw_poroelastic = 0._CUSTOM_REAL
-
- potential_acoustic = 0._CUSTOM_REAL
- potential_dot_acoustic = 0._CUSTOM_REAL
- potential_dot_dot_acoustic = 0._CUSTOM_REAL
-
-!
-!----- Files where viscous damping are saved during forward wavefield calculation
-!
- if(any_poroelastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE .eq. 2)) then
- allocate(b_viscodampx(npoin))
- allocate(b_viscodampz(npoin))
- write(outputname,'(a,i6.6,a)') 'viscodampingx',myrank,'.bin'
- write(outputname2,'(a,i6.6,a)') 'viscodampingz',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- reclen = CUSTOM_REAL * npoin
- open(unit=23,file='OUTPUT_FILES/'//outputname,status='old',&
- action='read',form='unformatted',access='direct',&
- recl=reclen)
- open(unit=24,file='OUTPUT_FILES/'//outputname2,status='old',&
- action='read',form='unformatted',access='direct',&
- recl=reclen)
- else
- reclen = CUSTOM_REAL * npoin
- open(unit=23,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted',access='direct',&
- recl=reclen)
- open(unit=24,file='OUTPUT_FILES/'//outputname2,status='unknown',&
- form='unformatted',access='direct',&
- recl=reclen)
- endif
- else
- allocate(b_viscodampx(1))
- allocate(b_viscodampz(1))
- endif
-
-!
-!----- Files where absorbing signal are saved during forward wavefield calculation
-!
-
- if( ((SAVE_FORWARD .and. SIMULATION_TYPE ==1) .or. SIMULATION_TYPE == 2) .and. anyabs ) then
- ! opens files for absorbing boundary data
- call prepare_absorb_files(myrank,any_elastic,any_poroelastic,any_acoustic, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,SIMULATION_TYPE)
- endif
-
- if(anyabs .and. SIMULATION_TYPE == 2) then
-
- ! reads in absorbing bounday data
- if(any_elastic) then
- call prepare_absorb_elastic(NSTEP,p_sv, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_elastic_left,b_absorb_elastic_right, &
- b_absorb_elastic_bottom,b_absorb_elastic_top)
-
- endif
- if(any_poroelastic) then
- call prepare_absorb_poroelastic(NSTEP, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_poro_s_left,b_absorb_poro_w_left, &
- b_absorb_poro_s_right,b_absorb_poro_w_right, &
- b_absorb_poro_s_bottom,b_absorb_poro_w_bottom, &
- b_absorb_poro_s_top,b_absorb_poro_w_top)
-
- endif
- if(any_acoustic) then
- call prepare_absorb_acoustic(NSTEP, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_acoustic_left,b_absorb_acoustic_right, &
- b_absorb_acoustic_bottom,b_absorb_acoustic_top)
- endif
-
- endif ! if(anyabs .and. SIMULATION_TYPE == 2)
-
-
-
-!
-!----- Read last frame for backward wavefield calculation
-!
-
- if(SIMULATION_TYPE == 2) then
-
- if(any_elastic) then
- write(outputname,'(a,i6.6,a)') 'snapshot_rho_kappa_mu_',myrank
- open(unit = 97, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_rhop_alpha_beta_',myrank
- open(unit = 98, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
-
- rho_kl(:,:,:) = 0._CUSTOM_REAL
- mu_kl(:,:,:) = 0._CUSTOM_REAL
- kappa_kl(:,:,:) = 0._CUSTOM_REAL
-
- rhop_kl(:,:,:) = 0._CUSTOM_REAL
- beta_kl(:,:,:) = 0._CUSTOM_REAL
- alpha_kl(:,:,:) = 0._CUSTOM_REAL
- rhorho_el_hessian_final2(:,:,:) = 0._CUSTOM_REAL
- rhorho_el_hessian_temp2(:) = 0._CUSTOM_REAL
- rhorho_el_hessian_final1(:,:,:) = 0._CUSTOM_REAL
- rhorho_el_hessian_temp1(:) = 0._CUSTOM_REAL
- endif
-
- if(any_poroelastic) then
-
- ! Primary kernels
- write(outputname,'(a,i6.6,a)') 'snapshot_mu_B_C_',myrank
- open(unit = 144, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_M_rho_rhof_',myrank
- open(unit = 155, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_m_eta_',myrank
- open(unit = 16, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- ! Wavespeed kernels
- write(outputname,'(a,i6.6,a)') 'snapshot_cpI_cpII_cs_',myrank
- open(unit = 20, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_rhobb_rhofbb_ratio_',myrank
- open(unit = 21, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_phib_eta_',myrank
- open(unit = 22, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- ! Density normalized kernels
- write(outputname,'(a,i6.6,a)') 'snapshot_mub_Bb_Cb_',myrank
- open(unit = 17, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_Mb_rhob_rhofb_',myrank
- open(unit = 18, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_mb_etab_',myrank
- open(unit = 19, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
-
- rhot_kl(:,:,:) = 0._CUSTOM_REAL
- rhof_kl(:,:,:) = 0._CUSTOM_REAL
- eta_kl(:,:,:) = 0._CUSTOM_REAL
- sm_kl(:,:,:) = 0._CUSTOM_REAL
- mufr_kl(:,:,:) = 0._CUSTOM_REAL
- B_kl(:,:,:) = 0._CUSTOM_REAL
- C_kl(:,:,:) = 0._CUSTOM_REAL
- M_kl(:,:,:) = 0._CUSTOM_REAL
-
- rhob_kl(:,:,:) = 0._CUSTOM_REAL
- rhofb_kl(:,:,:) = 0._CUSTOM_REAL
- phi_kl(:,:,:) = 0._CUSTOM_REAL
- mufrb_kl(:,:,:) = 0._CUSTOM_REAL
- Bb_kl(:,:,:) = 0._CUSTOM_REAL
- Cb_kl(:,:,:) = 0._CUSTOM_REAL
- Mb_kl(:,:,:) = 0._CUSTOM_REAL
-
- rhobb_kl(:,:,:) = 0._CUSTOM_REAL
- rhofbb_kl(:,:,:) = 0._CUSTOM_REAL
- phib_kl(:,:,:) = 0._CUSTOM_REAL
- cs_kl(:,:,:) = 0._CUSTOM_REAL
- cpI_kl(:,:,:) = 0._CUSTOM_REAL
- cpII_kl(:,:,:) = 0._CUSTOM_REAL
- ratio_kl(:,:,:) = 0._CUSTOM_REAL
- endif
-
- if(any_acoustic) then
- write(outputname,'(a,i6.6,a)') 'snapshot_rho_kappa_',myrank
- open(unit = 95, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_rhop_c_',myrank
- open(unit = 96, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
-
- rho_ac_kl(:,:,:) = 0._CUSTOM_REAL
- kappa_ac_kl(:,:,:) = 0._CUSTOM_REAL
-
- rhop_ac_kl(:,:,:) = 0._CUSTOM_REAL
- alpha_ac_kl(:,:,:) = 0._CUSTOM_REAL
- rhorho_ac_hessian_final2(:,:,:) = 0._CUSTOM_REAL
- rhorho_ac_hessian_final1(:,:,:) = 0._CUSTOM_REAL
- endif
-
- endif ! if(SIMULATION_TYPE == 2)
-
-!
-!---- read initial fields from external file if needed
-!
-
-! if we are looking a plane wave beyond critical angle we use other method
- over_critical_angle = .false.
-
- if(initialfield) then
-
- ! Calculation of the initial field for a plane wave
- if( any_elastic ) then
- call prepare_initialfield(myrank,any_acoustic,any_poroelastic,over_critical_angle, &
- NSOURCES,source_type,angleforce,x_source,z_source,f0, &
- npoin,numat,poroelastcoef,density,coord, &
- angleforce_refl,c_inc,c_refl,cploc,csloc,time_offset, &
- A_plane, B_plane, C_plane, &
- accel_elastic,veloc_elastic,displ_elastic)
- endif
-
- if( over_critical_angle ) then
-
- allocate(left_bound(nelemabs*NGLLX))
- allocate(right_bound(nelemabs*NGLLX))
- allocate(bot_bound(nelemabs*NGLLZ))
-
- call prepare_initialfield_paco(myrank,nelemabs,left_bound,right_bound,bot_bound, &
- numabs,codeabs,ibool,nspec, &
- source_type,NSOURCES,c_inc,c_refl, &
- count_bottom,count_left,count_right)
-
- 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_bottom,NSTEP))
- allocate(v0z_bot(count_bottom,NSTEP))
- allocate(t0x_bot(count_bottom,NSTEP))
- allocate(t0z_bot(count_bottom,NSTEP))
-
- allocate(displ_paco(NDIM,npoin))
- allocate(veloc_paco(NDIM,npoin))
- allocate(accel_paco(NDIM,npoin))
-
- ! 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_bottom)&
- ,count_left,count_right,count_bottom,displ_paco,veloc_paco,accel_paco)
-
- displ_elastic(1,:) = displ_paco(1,:)
- displ_elastic(3,:) = displ_paco(2,:)
- veloc_elastic(1,:) = veloc_paco(1,:)
- veloc_elastic(3,:) = veloc_paco(2,:)
- accel_elastic(1,:) = accel_paco(1,:)
- accel_elastic(3,:) = accel_paco(2,:)
-
- deallocate(left_bound)
- deallocate(right_bound)
- deallocate(bot_bound)
-
- deallocate(displ_paco)
- deallocate(veloc_paco)
- deallocate(accel_paco)
-
- 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(3,:)**2))
-
- endif ! initialfield
-
- deltatsquare = deltat * deltat
- deltatcube = deltatsquare * deltat
- deltatfourth = deltatsquare * deltatsquare
-
- twelvedeltat = 12.d0 * deltat
- fourdeltatsquare = 4.d0 * deltatsquare
-
-! compute the source time function and store it in a text file
- if(.not. initialfield) then
-
- allocate(source_time_function(NSOURCES,NSTEP))
- source_time_function(:,:) = 0._CUSTOM_REAL
-
- ! computes source time function array
- call prepare_source_time_function(myrank,NSTEP,NSOURCES,source_time_function, &
- time_function_type,f0,tshift_src,factor,aval, &
- t0,nb_proc_source,deltat)
- else
- ! uses an initialfield
- ! dummy allocation
- allocate(source_time_function(1,1))
- endif
-
-! determine if coupled fluid-solid simulation
- coupled_acoustic_elastic = any_acoustic .and. any_elastic
- coupled_acoustic_poro = any_acoustic .and. any_poroelastic
-
-! fluid/solid (elastic) edge detection
-! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
-! the common nodes forming the edge are computed here
- if(coupled_acoustic_elastic) then
-
- if (myrank == 0) then
- print *
- print *,'Mixed acoustic/elastic simulation'
- print *
- print *,'Beginning of fluid/solid edge detection'
- endif
-
-! define the edges of a given element
- i_begin(IBOTTOM) = 1
- j_begin(IBOTTOM) = 1
- i_end(IBOTTOM) = NGLLX
- j_end(IBOTTOM) = 1
-
- i_begin(IRIGHT) = NGLLX
- j_begin(IRIGHT) = 1
- i_end(IRIGHT) = NGLLX
- j_end(IRIGHT) = NGLLZ
-
- i_begin(ITOP) = NGLLX
- j_begin(ITOP) = NGLLZ
- i_end(ITOP) = 1
- j_end(ITOP) = NGLLZ
-
- i_begin(ILEFT) = 1
- j_begin(ILEFT) = NGLLZ
- i_end(ILEFT) = 1
- j_end(ILEFT) = 1
-
-! define i and j points for each edge
- do ipoin1D = 1,NGLLX
-
- ivalue(ipoin1D,IBOTTOM) = ipoin1D
- ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
- jvalue(ipoin1D,IBOTTOM) = 1
- jvalue_inverse(ipoin1D,IBOTTOM) = 1
-
- ivalue(ipoin1D,IRIGHT) = NGLLX
- ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
- jvalue(ipoin1D,IRIGHT) = ipoin1D
- jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
-
- ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
- ivalue_inverse(ipoin1D,ITOP) = ipoin1D
- jvalue(ipoin1D,ITOP) = NGLLZ
- jvalue_inverse(ipoin1D,ITOP) = NGLLZ
-
- ivalue(ipoin1D,ILEFT) = 1
- ivalue_inverse(ipoin1D,ILEFT) = 1
- jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
- jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
-
- enddo
-
- do inum = 1, num_fluid_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
-
-! loop on the four edges of the two elements
- do iedge_acoustic = 1,NEDGES
- do iedge_elastic = 1,NEDGES
-
-! store the matching topology if the two edges match in inverse order
- if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
- ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
- ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
- ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
- fluid_solid_acoustic_iedge(inum) = iedge_acoustic
- fluid_solid_elastic_iedge(inum) = iedge_elastic
-! print *,'edge ',iedge_acoustic,' of acoustic element ',ispec_acoustic, &
-! ' is in contact with edge ',iedge_elastic,' of elastic element ',ispec_elastic
- endif
-
- enddo
- enddo
-
- endif
-
- 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) print *,'Checking fluid/solid edge topology...'
-
- 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 elastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_elastic)
- j = jvalue_inverse(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
-! get point values for the acoustic side
- i = ivalue(ipoin1D,iedge_acoustic)
- j = jvalue(ipoin1D,iedge_acoustic)
- iglob2 = ibool(i,j,ispec_acoustic)
-
-! if distance between the two points is not negligible, there is an error, since it should be zero
- if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
- call exit_MPI( 'error in fluid/solid coupling buffer')
-
- enddo
-
- enddo
-
- if (myrank == 0) then
- print *,'End of fluid/solid edge detection'
- print *
- endif
-
- endif
-
-! fluid/solid (poroelastic) edge detection
-! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
-! the common nodes forming the edge are computed here
- if(coupled_acoustic_poro) then
- if ( myrank == 0 ) then
- print *
- print *,'Mixed acoustic/poroelastic simulation'
- print *
- print *,'Beginning of fluid/solid (poroelastic) edge detection'
- endif
-
-! define the edges of a given element
- i_begin(IBOTTOM) = 1
- j_begin(IBOTTOM) = 1
- i_end(IBOTTOM) = NGLLX
- j_end(IBOTTOM) = 1
-
- i_begin(IRIGHT) = NGLLX
- j_begin(IRIGHT) = 1
- i_end(IRIGHT) = NGLLX
- j_end(IRIGHT) = NGLLZ
-
- i_begin(ITOP) = NGLLX
- j_begin(ITOP) = NGLLZ
- i_end(ITOP) = 1
- j_end(ITOP) = NGLLZ
-
- i_begin(ILEFT) = 1
- j_begin(ILEFT) = NGLLZ
- i_end(ILEFT) = 1
- j_end(ILEFT) = 1
-
-! define i and j points for each edge
- do ipoin1D = 1,NGLLX
-
- ivalue(ipoin1D,IBOTTOM) = ipoin1D
- ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
- jvalue(ipoin1D,IBOTTOM) = 1
- jvalue_inverse(ipoin1D,IBOTTOM) = 1
-
- ivalue(ipoin1D,IRIGHT) = NGLLX
- ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
- jvalue(ipoin1D,IRIGHT) = ipoin1D
- jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
-
- ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
- ivalue_inverse(ipoin1D,ITOP) = ipoin1D
- jvalue(ipoin1D,ITOP) = NGLLZ
- jvalue_inverse(ipoin1D,ITOP) = NGLLZ
-
- ivalue(ipoin1D,ILEFT) = 1
- ivalue_inverse(ipoin1D,ILEFT) = 1
- jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
- jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
-
- enddo
-
- do inum = 1, num_fluid_poro_edges
- ispec_acoustic = fluid_poro_acoustic_ispec(inum)
- ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
-
-! one element must be acoustic and the other must be poroelastic
- if(ispec_acoustic /= ispec_poroelastic .and. .not. poroelastic(ispec_acoustic) .and. &
- .not. elastic(ispec_acoustic) .and. poroelastic(ispec_poroelastic)) then
-
-! loop on the four edges of the two elements
- do iedge_acoustic = 1,NEDGES
- do iedge_poroelastic = 1,NEDGES
-
-! store the matching topology if the two edges match in inverse order
- if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
- ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) .and. &
- ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
- ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic)) then
- fluid_poro_acoustic_iedge(inum) = iedge_acoustic
- fluid_poro_poroelastic_iedge(inum) = iedge_poroelastic
- endif
-
- enddo
- enddo
-
- endif
-
- enddo
-
-
-! make sure fluid/solid (poroelastic) matching has been perfectly detected: check that the grid points
-! have the same physical coordinates
-! loop on all the coupling edges
-
- if ( myrank == 0 ) then
- print *,'Checking fluid/solid (poroelastic) edge topology...'
- endif
-
- do inum = 1,num_fluid_poro_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_poro_acoustic_ispec(inum)
- iedge_acoustic = fluid_poro_acoustic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the poroelastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_poroelastic)
- j = jvalue_inverse(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
-
-! get point values for the acoustic side
- i = ivalue(ipoin1D,iedge_acoustic)
- j = jvalue(ipoin1D,iedge_acoustic)
- iglob2 = ibool(i,j,ispec_acoustic)
-
-! if distance between the two points is not negligible, there is an error, since it should be zero
- if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
- call exit_MPI( 'error in fluid/solid (poroelastic) coupling buffer')
-
- enddo
-
- enddo
-
- if ( myrank == 0 ) then
- print *,'End of fluid/solid (poroelastic) edge detection'
- print *
- endif
-
- endif
-
-! exclude common points between acoustic absorbing edges and acoustic/elastic matching interfaces
- if(coupled_acoustic_elastic .and. anyabs) then
-
- if (myrank == 0) &
- print *,'excluding common points between acoustic absorbing edges and acoustic/elastic matching interfaces, if any'
-
-! loop on all the absorbing elements
- do ispecabs = 1,nelemabs
-
- ispec = numabs(ispecabs)
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_solid_acoustic_ispec(inum)
- iedge_acoustic = fluid_solid_acoustic_iedge(inum)
-
-! if acoustic absorbing element and acoustic/elastic coupled element is the same
- if(ispec_acoustic == ispec) then
-
- if(iedge_acoustic == IBOTTOM) then
- jbegin_left(ispecabs) = 2
- jbegin_right(ispecabs) = 2
- endif
-
- if(iedge_acoustic == ITOP) then
- jend_left(ispecabs) = NGLLZ - 1
- jend_right(ispecabs) = NGLLZ - 1
- endif
-
- if(iedge_acoustic == ILEFT) then
- ibegin_bottom(ispecabs) = 2
- ibegin_top(ispecabs) = 2
- endif
-
- if(iedge_acoustic == IRIGHT) then
- iend_bottom(ispecabs) = NGLLX - 1
- iend_top(ispecabs) = NGLLX - 1
- endif
-
- endif
-
- enddo
-
- enddo
-
- endif
-
-! exclude common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces
- if(coupled_acoustic_poro .and. anyabs) then
-
- if (myrank == 0) &
- print *,'excluding common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces, if any'
-
-! 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
-
-! 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 == ispec) then
-
- if(iedge_acoustic == IBOTTOM) then
- jbegin_left(ispecabs) = 2
- jbegin_right(ispecabs) = 2
- endif
-
- if(iedge_acoustic == ITOP) then
- jend_left(ispecabs) = NGLLZ - 1
- jend_right(ispecabs) = NGLLZ - 1
- endif
-
- if(iedge_acoustic == ILEFT) then
- ibegin_bottom(ispecabs) = 2
- ibegin_top(ispecabs) = 2
- endif
-
- if(iedge_acoustic == IRIGHT) then
- iend_bottom(ispecabs) = NGLLX - 1
- iend_top(ispecabs) = NGLLX - 1
- endif
-
- endif
-
- enddo
-
- enddo
-
- endif
-
-
-! determine if coupled elastic-poroelastic simulation
- coupled_elastic_poro = any_elastic .and. any_poroelastic
-
-! solid/porous edge detection
-! the two elements forming an edge are already known (computed in meshfem2D),
-! the common nodes forming the edge are computed here
- if(coupled_elastic_poro) 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'
- print *
- print *,'Beginning of solid/porous edge detection'
- endif
-
-! define the edges of a given element
- i_begin(IBOTTOM) = 1
- j_begin(IBOTTOM) = 1
- i_end(IBOTTOM) = NGLLX
- j_end(IBOTTOM) = 1
-
- i_begin(IRIGHT) = NGLLX
- j_begin(IRIGHT) = 1
- i_end(IRIGHT) = NGLLX
- j_end(IRIGHT) = NGLLZ
-
- i_begin(ITOP) = NGLLX
- j_begin(ITOP) = NGLLZ
- i_end(ITOP) = 1
- j_end(ITOP) = NGLLZ
-
- i_begin(ILEFT) = 1
- j_begin(ILEFT) = NGLLZ
- i_end(ILEFT) = 1
- j_end(ILEFT) = 1
-
-! define i and j points for each edge
- do ipoin1D = 1,NGLLX
-
- ivalue(ipoin1D,IBOTTOM) = ipoin1D
- ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
- jvalue(ipoin1D,IBOTTOM) = 1
- jvalue_inverse(ipoin1D,IBOTTOM) = 1
-
- ivalue(ipoin1D,IRIGHT) = NGLLX
- ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
- jvalue(ipoin1D,IRIGHT) = ipoin1D
- jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
-
- ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
- ivalue_inverse(ipoin1D,ITOP) = ipoin1D
- jvalue(ipoin1D,ITOP) = NGLLZ
- jvalue_inverse(ipoin1D,ITOP) = NGLLZ
-
- ivalue(ipoin1D,ILEFT) = 1
- ivalue_inverse(ipoin1D,ILEFT) = 1
- jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
- jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
-
- enddo
-
-
- do inum = 1, num_solid_poro_edges
- ispec_elastic = solid_poro_elastic_ispec(inum)
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
-
-! one element must be elastic and the other must be poroelastic
- if(ispec_elastic /= ispec_poroelastic .and. elastic(ispec_elastic) .and. &
- poroelastic(ispec_poroelastic)) then
-
-! loop on the four edges of the two elements
- do iedge_poroelastic = 1,NEDGES
- do iedge_elastic = 1,NEDGES
-
-! store the matching topology if the two edges match in inverse order
- if(ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic) == &
- ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
- ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) == &
- ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
- solid_poro_elastic_iedge(inum) = iedge_elastic
- solid_poro_poroelastic_iedge(inum) = iedge_poroelastic
- endif
-
- enddo
- enddo
-
- endif
-
- enddo
-
-! make sure solid/porous matching has been perfectly detected: check that the grid points
-! have the same physical coordinates
-! loop on all the coupling edges
-
- if ( myrank == 0 ) then
- print *,'Checking solid/porous edge topology...'
- endif
-
- do inum = 1,num_solid_poro_edges
-
-! get the edge of the elastic element
- ispec_elastic = solid_poro_elastic_ispec(inum)
- iedge_elastic = solid_poro_elastic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the poroelastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_elastic)
- j = jvalue_inverse(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
-! get point values for the elastic side
- i = ivalue(ipoin1D,iedge_poroelastic)
- j = jvalue(ipoin1D,iedge_poroelastic)
- iglob2 = ibool(i,j,ispec_poroelastic)
-
-! if distance between the two points is not negligible, there is an error, since it should be zero
- if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
- call exit_MPI( 'error in solid/porous coupling buffer')
-
- enddo
-
- enddo
-
- if ( myrank == 0 ) then
- print *,'End of solid/porous edge detection'
- print *
- endif
-
- endif
-
-! initiation
- if(any_poroelastic .and. anyabs) then
-! loop on all the absorbing elements
- do ispecabs = 1,nelemabs
- jbegin_left_poro(ispecabs) = 1
- jbegin_right_poro(ispecabs) = 1
-
- jend_left_poro(ispecabs) = NGLLZ
- jend_right_poro(ispecabs) = NGLLZ
-
- ibegin_bottom_poro(ispecabs) = 1
- ibegin_top_poro(ispecabs) = 1
-
- iend_bottom_poro(ispecabs) = NGLLX
- iend_top_poro(ispecabs) = NGLLX
- enddo
- endif
-
-! exclude common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces
- if(coupled_elastic_poro .and. anyabs) then
-
- 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
-
- ispec = numabs(ispecabs)
-
-! loop on all the coupling edges
- do inum = 1,num_solid_poro_edges
-
-! 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/poroelastic coupled element is the same
- if(ispec_poroelastic == ispec) then
-
- if(iedge_poroelastic == IBOTTOM) then
- jbegin_left_poro(ispecabs) = 2
- jbegin_right_poro(ispecabs) = 2
- endif
-
- if(iedge_poroelastic == ITOP) then
- jend_left_poro(ispecabs) = NGLLZ - 1
- jend_right_poro(ispecabs) = NGLLZ - 1
- endif
-
- if(iedge_poroelastic == ILEFT) then
- ibegin_bottom_poro(ispecabs) = 2
- ibegin_top_poro(ispecabs) = 2
- endif
-
- if(iedge_poroelastic == IRIGHT) then
- iend_bottom_poro(ispecabs) = NGLLX - 1
- iend_top_poro(ispecabs) = NGLLX - 1
- endif
-
- endif
-
- enddo
-
- enddo
-
- endif
-
-#ifdef USE_MPI
- if(OUTPUT_ENERGY) stop 'energy calculation 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=IOUT_ENERGY,file='energy.gnu',status='unknown')
-
-!
-!---- s t a r t t i m e i t e r a t i o n s
-!
- if (myrank == 0) write(IOUT,400)
-
- ! count elapsed wall-clock time
- call date_and_time(datein,timein,zone,time_values)
- ! time_values(1): year
- ! time_values(2): month of the year
- ! time_values(3): day of the month
- ! time_values(5): hour of the day
- ! time_values(6): minutes of the hour
- ! time_values(7): seconds of the minute
- ! time_values(8): milliseconds of the second
- ! this fails if we cross the end of the month
- 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
- month_start = time_values(2)
- year_start = time_values(1)
-
- ! prepares image background
- if(output_color_image) then
- call prepare_color_image_vp(npoin,image_color_vp_display,iglob_image_color, &
- NX_IMAGE_color,NZ_IMAGE_color,nb_pixel_loc, &
- num_pixel_loc,nspec,poroelastic,ibool,kmato, &
- numat,density,poroelastcoef,porosity,tortuosity, &
- nproc,myrank,assign_external_model,vpext)
-
- 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
-
-! Precompute Runge Kutta coefficients if viscous attenuation
- if(TURN_VISCATTENUATION_ON) then
- theta_e = (sqrt(Q0**2+1.d0) +1.d0)/(2.d0*pi*freq0*Q0)
- theta_s = (sqrt(Q0**2+1.d0) -1.d0)/(2.d0*pi*freq0*Q0)
-
- thetainv = - 1.d0 / theta_s
- alphaval = 1.d0 + deltat*thetainv + deltat**2*thetainv**2 / 2.d0 + &
- deltat**3*thetainv**3 / 6.d0 + deltat**4*thetainv**4 / 24.d0
- betaval = deltat / 2.d0 + deltat**2*thetainv / 3.d0 + deltat**3*thetainv**2 / 8.d0 + deltat**4*thetainv**3 / 24.d0
- gammaval = deltat / 2.d0 + deltat**2*thetainv / 6.d0 + deltat**3*thetainv**2 / 24.d0
- print*,'************************************************************'
- print*,'****** Visco attenuation coefficients (poroelastic) ********'
- print*,'theta_e = ', theta_e
- print*,'theta_s = ', theta_s
- print*,'alpha = ', alphaval
- print*,'beta = ', betaval
- print*,'gamma = ', gammaval
- print*,'************************************************************'
-
-! initialize memory variables for attenuation
- viscox(:,:,:) = 0.d0
- viscoz(:,:,:) = 0.d0
- rx_viscous(:,:,:) = 0.d0
- rz_viscous(:,:,:) = 0.d0
-
- 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
- seismo_current = seismo_current + 1
-
-! compute current time
- time = (it-1)*deltat
-
-! update displacement using finite-difference time scheme (Newmark)
- if(any_elastic) then
- displ_elastic = displ_elastic &
- + deltat*veloc_elastic &
- + deltatsquareover2*accel_elastic
- veloc_elastic = veloc_elastic + deltatover2*accel_elastic
- accel_elastic = ZERO
-
- if(SIMULATION_TYPE == 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
-
- if(any_poroelastic) then
- !for the solid
- displs_poroelastic = displs_poroelastic &
- + deltat*velocs_poroelastic &
- + deltatsquareover2*accels_poroelastic
- velocs_poroelastic = velocs_poroelastic + deltatover2*accels_poroelastic
- accels_poroelastic = ZERO
- !for the fluid
- displw_poroelastic = displw_poroelastic &
- + deltat*velocw_poroelastic &
- + deltatsquareover2*accelw_poroelastic
- velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
- accelw_poroelastic = ZERO
-
- if(SIMULATION_TYPE == 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
- b_accels_poroelastic = ZERO
- !for the fluid
- b_displw_poroelastic = b_displw_poroelastic &
- + b_deltat*b_velocw_poroelastic &
- + b_deltatsquareover2*b_accelw_poroelastic
- b_velocw_poroelastic = b_velocw_poroelastic + b_deltatover2*b_accelw_poroelastic
- b_accelw_poroelastic = ZERO
- endif
- endif
-
-!--------------------------------------------------------------------------------------------
-! implement viscous attenuation for poroelastic media
-!
- if(TURN_VISCATTENUATION_ON .and. any_poroelastic) then
-! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
-! loop over spectral elements
-
- do ispec = 1,nspec
-
- etal_f = poroelastcoef(2,2,kmato(ispec))
- permlxx = permeability(1,kmato(ispec))
- permlxz = permeability(2,kmato(ispec))
- permlzz = permeability(3,kmato(ispec))
-
- ! calcul of the inverse of k
-
- detk = permlxx*permlzz - permlxz*permlxz
-
- if(detk /= ZERO) then
- invpermlxx = permlzz/detk
- invpermlxz = -permlxz/detk
- invpermlzz = permlxx/detk
- else
- stop 'Permeability matrix is not invertible'
- endif
-
- ! relaxed viscous coef
- bl_relaxed(1) = etal_f*invpermlxx
- bl_relaxed(2) = etal_f*invpermlxz
- bl_relaxed(3) = etal_f*invpermlzz
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- viscox_loc(i,j) = velocw_poroelastic(1,iglob)*bl_relaxed(1) + &
- velocw_poroelastic(2,iglob)*bl_relaxed(2)
- viscoz_loc(i,j) = velocw_poroelastic(1,iglob)*bl_relaxed(2) + &
- velocw_poroelastic(2,iglob)*bl_relaxed(3)
-
- ! evolution rx_viscous
- Sn = - (1.d0 - theta_e/theta_s)/theta_s*viscox(i,j,ispec)
- Snp1 = - (1.d0 - theta_e/theta_s)/theta_s*viscox_loc(i,j)
- rx_viscous(i,j,ispec) = alphaval * rx_viscous(i,j,ispec) &
- + betaval * Sn + gammaval * Snp1
-
- ! evolution rz_viscous
- Sn = - (1.d0 - theta_e/theta_s)/theta_s*viscoz(i,j,ispec)
- Snp1 = - (1.d0 - theta_e/theta_s)/theta_s*viscoz_loc(i,j)
- rz_viscous(i,j,ispec) = alphaval * rz_viscous(i,j,ispec) &
- + betaval * Sn + gammaval * Snp1
-
-
- enddo
- enddo
-
- ! save visco for Runge-Kutta scheme
- viscox(:,:,ispec) = viscox_loc(:,:)
- viscoz(:,:,ispec) = viscoz_loc(:,:)
-
- enddo ! end of spectral element loop
- endif ! end of viscous attenuation for porous media
-
-!-----------------------------------------
- if(any_acoustic) then
-
- ! Newmark time scheme
- 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(SIMULATION_TYPE == 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
- b_potential_dot_dot_acoustic = ZERO
- endif
-
- ! free surface for an acoustic medium
- if ( nelem_acoustic_surface > 0 ) then
- call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
-
- if(SIMULATION_TYPE == 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)
- endif
- endif
-
-! *********************************************************
-! ************* compute forces for the acoustic elements
-! *********************************************************
-
-! 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,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, &
-! SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top)
-
-
- call compute_forces_acoustic_2(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, &
- density,poroelastcoef,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, &
- SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
- nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
- b_absorb_acoustic_left,b_absorb_acoustic_right, &
- b_absorb_acoustic_bottom,b_absorb_acoustic_top)
- if( SIMULATION_TYPE == 2 ) then
- call compute_forces_acoustic_2(npoin,nspec,nelemabs,numat,it,NSTEP, &
- anyabs,assign_external_model,ibool,kmato,numabs, &
- elastic,poroelastic,codeabs,b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
- b_potential_acoustic, &
- density,poroelastcoef,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, &
- SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
- nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
- b_absorb_acoustic_left,b_absorb_acoustic_right, &
- b_absorb_acoustic_bottom,b_absorb_acoustic_top)
- endif
-
-
- ! stores absorbing boundary contributions into files
- if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
- !--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
- do i=1,NGLLZ
- write(65) b_absorb_acoustic_left(i,ispec,it)
- enddo
- enddo
- endif
- !--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
- do i=1,NGLLZ
- write(66) b_absorb_acoustic_right(i,ispec,it)
- enddo
- enddo
- endif
- !--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
- do i=1,NGLLX
- write(67) b_absorb_acoustic_bottom(i,ispec,it)
- enddo
- enddo
- endif
- !--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
- do i=1,NGLLX
- write(68) b_absorb_acoustic_top(i,ispec,it)
- enddo
- enddo
- endif
- endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
-
- endif ! end of test if any acoustic element
-
-! *********************************************************
-! ************* add coupling with the elastic 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 elastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_elastic)
- j = jvalue_inverse(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
- displ_x = displ_elastic(1,iglob)
- displ_z = displ_elastic(3,iglob)
-
- if(SIMULATION_TYPE == 2) then
- b_displ_x = b_displ_elastic(1,iglob)
- b_displ_z = b_displ_elastic(3,iglob)
- endif
-
-! get point values for the acoustic side
- i = ivalue(ipoin1D,iedge_acoustic)
- j = jvalue(ipoin1D,iedge_acoustic)
- iglob = ibool(i,j,ispec_acoustic)
-
-! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
-! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
-! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
-! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
-! Blackwell Science, page 110, equation (4.60).
- if(iedge_acoustic == 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
-
-! compute dot product
- displ_n = displ_x*nx + displ_z*nz
-
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
-
- if(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) +&
- weight*(b_displ_x*nx + b_displ_z*nz)
- endif !if(SIMULATION_TYPE == 2) then
-
- enddo
-
- enddo
-
- endif
-
-! *********************************************************
-! ************* add coupling with the poroelastic side
-! *********************************************************
-
- if(coupled_acoustic_poro) then
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_poro_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_poro_acoustic_ispec(inum)
- iedge_acoustic = fluid_poro_acoustic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the poroelastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_poroelastic)
- j = jvalue_inverse(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
-
- displ_x = displs_poroelastic(1,iglob)
- displ_z = displs_poroelastic(2,iglob)
-
- phil = porosity(kmato(ispec_poroelastic))
- displw_x = displw_poroelastic(1,iglob)
- displw_z = displw_poroelastic(2,iglob)
-
- if(SIMULATION_TYPE == 2) then
- b_displ_x = b_displs_poroelastic(1,iglob)
- b_displ_z = b_displs_poroelastic(2,iglob)
-
- b_displw_x = b_displw_poroelastic(1,iglob)
- b_displw_z = b_displw_poroelastic(2,iglob)
- endif
-
-! get point values for the acoustic side
-! get point values for the acoustic side
- i = ivalue(ipoin1D,iedge_acoustic)
- j = jvalue(ipoin1D,iedge_acoustic)
- iglob = ibool(i,j,ispec_acoustic)
-
-! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
-! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
-! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
-! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
-! Blackwell Science, page 110, equation (4.60).
- if(iedge_acoustic == 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
-
-! compute dot product [u_s + w]*n
- displ_n = (displ_x + displw_x)*nx + (displ_z + displw_z)*nz
-
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
-
- if(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
- + weight*((b_displ_x + b_displw_x)*nx + (b_displ_z + b_displw_z)*nz)
- endif
-
- enddo
-
- enddo
-
- endif
-
-
-! ************************************************************************************
-! ************************************ add force source
-! ************************************************************************************
-
- if(any_acoustic) then
-
-! --- add the source
- if(.not. initialfield) then
-
- do i_source=1,NSOURCES
- ! 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(SIMULATION_TYPE == 1) then
- ! forward wavefield
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
- - source_time_function(i_source,it)*hlagrange
- enddo
- enddo
- else
- ! backward wavefield
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
- - source_time_function(i_source,NSTEP-it+1)*hlagrange
- enddo
- enddo
- 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,NSOURCES
-
- if(SIMULATION_TYPE == 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
-
- irec_local = irec_local + 1
- if (.not. elastic(ispec_selected_rec(irec)) .and. &
- .not. poroelastic(ispec_selected_rec(irec))) then
- ! 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 element acoustic
-
- endif ! if this processor carries the adjoint source
- enddo ! irec = 1,nrec
- endif ! SIMULATION_TYPE == 2 adjoint wavefield
-
- endif ! if not using an initial field
-
- endif !if(any_acoustic)
-
-
-! 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(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, &
- buffer_recv_faces_vector_ac, my_neighbours)
-
- if ( SIMULATION_TYPE == 2) then
- call assemble_MPI_vector_ac(b_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, &
- buffer_recv_faces_vector_ac, my_neighbours)
-
- endif
-
- endif
-
-! if ( nproc > 1 .and. any_acoustic .and. ninterface_acoustic > 0 .and. SIMULATION_TYPE == 2) then
-! call assemble_MPI_vector_ac(b_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, &
-! buffer_recv_faces_vector_ac, my_neighbours)
-! endif
-#endif
-
-! ************************************************************************************
-! ************* multiply by the inverse of the mass matrix and update velocity
-! ************************************************************************************
-
- if(any_acoustic) then
-
- potential_dot_dot_acoustic = potential_dot_dot_acoustic * rmass_inverse_acoustic
- potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
-
- if(SIMULATION_TYPE ==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)
-
- if(SIMULATION_TYPE == 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)
- endif
-
- endif
-
- endif !if(any_acoustic)
-
-
-! *********************************************************
-! ************* main solver for the elastic elements
-! *********************************************************
-
- if(any_elastic) then
- call compute_forces_viscoelastic(p_sv,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,angleforce,deltatcube, &
- 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,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy, &
- 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, &
- 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_bottom,over_critical_angle, &
- NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,mu_k,kappa_k)
-
- if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
-!--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLZ
- write(35) b_absorb_elastic_left(1,i,ispec,it)
- enddo
- do i=1,NGLLZ
- write(35) b_absorb_elastic_left(3,i,ispec,it)
- enddo
- else!SH (membrane) waves
- do i=1,NGLLZ
- write(35) b_absorb_elastic_left(2,i,ispec,it)
- enddo
- endif
-
- enddo
- endif
-
-!--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
-
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLZ
- write(36) b_absorb_elastic_right(1,i,ispec,it)
- enddo
- do i=1,NGLLZ
- write(36) b_absorb_elastic_right(3,i,ispec,it)
- enddo
- else!SH (membrane) waves
- do i=1,NGLLZ
- write(36) b_absorb_elastic_right(2,i,ispec,it)
- enddo
- endif
-
- enddo
- endif
-
-!--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLX
- write(37) b_absorb_elastic_bottom(1,i,ispec,it)
- enddo
- do i=1,NGLLX
- write(37) b_absorb_elastic_bottom(3,i,ispec,it)
- enddo
- else!SH (membrane) waves
- do i=1,NGLLX
- write(37) b_absorb_elastic_bottom(2,i,ispec,it)
- enddo
- endif
-
- enddo
- endif
-
-!--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLX
- write(38) b_absorb_elastic_top(1,i,ispec,it)
- enddo
- do i=1,NGLLX
- write(38) b_absorb_elastic_top(3,i,ispec,it)
- enddo
- else!SH (membrane) waves
- do i=1,NGLLX
- write(38) b_absorb_elastic_top(2,i,ispec,it)
- enddo
- endif
-
- enddo
- endif
-
- endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
-
- 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(SIMULATION_TYPE == 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(3,iglob) = accel_elastic(3,iglob) + weight*nz*pressure
-
- if(SIMULATION_TYPE == 2) then
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + weight*nx*b_pressure
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) + weight*nz*b_pressure
- endif !if(SIMULATION_TYPE == 2) then
-
- enddo
-
- enddo
-
- endif
-
-! ****************************************************************************
-! ************* add coupling with the poroelastic side
-! ****************************************************************************
- if(coupled_elastic_poro) then
-
-! loop on all the coupling edges
- do inum = 1,num_solid_poro_edges
-
-! get the edge of the elastic element
- ispec_elastic = solid_poro_elastic_ispec(inum)
- iedge_elastic = solid_poro_elastic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the poroelastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_poroelastic)
- j = jvalue_inverse(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
-
-! get poroelastic domain paramters
- phil = porosity(kmato(ispec_poroelastic))
- tortl = tortuosity(kmato(ispec_poroelastic))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec_poroelastic))
- kappal_s = poroelastcoef(3,1,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
- rhol_s = density(1,kmato(ispec_poroelastic))
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec_poroelastic))
- rhol_f = density(2,kmato(ispec_poroelastic))
-!frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec_poroelastic))
- kappal_fr = poroelastcoef(3,3,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-!Biot coefficients for the input phi
- D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
- kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
- mul_G = mul_fr
- lambdal_G = H_biot - 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
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
-
- b_dwx_dxi = ZERO
- b_dwz_dxi = ZERO
-
- b_dwx_dgamma = ZERO
- b_dwz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
-
- b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec_poroelastic)
- xizl = xiz(i,j,ispec_poroelastic)
- gammaxl = gammax(i,j,ispec_poroelastic)
- gammazl = gammaz(i,j,ispec_poroelastic)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
-
- dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
-
- b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
- b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
-
- b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
- b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
- endif
-! compute stress tensor (include attenuation or anisotropy if needed)
-
-! no attenuation
- sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = mul_G*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- if(SIMULATION_TYPE == 2) then
- b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
- 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
- ii2 = ivalue(ipoin1D,iedge_elastic)
- jj2 = jvalue(ipoin1D,iedge_elastic)
- iglob = ibool(ii2,jj2,ispec_elastic)
-
-! get elastic properties
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec_elastic))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec_elastic))
- lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec_elastic))
-
-! derivative along x and along z for u_s and w
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
- duz_dxi = duz_dxi + displ_elastic(3,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
- dux_dgamma = dux_dgamma + displ_elastic(1,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
- duz_dgamma = duz_dgamma + displ_elastic(3,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
- b_duz_dxi = b_duz_dxi + b_displ_elastic(3,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
- b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
- b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
- endif
- enddo
-
- xixl = xix(ii2,jj2,ispec_elastic)
- xizl = xiz(ii2,jj2,ispec_elastic)
- gammaxl = gammax(ii2,jj2,ispec_elastic)
- gammazl = gammaz(ii2,jj2,ispec_elastic)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
- endif
-! compute stress tensor
-! full anisotropy
- if(kmato(ispec_elastic) == 2) then
-! implement anisotropy in 2D
- if(assign_external_model) then
- c11 = c11ext(ii2,jj2,ispec_elastic)
- c13 = c13ext(ii2,jj2,ispec_elastic)
- c15 = c15ext(ii2,jj2,ispec_elastic)
- c33 = c33ext(ii2,jj2,ispec_elastic)
- c35 = c35ext(ii2,jj2,ispec_elastic)
- c55 = c55ext(ii2,jj2,ispec_elastic)
- else
- c11 = anisotropy(1,kmato(ispec_elastic))
- c13 = anisotropy(2,kmato(ispec_elastic))
- c15 = anisotropy(3,kmato(ispec_elastic))
- c33 = anisotropy(4,kmato(ispec_elastic))
- c35 = anisotropy(5,kmato(ispec_elastic))
- c55 = anisotropy(6,kmato(ispec_elastic))
- end if
-
- sigma_xx = sigma_xx + c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
- sigma_zz = sigma_zz + c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
- sigma_xz = sigma_xz + c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
- else
-! no attenuation
- sigma_xx = sigma_xx + lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
- sigma_xz = sigma_xz + mul_relaxed*(duz_dxl + dux_dzl)
- sigma_zz = sigma_zz + lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
- endif
-
- if(SIMULATION_TYPE == 2) then
- b_sigma_xx = b_sigma_xx + lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
- b_sigma_xz = b_sigma_xz + mul_relaxed*(b_duz_dxl + b_dux_dzl)
- b_sigma_zz = b_sigma_zz + lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
- endif
-
-! 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_poroelastic == ITOP)then
- xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_poroelastic == IBOTTOM)then
- xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_poroelastic ==ILEFT)then
- xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- elseif(iedge_poroelastic ==IRIGHT)then
- xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- endif
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - weight* &
- (sigma_xx*nx + sigma_xz*nz)/2.d0
-
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - weight* &
- (sigma_xz*nx + sigma_zz*nz)/2.d0
-
- if(SIMULATION_TYPE == 2) then
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - weight* &
- (b_sigma_xx*nx + b_sigma_xz*nz)/2.d0
-
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - weight* &
- (b_sigma_xz*nx + b_sigma_zz*nz)/2.d0
- endif !if(SIMULATION_TYPE == 2) then
-
- enddo
-
- enddo
-
- endif
-
-
-! ************************************************************************************
-! ************************************ add force source
-! ************************************************************************************
-
- if(any_elastic) then
-
-! --- add the source if it is a collocated force
- if(.not. initialfield) then
-
- do i_source=1,NSOURCES
-! 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(SIMULATION_TYPE == 1) then ! forward wavefield
-
- if(p_sv) then ! P-SV calculation
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- accel_elastic(1,iglob) = accel_elastic(1,iglob) &
- - sin(angleforce(i_source))*source_time_function(i_source,it)*hlagrange
- accel_elastic(3,iglob) = accel_elastic(3,iglob) &
- + cos(angleforce(i_source))*source_time_function(i_source,it)*hlagrange
- enddo
- enddo
- else ! SH (membrane) calculation
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- accel_elastic(2,iglob) = accel_elastic(2,iglob) &
- + source_time_function(i_source,it)*hlagrange
- enddo
- enddo
- endif
-
- else ! backward wavefield
-
- if(p_sv) then ! P-SV calculation
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) &
- - sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1) &
- *hlagrange
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) &
- + cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1) &
- *hlagrange
- enddo
- enddo
- else ! SH (membrane) calculation
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) &
- + source_time_function(i_source,NSTEP-it+1)*hlagrange
- enddo
- enddo
-
- endif
-
- endif !endif SIMULATION_TYPE == 1
- endif
-
- endif ! if this processor carries the source and the source element is elastic
- enddo ! do i_source=1,NSOURCES
-
- endif ! if not using an initial field
- endif !if(any_elastic)
-
-! 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(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
-
- if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0 .and. SIMULATION_TYPE == 2) then
- call assemble_MPI_vector_el(b_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
-
-
-! ************************************************************************************
-! ************* multiply by the inverse of the mass matrix and update velocity
-! ************************************************************************************
-
- if(any_elastic) then
- accel_elastic(1,:) = accel_elastic(1,:) * rmass_inverse_elastic
- accel_elastic(2,:) = accel_elastic(2,:) * rmass_inverse_elastic
- accel_elastic(3,:) = accel_elastic(3,:) * rmass_inverse_elastic
-
- veloc_elastic = veloc_elastic + deltatover2*accel_elastic
-
- if(SIMULATION_TYPE == 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_accel_elastic(3,:) = b_accel_elastic(3,:) * rmass_inverse_elastic(:)
-
- b_veloc_elastic = b_veloc_elastic + b_deltatover2*b_accel_elastic
- endif
-
- endif !if(any_elastic)
-
-
-! ******************************************************************************************************************
-! ************* main solver for the poroelastic elements: first the solid (u_s) than the fluid (w)
-! ******************************************************************************************************************
-
- if(any_poroelastic) then
-
- if(SIMULATION_TYPE == 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_poro_solid(npoin,nspec,myrank,nelemabs,numat, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
- source_type,it,NSTEP,anyabs, &
- initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,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_displw_poroelastic,&
- density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
- 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_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,&
- mufr_k,B_k,NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,f0(1),freq0,Q0)
-
-
-
- call compute_forces_poro_fluid(npoin,nspec,myrank,nelemabs,numat, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
- source_type,it,NSTEP,anyabs, &
- initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
- accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
- b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
- density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
- jacobian,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_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,&
- C_k,M_k,NSOURCES,nrec,SIMULATION_TYPE,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_left,ib_right,ib_bottom,ib_top,f0(1),freq0,Q0)
-
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
-! if inviscid fluid, comment
-! write(23,rec=it) b_viscodampx
-! write(24,rec=it) b_viscodampz
- endif
-
- if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
-
-!--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
- do id =1,2
- do i=1,NGLLZ
- write(45) b_absorb_poro_s_left(id,i,ispec,it)
- write(25) b_absorb_poro_w_left(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
-!--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
- do id =1,2
- do i=1,NGLLZ
- write(46) b_absorb_poro_s_right(id,i,ispec,it)
- write(26) b_absorb_poro_w_right(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
-!--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
- do id =1,2
- do i=1,NGLLX
- write(47) b_absorb_poro_s_bottom(id,i,ispec,it)
- write(29) b_absorb_poro_w_bottom(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
-!--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
- do id =1,2
- do i=1,NGLLX
- write(48) b_absorb_poro_s_top(id,i,ispec,it)
- write(28) b_absorb_poro_w_top(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
- endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
-
- endif !if(any_poroelastic) then
-
-! *********************************************************
-! ************* add coupling with the acoustic side
-! *********************************************************
-
- if(coupled_acoustic_poro) 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(SIMULATION_TYPE == 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(SIMULATION_TYPE == 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(SIMULATION_TYPE == 2) then
-
- enddo ! do ipoin1D = 1,NGLLX
-
- enddo ! do inum = 1,num_fluid_poro_edges
-
- endif ! if(coupled_acoustic_poro)
-
-! ****************************************************************************
-! ************* add coupling with the elastic side
-! ****************************************************************************
-
- if(coupled_elastic_poro) then
-
-! loop on all the coupling edges
- do inum = 1,num_solid_poro_edges
-
-! get the edge of the elastic element
- ispec_elastic = solid_poro_elastic_ispec(inum)
- iedge_elastic = solid_poro_elastic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the elastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_elastic)
- j = jvalue_inverse(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
-! get elastic properties
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec_elastic))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec_elastic))
- lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec_elastic))
-
-! derivative along x and along z for u_s and w
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,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(3,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
-
- if(SIMULATION_TYPE == 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(3,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
- b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec_elastic)
- xizl = xiz(i,j,ispec_elastic)
- gammaxl = gammax(i,j,ispec_elastic)
- gammazl = gammaz(i,j,ispec_elastic)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
- endif
-! compute stress tensor
-! full anisotropy
- if(kmato(ispec_elastic) == 2) then
-! implement anisotropy in 2D
- if(assign_external_model) then
- c11 = c11ext(i,j,ispec_elastic)
- c13 = c13ext(i,j,ispec_elastic)
- c15 = c15ext(i,j,ispec_elastic)
- c33 = c33ext(i,j,ispec_elastic)
- c35 = c35ext(i,j,ispec_elastic)
- c55 = c55ext(i,j,ispec_elastic)
- else
- c11 = anisotropy(1,kmato(ispec_elastic))
- c13 = anisotropy(2,kmato(ispec_elastic))
- c15 = anisotropy(3,kmato(ispec_elastic))
- c33 = anisotropy(4,kmato(ispec_elastic))
- c35 = anisotropy(5,kmato(ispec_elastic))
- c55 = anisotropy(6,kmato(ispec_elastic))
- end if
- sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
- sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
- sigma_xz = c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
- else
-! 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
- endif
-
- if(SIMULATION_TYPE == 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 ! if(SIMULATION_TYPE == 2)
-
-! get point values for the poroelastic side
- i = ivalue(ipoin1D,iedge_poroelastic)
- j = jvalue(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
-
-! get poroelastic domain paramters
- phil = porosity(kmato(ispec_poroelastic))
- tortl = tortuosity(kmato(ispec_poroelastic))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec_poroelastic))
- kappal_s = poroelastcoef(3,1,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
- rhol_s = density(1,kmato(ispec_poroelastic))
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec_poroelastic))
- rhol_f = density(2,kmato(ispec_poroelastic))
-!frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec_poroelastic))
- kappal_fr = poroelastcoef(3,3,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-!Biot coefficients for the input phi
- D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
- kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
- mul_G = mul_fr
- lambdal_G = H_biot - 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
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
-
- b_dwx_dxi = ZERO
- b_dwz_dxi = ZERO
-
- b_dwx_dgamma = ZERO
- b_dwz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
-
- b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec_poroelastic)
- xizl = xiz(i,j,ispec_poroelastic)
- gammaxl = gammax(i,j,ispec_poroelastic)
- gammazl = gammaz(i,j,ispec_poroelastic)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
-
- dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
-
- b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
- b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
-
- b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
- b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
- endif
-! compute stress tensor
-
-! no attenuation
- sigma_xx = sigma_xx + lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = sigma_xz + mul_G*(duz_dxl + dux_dzl)
- sigma_zz = sigma_zz + lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
-
- if(SIMULATION_TYPE == 2) then
- b_sigma_xx = b_sigma_xx + lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- b_sigma_xz = b_sigma_xz + mul_G*(b_duz_dxl + b_dux_dzl)
- b_sigma_zz = b_sigma_zz + lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
- endif
-
-! 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_poroelastic == ITOP)then
- xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_poroelastic == IBOTTOM)then
- xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_poroelastic ==ILEFT)then
- xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- elseif(iedge_poroelastic ==IRIGHT)then
- xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- endif
-
-! contribution to the solid phase
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + &
- weight*((sigma_xx*nx + sigma_xz*nz)/2.d0 -phil/tortl*sigmap*nx)
-
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + &
- weight*((sigma_xz*nx + sigma_zz*nz)/2.d0 -phil/tortl*sigmap*nz)
-
-! contribution to the fluid phase
-! w = 0
-
- if(SIMULATION_TYPE == 2) then
-! contribution to the solid phase
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + &
- weight*((b_sigma_xx*nx + b_sigma_xz*nz)/2.d0 -phil/tortl*b_sigmap*nx)
-
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + &
- weight*((b_sigma_xz*nx + b_sigma_zz*nz)/2.d0 -phil/tortl*b_sigmap*nz)
-
-! contribution to the fluid phase
-! w = 0
- endif !if(SIMULATION_TYPE == 2) then
-
- enddo
-
- enddo
-
- endif ! if(coupled_elastic_poro)
-
-
-! ************************************************************************************
-! ******************************** add force source
-! ************************************************************************************
-
- if(any_poroelastic) then
-
-
-! --- add the source if it is a collocated force
- if(.not. initialfield) then
-
- do i_source=1,NSOURCES
-! 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
-
- 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
-
-! collocated force
- if(source_type(i_source) == 1) then
- if(SIMULATION_TYPE == 1) then ! forward wavefield
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
-! s
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - hlagrange * &
- (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,it)
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + hlagrange * &
- (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,it)
-! w
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - hlagrange * &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,it)
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + hlagrange * &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,it)
- enddo
- enddo
- else ! backward wavefield
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
-! b_s
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - hlagrange * &
- (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + hlagrange * &
- (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
-!b_w
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - hlagrange * &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + hlagrange * &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- enddo
- enddo
- endif !endif SIMULATION_TYPE == 1
- endif
-
- endif ! if this processor carries the source and the source element is elastic
- enddo ! do i_source=1,NSOURCES
-
- endif ! if not using an initial field
- endif !if(any_poroelastic)
-
-! 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_poro,buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
- buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
- my_neighbours)
- endif
-
- if (nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0 .and. SIMULATION_TYPE == 2) then
- call assemble_MPI_vector_po(b_accels_poroelastic,b_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_poro,buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
- buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
- my_neighbours)
- endif
-#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(SIMULATION_TYPE == 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)
-
-!*******************************************************************************
-! assembling the displacements on the elastic-poro boundaries
-!*******************************************************************************
- if(coupled_elastic_poro) then
- icount(:)=ZERO
-
-! loop on all the coupling edges
- do inum = 1,num_solid_poro_edges
-! get the edge of the elastic element
- ispec_elastic = solid_poro_elastic_ispec(inum)
- iedge_elastic = solid_poro_elastic_iedge(inum)
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
-
- do ipoin1D = 1,NGLLX
-! recovering original velocities and accelerations on boundaries (elastic side)
- i = ivalue(ipoin1D,iedge_poroelastic)
- j = jvalue(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
- icount(iglob) = icount(iglob) + 1
-
- if(icount(iglob) ==1)then
- veloc_elastic(1,iglob) = veloc_elastic(1,iglob) - deltatover2*accel_elastic(1,iglob)
- veloc_elastic(3,iglob) = veloc_elastic(3,iglob) - deltatover2*accel_elastic(3,iglob)
- accel_elastic(1,iglob) = accel_elastic(1,iglob) / rmass_inverse_elastic(iglob)
- accel_elastic(3,iglob) = accel_elastic(3,iglob) / rmass_inverse_elastic(iglob)
-! recovering original velocities and accelerations on boundaries (poro side)
- velocs_poroelastic(1,iglob) = velocs_poroelastic(1,iglob) - deltatover2*accels_poroelastic(1,iglob)
- velocs_poroelastic(2,iglob) = velocs_poroelastic(2,iglob) - deltatover2*accels_poroelastic(2,iglob)
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) / rmass_s_inverse_poroelastic(iglob)
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) / rmass_s_inverse_poroelastic(iglob)
-! assembling accelerations
- accel_elastic(1,iglob) = ( accel_elastic(1,iglob) + accels_poroelastic(1,iglob) ) / &
- ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
- accel_elastic(3,iglob) = ( accel_elastic(3,iglob) + accels_poroelastic(2,iglob) ) / &
- ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
- accels_poroelastic(1,iglob) = accel_elastic(1,iglob)
- accels_poroelastic(2,iglob) = accel_elastic(3,iglob)
-! updating velocities
- velocs_poroelastic(1,iglob) = velocs_poroelastic(1,iglob) + deltatover2*accels_poroelastic(1,iglob)
- velocs_poroelastic(2,iglob) = velocs_poroelastic(2,iglob) + deltatover2*accels_poroelastic(2,iglob)
- veloc_elastic(1,iglob) = veloc_elastic(1,iglob) + deltatover2*accel_elastic(1,iglob)
- veloc_elastic(3,iglob) = veloc_elastic(3,iglob) + deltatover2*accel_elastic(3,iglob)
-! zeros w
- accelw_poroelastic(1,iglob) = ZERO
- accelw_poroelastic(2,iglob) = ZERO
- velocw_poroelastic(1,iglob) = ZERO
- velocw_poroelastic(2,iglob) = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_veloc_elastic(1,iglob) = b_veloc_elastic(1,iglob) - b_deltatover2*b_accel_elastic(1,iglob)
- b_veloc_elastic(3,iglob) = b_veloc_elastic(3,iglob) - b_deltatover2*b_accel_elastic(3,iglob)
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) / rmass_inverse_elastic(iglob)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) / rmass_inverse_elastic(iglob)
-! recovering original velocities and accelerations on boundaries (poro side)
- b_velocs_poroelastic(1,iglob) = b_velocs_poroelastic(1,iglob) - b_deltatover2*b_accels_poroelastic(1,iglob)
- b_velocs_poroelastic(2,iglob) = b_velocs_poroelastic(2,iglob) - b_deltatover2*b_accels_poroelastic(2,iglob)
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) / rmass_s_inverse_poroelastic(iglob)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) / rmass_s_inverse_poroelastic(iglob)
-! assembling accelerations
- b_accel_elastic(1,iglob) = ( b_accel_elastic(1,iglob) + b_accels_poroelastic(1,iglob) ) / &
- ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
- b_accel_elastic(3,iglob) = ( b_accel_elastic(3,iglob) + b_accels_poroelastic(2,iglob) ) / &
- ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
- b_accels_poroelastic(1,iglob) = b_accel_elastic(1,iglob)
- b_accels_poroelastic(2,iglob) = b_accel_elastic(3,iglob)
-! updating velocities
- b_velocs_poroelastic(1,iglob) = b_velocs_poroelastic(1,iglob) + b_deltatover2*b_accels_poroelastic(1,iglob)
- b_velocs_poroelastic(2,iglob) = b_velocs_poroelastic(2,iglob) + b_deltatover2*b_accels_poroelastic(2,iglob)
- b_veloc_elastic(1,iglob) = b_veloc_elastic(1,iglob) + b_deltatover2*b_accel_elastic(1,iglob)
- b_veloc_elastic(3,iglob) = b_veloc_elastic(3,iglob) + b_deltatover2*b_accel_elastic(3,iglob)
-! zeros w
- b_accelw_poroelastic(1,iglob) = ZERO
- b_accelw_poroelastic(2,iglob) = ZERO
- b_velocw_poroelastic(1,iglob) = ZERO
- b_velocw_poroelastic(2,iglob) = ZERO
- endif !if(SIMULATION_TYPE == 2)
-
- endif !if(icount(iglob) ==1)
-
- enddo
-
- enddo
- endif
-
-! ********************************************************************************************
-! reading lastframe for adjoint/kernels calculation
-! ********************************************************************************************
- if(it == 1 .and. SIMULATION_TYPE == 2) then
-
-! acoustic medium
- if(any_acoustic) then
- write(outputname,'(a,i6.6,a)') 'lastframe_acoustic',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
- do j=1,npoin
- read(55) b_potential_acoustic(j),&
- b_potential_dot_acoustic(j),&
- b_potential_dot_dot_acoustic(j)
- enddo
- close(55)
-
-! free surface for an acoustic medium
- if ( nelem_acoustic_surface > 0 ) 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)
- endif
- endif
-
-! elastic medium
- if(any_elastic) then
- write(outputname,'(a,i6.6,a)') 'lastframe_elastic',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
- if(p_sv)then !P-SV waves
- do j=1,npoin
- read(55) (b_displ_elastic(i,j), i=1,NDIM), &
- (b_veloc_elastic(i,j), i=1,NDIM), &
- (b_accel_elastic(i,j), i=1,NDIM)
- enddo
- b_displ_elastic(3,:) = b_displ_elastic(2,:)
- b_displ_elastic(2,:) = 0._CUSTOM_REAL
- b_veloc_elastic(3,:) = b_veloc_elastic(2,:)
- b_veloc_elastic(2,:) = 0._CUSTOM_REAL
- b_accel_elastic(3,:) = b_accel_elastic(2,:)
- b_accel_elastic(2,:) = 0._CUSTOM_REAL
- else !SH (membrane) waves
- do j=1,npoin
- read(55) b_displ_elastic(2,j), &
- b_veloc_elastic(2,j), &
- b_accel_elastic(2,j)
- enddo
- b_displ_elastic(1,:) = 0._CUSTOM_REAL
- b_displ_elastic(3,:) = 0._CUSTOM_REAL
- b_veloc_elastic(1,:) = 0._CUSTOM_REAL
- b_veloc_elastic(3,:) = 0._CUSTOM_REAL
- b_accel_elastic(1,:) = 0._CUSTOM_REAL
- b_accel_elastic(3,:) = 0._CUSTOM_REAL
- endif
- close(55)
- endif
-
-! poroelastic medium
- if(any_poroelastic) then
- write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
- write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_w',myrank,'.bin'
- open(unit=56,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
- do j=1,npoin
- read(55) (b_displs_poroelastic(i,j), i=1,NDIM), &
- (b_velocs_poroelastic(i,j), i=1,NDIM), &
- (b_accels_poroelastic(i,j), i=1,NDIM)
- read(56) (b_displw_poroelastic(i,j), i=1,NDIM), &
- (b_velocw_poroelastic(i,j), i=1,NDIM), &
- (b_accelw_poroelastic(i,j), i=1,NDIM)
- enddo
- close(55)
- close(56)
- endif
-
- endif ! if(it == 1 .and. SIMULATION_TYPE == 2)
-
-! ********************************************************************************************
-! kernels calculation
-! ********************************************************************************************
- if(any_elastic .and. SIMULATION_TYPE == 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(3,iglob)*b_displ_elastic(3,iglob)
- rhorho_el_hessian_temp1(iglob) = accel_elastic(1,iglob)*accel_elastic(1,iglob) +&
- accel_elastic(2,iglob)*accel_elastic(2,iglob) +&
- accel_elastic(3,iglob)*accel_elastic(3,iglob)
- rhorho_el_hessian_temp2(iglob) = accel_elastic(1,iglob)*b_accel_elastic(1,iglob) +&
- accel_elastic(2,iglob)*b_accel_elastic(2,iglob) +&
- accel_elastic(3,iglob)*b_accel_elastic(3,iglob)
- enddo
- endif
-
- if(any_poroelastic .and. SIMULATION_TYPE ==2) then
- do iglob =1,npoin
- rhot_k(iglob) = accels_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
- accels_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob)
- rhof_k(iglob) = accelw_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
- accelw_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob) + &
- accels_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
- accels_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
- sm_k(iglob) = accelw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
- accelw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
- eta_k(iglob) = velocw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
- velocw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
- enddo
- endif
-
-!---- compute kinetic and potential energy
- if(OUTPUT_ENERGY) &
- call compute_energy(displ_elastic,veloc_elastic, &
- displs_poroelastic,velocs_poroelastic, &
- displw_poroelastic,velocw_poroelastic, &
- xix,xiz,gammax,gammaz,jacobian,ibool,elastic,poroelastic,hprime_xx,hprime_zz, &
- nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- assign_external_model,it,deltat,t0,kmato,poroelastcoef,density, &
- porosity,tortuosity, &
- vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext, &
- anisotropic,anisotropy,wxgll,wzgll,numat, &
- pressure_element,vector_field_element,e1,e11, &
- potential_dot_acoustic,potential_dot_dot_acoustic, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS,p_sv)
-
-!---- display time step and max of norm of displacement
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
- call check_stability(myrank,time,it,NSTEP, &
- npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- any_elastic_glob,any_elastic,displ_elastic, &
- any_poroelastic_glob,any_poroelastic, &
- displs_poroelastic,displw_poroelastic, &
- any_acoustic_glob,any_acoustic,potential_acoustic, &
- year_start,month_start,time_start)
- endif
-
-! loop on all the receivers to compute and store the seismograms
- do irecloc = 1,nrecloc
-
- 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_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
- TURN_ATTENUATION_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_acoustic,npoin_elastic,npoin_poroelastic, &
- 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_acoustic,npoin_elastic,npoin_poroelastic, &
- 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_acoustic,npoin_elastic,npoin_poroelastic, &
- 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_elastic,npoin_poroelastic,ispec)
- endif
-
-! perform the general interpolation using Lagrange polynomials
- valux = ZERO
- valuy = ZERO
- valuz = ZERO
- valcurl = ZERO
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- 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 /= 6) then
-
- dxd = vector_field_element(1,i,j)
- dzd = vector_field_element(3,i,j)
-
- else if(seismotype == 6) then
-
- dxd = potential_acoustic(iglob)
- dzd = ZERO
-
- else if(seismotype == 1) then
-
- if(poroelastic(ispec)) then
- dxd = displs_poroelastic(1,iglob)
- dzd = displs_poroelastic(2,iglob)
- elseif(elastic(ispec)) then
- dxd = displ_elastic(1,iglob)
- dyd = displ_elastic(2,iglob)
- dzd = displ_elastic(3,iglob)
- endif
-
- else if(seismotype == 2) then
-
- if(poroelastic(ispec)) then
- dxd = velocs_poroelastic(1,iglob)
- dzd = velocs_poroelastic(2,iglob)
- elseif(elastic(ispec)) then
- dxd = veloc_elastic(1,iglob)
- dyd = veloc_elastic(2,iglob)
- dzd = veloc_elastic(3,iglob)
- endif
-
- else if(seismotype == 3) then
-
- if(poroelastic(ispec)) then
- dxd = accels_poroelastic(1,iglob)
- dzd = accels_poroelastic(2,iglob)
- elseif(elastic(ispec)) then
- dxd = accel_elastic(1,iglob)
- dyd = accel_elastic(2,iglob)
- dzd = accel_elastic(3,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
- if(elastic(ispec)) valuy = valuy + dyd*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 /= 6) then
- if(p_sv) 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) = valuy
- sisuz(seismo_current,irecloc) = ZERO
- endif
- else
- sisux(seismo_current,irecloc) = valux
- sisuz(seismo_current,irecloc) = ZERO
- endif
- siscurl(seismo_current,irecloc) = valcurl
-
- enddo
-
-
-!----- writing the kernels
-!
-! kernels output
- if(SIMULATION_TYPE == 2) then
-
- if(any_acoustic) then
-
- do ispec = 1, nspec
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- kappal_ac_global(iglob) = poroelastcoef(3,1,kmato(ispec))
- rhol_ac_global(iglob) = density(1,kmato(ispec))
-
-! calcul the displacement by computing the gradient of potential / rho
-! and calcul the acceleration by computing the gradient of potential_dot_dot / rho
- tempx1l = ZERO
- tempx2l = ZERO
- b_tempx1l = ZERO
- b_tempx2l = ZERO
- do k = 1,NGLLX
-! derivative along x
- tempx1l = tempx1l + potential_dot_dot_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
- b_tempx1l = b_tempx1l + b_potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
- bb_tempx1l = bb_tempx1l + b_potential_dot_dot_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
-! derivative along z
- tempx2l = tempx2l + potential_dot_dot_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
- b_tempx2l = b_tempx2l + b_potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
- bb_tempx2l = bb_tempx2l + b_potential_dot_dot_acoustic(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)
-
- if(assign_external_model) rhol_ac_global(iglob) = rhoext(i,j,ispec)
-
-! derivatives of potential
- accel_ac(1,iglob) = (tempx1l*xixl + tempx2l*gammaxl) / rhol_ac_global(iglob)
- accel_ac(2,iglob) = (tempx1l*xizl + tempx2l*gammazl) / rhol_ac_global(iglob)
- b_displ_ac(1,iglob) = (b_tempx1l*xixl + b_tempx2l*gammaxl) / rhol_ac_global(iglob)
- b_displ_ac(2,iglob) = (b_tempx1l*xizl + b_tempx2l*gammazl) / rhol_ac_global(iglob)
- b_accel_ac(1,iglob) = (bb_tempx1l*xixl + bb_tempx2l*gammaxl) / rhol_ac_global(iglob)
- b_accel_ac(2,iglob) = (bb_tempx1l*xizl + bb_tempx2l*gammazl) / rhol_ac_global(iglob)
-
- enddo !i = 1, NGLLX
- enddo !j = 1, NGLLZ
- endif
- enddo
-
- do ispec = 1,nspec
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- rho_ac_kl(i,j,ispec) = rho_ac_kl(i,j,ispec) - rhol_ac_global(iglob) * &
- dot_product(accel_ac(:,iglob),b_displ_ac(:,iglob)) * deltat
- kappa_ac_kl(i,j,ispec) = kappa_ac_kl(i,j,ispec) - kappal_ac_global(iglob) * &
- potential_dot_dot_acoustic(iglob)/kappal_ac_global(iglob) * &
- b_potential_dot_dot_acoustic(iglob)/kappal_ac_global(iglob)&
- * deltat
-!
- rhop_ac_kl(i,j,ispec) = rho_ac_kl(i,j,ispec) + kappa_ac_kl(i,j,ispec)
- alpha_ac_kl(i,j,ispec) = TWO * kappa_ac_kl(i,j,ispec)
- rhorho_ac_hessian_final1(i,j,ispec) = rhorho_ac_hessian_final1(i,j,ispec) + &
- dot_product(accel_ac(:,iglob),accel_ac(:,iglob)) * deltat
- rhorho_ac_hessian_final2(i,j,ispec) = rhorho_ac_hessian_final2(i,j,ispec) + &
- dot_product(accel_ac(:,iglob),b_accel_ac(:,iglob)) * deltat
- enddo
- enddo
- endif
- enddo
-
- endif !if(any_acoustic)
-
- if(any_elastic) then
-
- do ispec = 1, nspec
- if(elastic(ispec)) then
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- mul_global(iglob) = poroelastcoef(2,1,kmato(ispec))
- kappal_global(iglob) = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_global(iglob)/3._CUSTOM_REAL
- rhol_global(iglob) = density(1,kmato(ispec))
-
- rho_kl(i,j,ispec) = rho_kl(i,j,ispec) - rhol_global(iglob) * rho_k(iglob) * deltat
- mu_kl(i,j,ispec) = mu_kl(i,j,ispec) - TWO * mul_global(iglob) * mu_k(iglob) * deltat
- kappa_kl(i,j,ispec) = kappa_kl(i,j,ispec) - kappal_global(iglob) * kappa_k(iglob) * deltat
-!
- rhop_kl(i,j,ispec) = rho_kl(i,j,ispec) + kappa_kl(i,j,ispec) + mu_kl(i,j,ispec)
- beta_kl(i,j,ispec) = TWO * (mu_kl(i,j,ispec) - 4._CUSTOM_REAL * mul_global(iglob) &
- / (3._CUSTOM_REAL * kappal_global(iglob)) * kappa_kl(i,j,ispec))
- alpha_kl(i,j,ispec) = TWO * (1._CUSTOM_REAL + 4._CUSTOM_REAL * mul_global(iglob)/&
- (3._CUSTOM_REAL * kappal_global(iglob))) * kappa_kl(i,j,ispec)
- rhorho_el_hessian_final1(i,j,ispec) = rhorho_el_hessian_final1(i,j,ispec) + rhorho_el_hessian_temp1(iglob) * deltat
- rhorho_el_hessian_final2(i,j,ispec) = rhorho_el_hessian_final2(i,j,ispec) + rhorho_el_hessian_temp2(iglob) * deltat
-
- enddo
- enddo
- endif
- enddo
-
- endif !if(any_elastic)
-
- if(any_poroelastic) then
-
- do ispec = 1, nspec
- if(poroelastic(ispec)) then
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- phil_global(iglob) = porosity(kmato(ispec))
- tortl_global(iglob) = tortuosity(kmato(ispec))
- rhol_s_global(iglob) = density(1,kmato(ispec))
- rhol_f_global(iglob) = density(2,kmato(ispec))
- rhol_bar_global(iglob) = (1._CUSTOM_REAL - phil_global(iglob))*rhol_s_global(iglob) &
- + phil_global(iglob)*rhol_f_global(iglob)
- etal_f_global(iglob) = poroelastcoef(2,2,kmato(ispec))
- permlxx_global(iglob) = permeability(1,kmato(ispec))
- permlxz_global(iglob) = permeability(2,kmato(ispec))
- permlzz_global(iglob) = permeability(3,kmato(ispec))
- mulfr_global(iglob) = poroelastcoef(2,3,kmato(ispec))
-
- rhot_kl(i,j,ispec) = rhot_kl(i,j,ispec) - deltat * rhol_bar_global(iglob) * rhot_k(iglob)
- rhof_kl(i,j,ispec) = rhof_kl(i,j,ispec) - deltat * rhol_f_global(iglob) * rhof_k(iglob)
- sm_kl(i,j,ispec) = sm_kl(i,j,ispec) - deltat * rhol_f_global(iglob)*tortl_global(iglob)/phil_global(iglob) * sm_k(iglob)
-!at the moment works with constant permeability
- eta_kl(i,j,ispec) = eta_kl(i,j,ispec) - deltat * etal_f_global(iglob)/permlxx_global(iglob) * eta_k(iglob)
- B_kl(i,j,ispec) = B_kl(i,j,ispec) - deltat * B_k(iglob)
- C_kl(i,j,ispec) = C_kl(i,j,ispec) - deltat * C_k(iglob)
- M_kl(i,j,ispec) = M_kl(i,j,ispec) - deltat * M_k(iglob)
- mufr_kl(i,j,ispec) = mufr_kl(i,j,ispec) - TWO * deltat * mufr_k(iglob)
-! density kernels
- rholb = rhol_bar_global(iglob) - phil_global(iglob)*rhol_f_global(iglob)/tortl_global(iglob)
- rhob_kl(i,j,ispec) = rhot_kl(i,j,ispec) + B_kl(i,j,ispec) + mufr_kl(i,j,ispec)
- rhofb_kl(i,j,ispec) = rhof_kl(i,j,ispec) + C_kl(i,j,ispec) + M_kl(i,j,ispec) + sm_kl(i,j,ispec)
- Bb_kl(i,j,ispec) = B_kl(i,j,ispec)
- Cb_kl(i,j,ispec) = C_kl(i,j,ispec)
- Mb_kl(i,j,ispec) = M_kl(i,j,ispec)
- mufrb_kl(i,j,ispec) = mufr_kl(i,j,ispec)
- phi_kl(i,j,ispec) = - sm_kl(i,j,ispec) - M_kl(i,j,ispec)
-! wave speed kernels
- dd1 = (1._CUSTOM_REAL+rholb/rhol_f_global(iglob))*ratio**2 + 2._CUSTOM_REAL*ratio +&
- tortl_global(iglob)/phil_global(iglob)
- rhobb_kl(i,j,ispec) = rhob_kl(i,j,ispec) - &
- phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
- (cpIIsquare + (cpIsquare - cpIIsquare)*( (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1+&
- (rhol_bar_global(iglob)**2*ratio**2/rhol_f_global(iglob)**2*(phil_global(iglob)/tortl_global(iglob)*&
- ratio+1)*(phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*&
- (1+rhol_f_global(iglob)/rhol_bar_global(iglob))-1) )/dd1**2 )- FOUR_THIRDS*cssquare )*&
- Bb_kl(i,j,ispec) - &
- rhol_bar_global(iglob)*ratio**2/M_biot * (cpIsquare - cpIIsquare)* &
- (phil_global(iglob)/tortl_global(iglob)*ratio + 1._CUSTOM_REAL)**2/dd1**2*Mb_kl(i,j,ispec) + &
- rhol_bar_global(iglob)*ratio/C_biot * (cpIsquare - cpIIsquare)* (&
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
- phil_global(iglob)*ratio/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
- (1+rhol_bar_global(iglob)*ratio/rhol_f_global(iglob))/dd1**2)*Cb_kl(i,j,ispec)+ &
- phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
- rhofbb_kl(i,j,ispec) = rhofb_kl(i,j,ispec) + &
- phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
- (cpIIsquare + (cpIsquare - cpIIsquare)*( (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1+&
- (rhol_bar_global(iglob)**2*ratio**2/rhol_f_global(iglob)**2*(phil_global(iglob)/tortl_global(iglob)*&
- ratio+1)*(phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*&
- (1+rhol_f_global(iglob)/rhol_bar_global(iglob))-1) )/dd1**2 )- FOUR_THIRDS*cssquare )*&
- Bb_kl(i,j,ispec) + &
- rhol_bar_global(iglob)*ratio**2/M_biot * (cpIsquare - cpIIsquare)* &
- (phil_global(iglob)/tortl_global(iglob)*ratio + 1._CUSTOM_REAL)**2/dd1**2*Mb_kl(i,j,ispec) - &
- rhol_bar_global(iglob)*ratio/C_biot * (cpIsquare - cpIIsquare)* (&
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
- phil_global(iglob)*ratio/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
- (1+rhol_bar_global(iglob)*ratio/rhol_f_global(iglob))/dd1**2)*Cb_kl(i,j,ispec)- &
- phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
- phib_kl(i,j,ispec) = phi_kl(i,j,ispec) - &
- phil_global(iglob)*rhol_bar_global(iglob)/(tortl_global(iglob)*B_biot) * ( cpIsquare - rhol_f_global(iglob)/&
- rhol_bar_global(iglob)*cpIIsquare- &
- (cpIsquare-cpIIsquare)*( (TWO*ratio**2*phil_global(iglob)/tortl_global(iglob) + (1._CUSTOM_REAL+&
- rhol_f_global(iglob)/rhol_bar_global(iglob))*(TWO*ratio*phil_global(iglob)/tortl_global(iglob)+&
- 1._CUSTOM_REAL))/dd1 + (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)*&
- ratio/tortl_global(iglob)+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/&
- rhol_bar_global(iglob))-1._CUSTOM_REAL)*((1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-&
- TWO*phil_global(iglob)/tortl_global(iglob))*ratio**2+TWO*ratio)/dd1**2 ) - &
- FOUR_THIRDS*rhol_f_global(iglob)*cssquare/rhol_bar_global(iglob) )*Bb_kl(i,j,ispec) + &
- rhol_f_global(iglob)/M_biot * (cpIsquare-cpIIsquare)*(&
- TWO*ratio*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2*((1._CUSTOM_REAL+rhol_bar_global(iglob)/&
- rhol_f_global(iglob)-TWO*phil_global(iglob)/tortl_global(iglob))*ratio**2+TWO*ratio)/dd1**2&
- )*Mb_kl(i,j,ispec) + &
- phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*C_biot)*(cpIsquare-cpIIsquare)*ratio* (&
- (1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob)*ratio)/dd1 - &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/&
- rhol_f_global(iglob)*ratio)*((1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-TWO*&
- phil_global(iglob)/tortl_global(iglob))*ratio+TWO)/dd1**2&
- )*Cb_kl(i,j,ispec) -&
- phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
- cpI_kl(i,j,ispec) = 2._CUSTOM_REAL*cpIsquare/B_biot*rhol_bar_global(iglob)*( &
- 1._CUSTOM_REAL-phil_global(iglob)/tortl_global(iglob) + &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)/tortl_global(iglob)*&
- ratio+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-&
- 1._CUSTOM_REAL)/dd1 &
- )* Bb_kl(i,j,ispec) +&
- 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) *&
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2/dd1*Mb_kl(i,j,ispec)+&
- 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)/C_biot * &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/&
- rhol_f_global(iglob)*ratio)/dd1*Cb_kl(i,j,ispec)
- cpII_kl(i,j,ispec) = 2._CUSTOM_REAL*cpIIsquare*rhol_bar_global(iglob)/B_biot * (&
- phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*rhol_bar_global(iglob)) - &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)/tortl_global(iglob)*&
- ratio+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-&
- 1._CUSTOM_REAL)/dd1 ) * Bb_kl(i,j,ispec) +&
- 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) * (&
- 1._CUSTOM_REAL - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2/dd1 )*Mb_kl(i,j,ispec) + &
- 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)/C_biot * (&
- 1._CUSTOM_REAL - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+&
- rhol_bar_global(iglob)/rhol_f_global(iglob)*ratio)/dd1 )*Cb_kl(i,j,ispec)
- cs_kl(i,j,ispec) = - 8._CUSTOM_REAL/3._CUSTOM_REAL*cssquare*rhol_bar_global(iglob)/B_biot*(1._CUSTOM_REAL-&
- phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*rhol_bar_global(iglob)))*Bb_kl(i,j,ispec) + &
- 2._CUSTOM_REAL*(rhol_bar_global(iglob)-rhol_f_global(iglob)*phil_global(iglob)/tortl_global(iglob))/&
- mulfr_global(iglob)*cssquare*mufrb_kl(i,j,ispec)
- ratio_kl(i,j,ispec) = ratio*rhol_bar_global(iglob)*phil_global(iglob)/(tortl_global(iglob)*B_biot) * &
- (cpIsquare-cpIIsquare) * ( &
- phil_global(iglob)/tortl_global(iglob)*(2._CUSTOM_REAL*ratio+1._CUSTOM_REAL+rhol_f_global(iglob)/ &
- rhol_bar_global(iglob))/dd1 - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
- (phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*(&
- 1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-1._CUSTOM_REAL)*(2._CUSTOM_REAL*ratio*(&
- 1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob)) +&
- 2._CUSTOM_REAL)/dd1**2 )*Bb_kl(i,j,ispec) + &
- ratio*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot)*(cpIsquare-cpIIsquare) * &
- 2._CUSTOM_REAL*phil_global(iglob)/tortl_global(iglob) * (&
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2*((1._CUSTOM_REAL+rhol_bar_global(iglob)/&
- rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob))*ratio+1._CUSTOM_REAL)/dd1**2 )*Mb_kl(i,j,ispec) +&
- ratio*rhol_f_global(iglob)/C_biot*(cpIsquare-cpIIsquare) * (&
- (2._CUSTOM_REAL*phil_global(iglob)*rhol_bar_global(iglob)*ratio/(tortl_global(iglob)*rhol_f_global(iglob))+&
- phil_global(iglob)/tortl_global(iglob)+rhol_bar_global(iglob)/rhol_f_global(iglob))/dd1 - &
- 2._CUSTOM_REAL*phil_global(iglob)/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+&
- 1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)*ratio)*((1._CUSTOM_REAL+&
- rhol_bar_global(iglob)/rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob))*ratio+1._CUSTOM_REAL)/&
- dd1**2 )*Cb_kl(i,j,ispec)
-
- enddo
- enddo
- endif
- enddo
-
- endif ! if(any_poroelastic)
-
- endif ! if(SIMULATION_TYPE == 2)
-
-!
-!---- display results at given time steps
-!
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
-
-!
-! kernels output files
-!
-
- if(SIMULATION_TYPE == 2 .and. it == NSTEP) then
-
- if ( myrank == 0 ) then
- write(IOUT,*) 'Writing Kernels file'
- endif
-
- if(any_acoustic) then
- do ispec = 1, nspec
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- xx = coord(1,iglob)
- zz = coord(2,iglob)
- write(95,'(5e11.3)')xx,zz,rho_ac_kl(i,j,ispec),kappa_ac_kl(i,j,ispec)
- write(96,'(5e11.3)')rhorho_ac_hessian_final1(i,j,ispec), rhorho_ac_hessian_final2(i,j,ispec),&
- rhop_ac_kl(i,j,ispec),alpha_ac_kl(i,j,ispec)
- enddo
- enddo
- enddo
- close(95)
- close(96)
- endif
-
- if(any_elastic) then
- do ispec = 1, nspec
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- xx = coord(1,iglob)
- zz = coord(2,iglob)
- write(97,'(5e11.3)')xx,zz,rho_kl(i,j,ispec),kappa_kl(i,j,ispec),mu_kl(i,j,ispec)
- write(98,'(5e11.3)')xx,zz,rhop_kl(i,j,ispec),alpha_kl(i,j,ispec),beta_kl(i,j,ispec)
- !write(98,'(5e11.3)')rhorho_el_hessian_final1(i,j,ispec), rhorho_el_hessian_final2(i,j,ispec),&
- ! rhop_kl(i,j,ispec),alpha_kl(i,j,ispec),beta_kl(i,j,ispec)
- enddo
- enddo
- enddo
- close(97)
- close(98)
- endif
-
- if(any_poroelastic) then
- do ispec = 1, nspec
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- xx = coord(1,iglob)
- zz = coord(2,iglob)
- write(144,'(5e11.3)')xx,zz,mufr_kl(i,j,ispec),B_kl(i,j,ispec),C_kl(i,j,ispec)
- write(155,'(5e11.3)')xx,zz,M_kl(i,j,ispec),rhot_kl(i,j,ispec),rhof_kl(i,j,ispec)
- write(16,'(5e11.3)')xx,zz,sm_kl(i,j,ispec),eta_kl(i,j,ispec)
- write(17,'(5e11.3)')xx,zz,mufrb_kl(i,j,ispec),Bb_kl(i,j,ispec),Cb_kl(i,j,ispec)
- write(18,'(5e11.3)')xx,zz,Mb_kl(i,j,ispec),rhob_kl(i,j,ispec),rhofb_kl(i,j,ispec)
- write(19,'(5e11.3)')xx,zz,phi_kl(i,j,ispec),eta_kl(i,j,ispec)
- write(20,'(5e11.3)')xx,zz,cpI_kl(i,j,ispec),cpII_kl(i,j,ispec),cs_kl(i,j,ispec)
- write(21,'(5e11.3)')xx,zz,rhobb_kl(i,j,ispec),rhofbb_kl(i,j,ispec),ratio_kl(i,j,ispec)
- write(22,'(5e11.3)')xx,zz,phib_kl(i,j,ispec),eta_kl(i,j,ispec)
- enddo
- enddo
- enddo
- close(144)
- close(155)
- close(16)
- close(17)
- close(18)
- close(19)
- close(20)
- close(21)
- close(22)
- endif
-
- endif
-
-!
-!---- PostScript display
-!
- if(output_postscript_snapshot) then
-
- if (myrank == 0) write(IOUT,*) 'Writing PostScript file'
-
- if(imagetype == 1 .and. p_sv) then
-
- 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
- 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, &
- simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
- 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 .and. p_sv) then
-
- 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
- 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, &
- simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
- 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 .and. p_sv) then
-
- 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
- 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, &
- simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
- 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 == 4 .or. .not. p_sv) then
-
- if (myrank == 0) write(IOUT,*) 'cannot draw scalar pressure field or y-component field as a vector plot, skipping...'
-
- else
- call exit_MPI('wrong type for snapshots')
- endif
-
- if (myrank == 0 .and. imagetype /= 4 .and. p_sv) write(IOUT,*) 'PostScript file written'
-
- endif
-
-!
-!---- display color image
-!
- if(output_color_image) then
-
- if (myrank == 0) write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color,' for time step ',it
-
- if(imagetype == 1) then
-
- if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- else if(imagetype == 2) then
-
- if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- else if(imagetype == 3) then
-
- if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) 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,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- else if(imagetype == 4 .and. p_sv) then
-
- if (myrank == 0) write(IOUT,*) 'drawing image of pressure field...'
-
- 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,npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,e1,e11, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
-
- else if(imagetype == 4 .and. .not. p_sv) then
- call exit_MPI('cannot draw pressure field for SH (membrane) waves')
- else
- call exit_MPI('wrong type for snapshots')
- endif
-
- image_color_data(:,:) = 0.d0
-
- 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
- if(p_sv) then !P-SH waves, plot vertical component or pressure
- image_color_data(i,j) = vector_field_display(3,iglob_image_color(i,j))
- else !SH (membrane) waves, plot y-component
- image_color_data(i,j) = vector_field_display(2,iglob_image_color(i,j))
- endif
- enddo
-
-! assembling array image_color_data on process zero for color output
-#ifdef USE_MPI
- 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)
-
- do k = 1, nb_pixel_per_proc(iproc+1)
- 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
-
- 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
- if(p_sv) then !P-SH waves, plot vertical component or pressure
- data_pixel_send(k) = vector_field_display(3,iglob_image_color(i,j))
- else !SH (membrane) waves, plot y-component
- data_pixel_send(k) = vector_field_display(2,iglob_image_color(i,j))
- endif
- enddo
-
- call MPI_SEND(data_pixel_send(1),nb_pixel_loc,MPI_DOUBLE_PRECISION, 0, 43, MPI_COMM_WORLD, ier)
-
- endif
- endif
-
-#endif
-
- 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
-
-!---- save temporary or final seismograms
-! 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,p_sv)
-
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
-
- 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. SIMULATION_TYPE==1) .or. SIMULATION_TYPE ==2) then
- if(any_acoustic) then
- close(65)
- close(66)
- close(67)
- close(68)
- endif
- if(any_elastic) then
- close(35)
- close(36)
- close(37)
- close(38)
- endif
- if(any_poroelastic) then
- close(25)
- close(45)
- close(26)
- close(46)
- close(29)
- close(47)
- close(28)
- close(48)
- endif
- endif
-
-!
-!--- save last frame
-!
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_elastic) then
- if ( myrank == 0 ) then
- write(IOUT,*)
- write(IOUT,*) 'Saving elastic last frame...'
- write(IOUT,*)
- endif
- write(outputname,'(a,i6.6,a)') 'lastframe_elastic',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
- if(p_sv)then !P-SV waves
- do j=1,npoin
- write(55) displ_elastic(1,j), displ_elastic(3,j), &
- veloc_elastic(1,j), veloc_elastic(3,j), &
- accel_elastic(1,j), accel_elastic(3,j)
- enddo
- else !SH (membrane) waves
- do j=1,npoin
- write(55) displ_elastic(2,j), &
- veloc_elastic(2,j), &
- accel_elastic(2,j)
- enddo
- endif
- close(55)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_poroelastic) then
- if ( myrank == 0 ) then
- write(IOUT,*)
- write(IOUT,*) 'Saving poroelastic last frame...'
- write(IOUT,*)
- endif
- write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
- write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_w',myrank,'.bin'
- open(unit=56,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
- do j=1,npoin
- write(55) (displs_poroelastic(i,j), i=1,NDIM), &
- (velocs_poroelastic(i,j), i=1,NDIM), &
- (accels_poroelastic(i,j), i=1,NDIM)
- write(56) (displw_poroelastic(i,j), i=1,NDIM), &
- (velocw_poroelastic(i,j), i=1,NDIM), &
- (accelw_poroelastic(i,j), i=1,NDIM)
- enddo
- close(55)
- close(56)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_acoustic) then
- if ( myrank == 0 ) then
- write(IOUT,*)
- write(IOUT,*) 'Saving acoustic last frame...'
- write(IOUT,*)
- endif
- write(outputname,'(a,i6.6,a)') 'lastframe_acoustic',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
- do j=1,npoin
- write(55) potential_acoustic(j),&
- potential_dot_acoustic(j),&
- potential_dot_dot_acoustic(j)
- enddo
- 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 .and. myrank == 0) then
- close(IOUT_ENERGY)
- open(unit=IOUT_ENERGY,file='plotenergy',status='unknown')
- write(IOUT_ENERGY,*) 'set term postscript landscape color solid "Helvetica" 22'
- write(IOUT_ENERGY,*) 'set output "energy.ps"'
- write(IOUT_ENERGY,*) 'set xlabel "Time (s)"'
- write(IOUT_ENERGY,*) 'set ylabel "Energy (J)"'
- write(IOUT_ENERGY,*) 'plot "energy.gnu" us 1:4 t ''Total Energy'' w l 1, "energy.gnu" us 1:3 t ''Potential Energy'' w l 2'
- close(IOUT_ENERGY)
- endif
-
- if (.not. any_poroelastic) then
-open(unit=1001,file='DATA/model_velocity.dat_output',status='unknown')
- if ( .NOT. assign_external_model) then
-allocate(rho_local(ngllx,ngllz,nspec)); rho_local=0.
-allocate(vp_local(ngllx,ngllz,nspec)); vp_local=0.
-allocate(vs_local(ngllx,ngllz,nspec)); vs_local=0.
-!! write(1001,*) npoin
-!! do iglob = 1,npoin
-!! write(1001,*) coord(1,iglob),coord(2,iglob),rho_global(iglob),vp_global(iglob),vs_global(iglob)
-!! end do
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- rho_local(i,j,ispec) = density(1,kmato(ispec))
- vp_local(i,j,ispec) = sqrt(poroelastcoef(3,1,kmato(ispec))/density(1,kmato(ispec)))
- vs_local(i,j,ispec) = sqrt(poroelastcoef(2,1,kmato(ispec))/density(1,kmato(ispec)))
- write(1001,'(I10, 5F13.4)') iglob, coord(1,iglob),coord(2,iglob),&
- rho_local(i,j,ispec),vp_local(i,j,ispec),vs_local(i,j,ispec)
- end do
- end do
- end do
- else
-!! write(1001,*) npoin
-!! do iglob = 1,npoin
-!! write(1001,*) coord(1,iglob),coord(2,iglob),rhoext_global(iglob),vpext_global(iglob),vsext_global(iglob)
-!! end do
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- write(1001,'(I10,5F13.4)') iglob, coord(1,iglob),coord(2,iglob),&
- rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec)
- end do
- end do
- end do
- endif
-close(1001)
- endif
-
-! print exit banner
- if (myrank == 0) call datim(simulation_title)
-
-!
-!---- close output file
-!
- if(IOUT /= ISTANDARD_OUTPUT) close(IOUT)
-
-!
-!---- end MPI
-!
-#ifdef USE_MPI
- call MPI_FINALIZE(ier)
-#endif
-
-!
-!---- formats
-!
-
- 400 format(/1x,41('=')/,' = T i m e e v o l u t i o n l o o p ='/1x,41('=')/)
-
- end program specfem2D
-
Deleted: seismo/2D/SPECFEM2D/trunk/src/spline_routines.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/spline_routines.f90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/spline_routines.f90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,174 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! compute spline coefficients
-
- subroutine spline_construction(xpoint,ypoint,npoint,tangent_first_point,tangent_last_point,spline_coefficients)
-
- implicit none
-
-! tangent to the spline imposed at the first and last points
- double precision, intent(in) :: tangent_first_point,tangent_last_point
-
-! number of input points and coordinates of the input points
- integer, intent(in) :: npoint
- double precision, dimension(npoint), intent(in) :: xpoint,ypoint
-
-! spline coefficients output by the routine
- double precision, dimension(npoint), intent(out) :: spline_coefficients
-
- integer :: i
-
- double precision, dimension(:), allocatable :: temporary_array
-
- allocate(temporary_array(npoint))
-
- spline_coefficients(1) = - 1.d0 / 2.d0
-
- temporary_array(1) = (3.d0/(xpoint(2)-xpoint(1)))*((ypoint(2)-ypoint(1))/(xpoint(2)-xpoint(1))-tangent_first_point)
-
- do i = 2,npoint-1
-
- spline_coefficients(i) = ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))-1.d0) &
- / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
-
- temporary_array(i) = (6.d0*((ypoint(i+1)-ypoint(i))/(xpoint(i+1)-xpoint(i)) &
- - (ypoint(i)-ypoint(i-1))/(xpoint(i)-xpoint(i-1)))/(xpoint(i+1)-xpoint(i-1)) &
- - (xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*temporary_array(i-1)) &
- / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
-
- enddo
-
- spline_coefficients(npoint) = ((3.d0/(xpoint(npoint)-xpoint(npoint-1))) &
- * (tangent_last_point-(ypoint(npoint)-ypoint(npoint-1))/(xpoint(npoint)-xpoint(npoint-1))) &
- - 1.d0/2.d0*temporary_array(npoint-1))/(1.d0/2.d0*spline_coefficients(npoint-1)+1.d0)
-
- do i = npoint-1,1,-1
- spline_coefficients(i) = spline_coefficients(i)*spline_coefficients(i+1) + temporary_array(i)
- enddo
-
- deallocate(temporary_array)
-
- end subroutine spline_construction
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! evaluate a spline
-
- subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate_spline,y_spline_obtained)
-
- implicit none
-
-! number of input points and coordinates of the input points
- integer, intent(in) :: npoint
- double precision, dimension(npoint), intent(in) :: xpoint,ypoint
-
-! spline coefficients to use
- double precision, dimension(npoint), intent(in) :: spline_coefficients
-
-! abscissa at which we need to evaluate the value of the spline
- double precision, intent(in):: x_evaluate_spline
-
-! ordinate evaluated by the routine for the spline at this abscissa
- double precision, intent(out):: y_spline_obtained
-
- integer :: index_loop,index_lower,index_higher
-
- double precision :: coef1,coef2
-
-! initialize to the whole interval
- index_lower = 1
- index_higher = npoint
-
-! determine the right interval to use, by dichotomy
- do while (index_higher - index_lower > 1)
-! compute the middle of the interval
- index_loop = (index_higher + index_lower) / 2
- if(xpoint(index_loop) > x_evaluate_spline) then
- index_higher = index_loop
- else
- index_lower = index_loop
- endif
- enddo
-
-! test that the interval obtained does not have a size of zero
-! (this could happen for instance in the case of duplicates in the input list of points)
- if(xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation'
-
- coef1 = (xpoint(index_higher) - x_evaluate_spline) / (xpoint(index_higher) - xpoint(index_lower))
- coef2 = (x_evaluate_spline - xpoint(index_lower)) / (xpoint(index_higher) - xpoint(index_lower))
-
- y_spline_obtained = coef1*ypoint(index_lower) + coef2*ypoint(index_higher) + &
- ((coef1**3 - coef1)*spline_coefficients(index_lower) + &
- (coef2**3 - coef2)*spline_coefficients(index_higher))*((xpoint(index_higher) - xpoint(index_lower))**2)/6.d0
-
- end subroutine spline_evaluation
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-!--- spline to describe the interfaces
-
-double precision function value_spline(x,xinterface,zinterface,coefs_interface,npoints_interface)
-
- implicit none
-
- integer npoints_interface
- double precision x,xp
- double precision, dimension(npoints_interface) :: xinterface,zinterface,coefs_interface
-
- value_spline = 0.d0
-
- xp = x
-
- ! assign the value on the edge if point is outside the model
- if(xp < xinterface(1)) xp = xinterface(1)
- if(xp > xinterface(npoints_interface)) xp = xinterface(npoints_interface)
-
- call spline_evaluation(xinterface,zinterface,coefs_interface,npoints_interface,xp,value_spline)
-
-end function value_spline
Deleted: seismo/2D/SPECFEM2D/trunk/src/write_seismograms.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/write_seismograms.F90 2011-03-01 20:42:00 UTC (rev 17997)
+++ seismo/2D/SPECFEM2D/trunk/src/write_seismograms.F90 2011-03-01 20:59:44 UTC (rev 17998)
@@ -1,396 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! 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 princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! write seismograms to text files
-
- 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,p_sv &
- )
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: nrec,NSTEP,seismotype
- integer :: NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current
- double precision :: t0,deltat
-
- logical :: p_sv
-
- integer, intent(in) :: nrecloc,myrank
- integer, dimension(nrec),intent(in) :: which_proc_receiver
-
- double precision, dimension(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc), intent(in) :: sisux,sisuz,siscurl
-
- double precision st_xval(nrec)
-
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- integer irec,length_station_name,length_network_name,iorientation,isample,number_of_components
-
- character(len=4) chn
- character(len=1) component
- character(len=150) sisname
-
-! to write seismograms in single precision SEP and double precision binary format
- double precision, dimension(:,:), allocatable :: buffer_binary
-
-! scaling factor for Seismic Unix xsu dislay
- double precision, parameter :: FACTORXSU = 1.d0
-
-
- integer :: irecloc
-
-#ifdef USE_MPI
- integer :: ierror
- integer, dimension(MPI_STATUS_SIZE) :: status
-#endif
-
-!----
-
-! write seismograms in ASCII format
-
-! save displacement, velocity, acceleration or pressure
- if(seismotype == 1) then
- component = 'd'
- else if(seismotype == 2) then
- component = 'v'
- else if(seismotype == 3) then
- component = 'a'
- else if(seismotype == 4 .or. seismotype == 6) 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 pressures or SH (membrane) waves
- if(seismotype == 4 .or. seismotype == 6 .or. .not. p_sv) then
- number_of_components = 1
- else if(seismotype == 5) then
- number_of_components = NDIM+1
- else
- number_of_components = NDIM
- endif
-
- allocate(buffer_binary(NTSTEP_BETWEEN_OUTPUT_SEISMO,number_of_components))
-
-
- if ( myrank == 0 .and. seismo_offset == 0 ) then
-
-! delete the old files
- open(unit=11,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown')
- close(11,status='delete')
-
- 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 == 6) then
- open(unit=12,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown',access='direct',recl=4)
- elseif(.not.p_sv) then
- open(unit=12,file='OUTPUT_FILES/Uy_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 == 6) then
- open(unit=13,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown',access='direct',recl=8)
- elseif(.not.p_sv) then
- open(unit=13,file='OUTPUT_FILES/Uz_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 /= 6 .and. p_sv) 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
-
-
- irecloc = 0
- do irec = 1,nrec
-
- if ( myrank == 0 ) then
-
- if ( which_proc_receiver(irec) == myrank ) then
- irecloc = irecloc + 1
- 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
- else
- call MPI_RECV(buffer_binary(1,1),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
- which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
- if ( number_of_components == 2 ) 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)
- 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
- end if
-
-! write trace
- do iorientation = 1,number_of_components
-
- if(iorientation == 1) then
- 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 == 6) chn = 'PRE'
- ! in case of SH (membrane) waves, use different abbreviation
- if(.not.p_sv) chn = 'BHY'
-
- ! create the name of the seismogram file for each slice
- ! file name includes the name of the station, the network and the component
- length_station_name = len_trim(station_name(irec))
- length_network_name = len_trim(network_name(irec))
-
- ! check that length conforms to standard
- if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) then
- call exit_MPI('wrong length of station name')
- end if
- if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) then
- call exit_MPI('wrong length of network name')
- end if
-
- write(sisname,"('OUTPUT_FILES/',a,'.',a,'.',a3,'.sem',a1)") station_name(irec)(1:length_station_name),&
- network_name(irec)(1:length_network_name),chn,component
-
- ! save seismograms in text format with no subsampling.
- ! Because we do not subsample the output, this can result in large files
- ! if the simulation uses many time steps. However, subsampling the output
- ! here would result in a loss of accuracy when one later convolves
- ! the results with the source time function
- if ( seismo_offset == 0 ) then
- open(unit=11,file=sisname(1:len_trim(sisname)),status='unknown')
- close(11,status='delete')
- endif
- open(unit=11,file=sisname(1:len_trim(sisname)),status='unknown',position='append')
-
- ! make sure we never write more than the maximum number of time steps
- ! subtract offset of the source to make sure travel time is correct
- do isample = 1,seismo_current
- if(iorientation == 1) then
- write(11,*) sngl(dble(seismo_offset+isample-1)*deltat - t0),' ', &
- sngl(buffer_binary(isample,iorientation))
- else
- write(11,*) sngl(dble(seismo_offset+isample-1)*deltat - t0),' ', &
- sngl(buffer_binary(isample,iorientation))
- endif
- enddo
-
- close(11)
- end do
-
-! write binary seismogram
- 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 /= 6 .and. p_sv) 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
-
- else
- 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
- 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
-
- end if
-
- enddo
-
- close(12)
- close(13)
- if ( seismotype /= 4 .and. seismotype /= 6 .and. p_sv) then
- close(14)
- close(15)
- end if
- if ( seismotype == 5 ) then
- close(16)
- close(17)
- end if
-
-!----
-
- deallocate(buffer_binary)
-
-!----
- if ( myrank == 0 ) then
-
-! ligne de recepteurs pour Xsu
- open(unit=11,file='OUTPUT_FILES/receiver_line_Xsu_XWindow',status='unknown')
-
-! subtract t0 from seismograms to get correct zero time
- write(11,110) FACTORXSU,NSTEP,deltat,-t0,nrec
-
- do irec=1,nrec
- ! this format statement might now work for larger meshes
- !write(11,"(f12.5)") st_xval(irec)
- write(11,*) st_xval(irec)
- if(irec < nrec) write(11,*) ','
- enddo
-
- if(seismotype == 1) then
- write(11,*) '@title="Ux at displacement@component"@<@Ux_file_single.bin'
- else if(seismotype == 2) then
- write(11,*) '@title="Ux at velocity@component"@<@Ux_file_single.bin'
- else
- write(11,*) '@title="Ux at acceleration@component"@<@Ux_file_single.bin'
- endif
-
- close(11)
-
-! script de visualisation
- open(unit=11,file='OUTPUT_FILES/show_receiver_line_Xsu',status='unknown')
- write(11,"('#!/bin/csh')")
- write(11,*)
- write(11,*) '/bin/rm -f tempfile receiver_line_Xsu_postscript'
- write(11,*) '# concatener toutes les lignes'
- write(11,*) 'tr -d ''\012'' <receiver_line_Xsu_XWindow >tempfile'
- write(11,*) '# remettre fin de ligne'
- write(11,*) 'echo " " >> tempfile'
- write(11,*) '# supprimer espaces, changer arobas, dupliquer'
- write(11,120)
- write(11,*) '/bin/rm -f tempfile'
- write(11,*) '# copier fichier pour sortie postscript'
- write(11,130)
- write(11,*) '/bin/rm -f tempfile'
- write(11,*) 'echo ''rm -f uxpoly.ps uzpoly.ps'' > tempfile'
- write(11,*) 'cat tempfile receiver_line_Xsu_postscript > tempfile2'
- write(11,*) '/bin/mv -f tempfile2 receiver_line_Xsu_postscript'
- write(11,*) '/bin/rm -f tempfile'
- write(11,*) '# executer commande xsu'
- write(11,*) 'sh receiver_line_Xsu_XWindow'
- write(11,*) '/bin/rm -f tempfile tempfile2'
- close(11)
-
-end if
-
-! formats
- 110 format('xwigb at xcur=',f8.2,'@n1=',i6,'@d1=',f15.8,'@f1=',f15.8,'@label1="Time@(s)"@label2="x@(m)"@n2=',i6,'@x2=')
-
- 120 format('sed -e ''1,$s/ //g'' -e ''1,$s/@/ /g'' -e ''1,1p'' -e ''$,$s/Ux/Uz/g'' <tempfile > receiver_line_Xsu_XWindow')
-
- 130 format('sed -e ''1,$s/xwigb/pswigp/g'' ', &
- '-e ''1,$s/Ux_file_single.bin/Ux_file_single.bin > uxpoly.ps/g'' ', &
- '-e ''1,$s/Uz_file_single.bin/Uz_file_single.bin > uzpoly.ps/g'' receiver_line_Xsu_XWindow > receiver_line_Xsu_postscript')
-
- end subroutine write_seismograms
-
More information about the CIG-COMMITS
mailing list