[cig-commits] r16315 - in seismo/3D/SPECFEM3D_SESAME/trunk: . EXAMPLES/homogeneous_halfspace EXAMPLES/homogeneous_halfspace/REF_SEIS EXAMPLES/layered_halfspace EXAMPLES/layered_halfspace/REF_SEIS EXAMPLES/waterlayered_halfspace UTILS UTILS/Visualization/mesh2vtu UTILS/cut_velocity UTILS/lib decompose_mesh_SCOTCH decompose_mesh_SCOTCH/OUTPUT_FILES
danielpeter at geodynamics.org
danielpeter at geodynamics.org
Mon Feb 22 18:41:08 PST 2010
Author: danielpeter
Date: 2010-02-22 18:41:02 -0800 (Mon, 22 Feb 2010)
New Revision: 16315
Added:
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README_kernel
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/STATIONS_ADJOINT
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/run_boundary_definition.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/run_cubit2specfem3d.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/slices.txt
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cut_velocity/Makefile
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/Makefile
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/drw_ascfile.h
seismo/3D/SPECFEM3D_SESAME/trunk/compute_add_sources_acoustic.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_add_sources_elastic.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_coupling_acoustic_el.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_coupling_elastic_ac.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic_pot.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic_Dev.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic_noDev.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_interpolated_dva.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_stacey_acoustic.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_stacey_elastic.f90
seismo/3D/SPECFEM3D_SESAME/trunk/param_reader.c
seismo/3D/SPECFEM3D_SESAME/trunk/save_adjoint_kernels.f90
seismo/3D/SPECFEM3D_SESAME/trunk/write_movie_output.f90
Removed:
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90
Modified:
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/Par_file
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/REF_SEIS/X1-50.BHZ.gnuplot
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/cubit2specfem3d.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8-nodoubling.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/REF_SEIS/X10-50.BHZ.gnuplot
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/cubit2specfem3d.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/CMTSOLUTION
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/Par_file
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/cubit2specfem3d.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8-nodoubling.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_vertical.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_only-nodoubling.py
seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/mesh2vtu/Makefile
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cut_velocity/cut_velocity.f90
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/go_mesher_solver_lsf_basin.kernel
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/rw_ascfile_c.c
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/rw_ascfile_f.f90
seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90
seismo/3D/SPECFEM3D_SESAME/trunk/calc_jacobian.f90
seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90
seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90
seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90
seismo/3D/SPECFEM3D_SESAME/trunk/comp_source_time_function.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_arrays_source.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_boundary_kernel.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90
seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in
seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90
seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90
seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/Makefile
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/OUTPUT_FILES/cubit2specfem3d.py
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90
seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90
seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/flags.guess
seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_cmt.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_global.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_value_parameters.f90
seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
seismo/3D/SPECFEM3D_SESAME/trunk/locate_receivers.f90
seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90
seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90
seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_parameter_file.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_value_parameters.f90
seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90
seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90
seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
seismo/3D/SPECFEM3D_SESAME/trunk/write_PNM_GIF_data.f90
seismo/3D/SPECFEM3D_SESAME/trunk/write_c_binary.c
seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90
Log:
added adjoint capabilities, working copy - not validated yet
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/Par_file
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/Par_file 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/Par_file 2010-02-23 02:41:02 UTC (rev 16315)
@@ -12,8 +12,8 @@
NPROC_ETA = 2
# time step parameters
-NSTEP = 5000
-DT = 0.0065d0
+NSTEP = 1000
+DT = 0.05d0
# parameters describing the model
OCEANS = .false.
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README 2010-02-23 02:41:02 UTC (rev 16315)
@@ -2,53 +2,130 @@
README
----------------------------------------------------------------------
-
step-by-step tutorial:
-1. create mesh:
+1. configure package:
+
+ - From the SPECFEM3D_SESAME root directory /SPECFEM3D_SESAME/
+ configure the package, e.g. using intel's ifort compiler:
+ > cd /SPECFEM3D_SESAME
+ > ./configure F90=ifort
- - run cubit GUI:
- > claro
+ If successful, this will generate the files:
+ Makefile, constants.h, and precision.h, among others
+
+ - make a directory for the databases
+ > mkdir DATABASES_MPI
+
+
+2. create mesh:
+
+ - change to the examples directory /SPECFEM3D_SESAME/EXAMPLES/homogeneous_halfspace:
+ > cd EXAMPLES/homogeneous_halfspace
+
+ - open the cubit GUI:
+ > claro (or cubit)
then run meshing script:
claro -> Menu "Tools" -> "Play Journal File" ... and select file: "block_mesh.py"
- this creates all the mesh files in subdirectory MESH/
+ if everything goes fine, this creates all the mesh files in a subdirectory MESH/:
+ MESH/absorbing_surface_file_bottom
+ MESH/absorbing_surface_file_xmax
+ MESH/absorbing_surface_file_xmin
+ MESH/absorbing_surface_file_ymax
+ MESH/absorbing_surface_file_ymin
+ MESH/free_surface_file
+ MESH/materials_file
+ MESH/mesh_file
+ MESH/nodes_coords_file
+ MESH/nummaterial_velocity_file
-2. decompose mesh files:
+3. decompose mesh files:
- - run decomposer in directory decompose_mesh_SCOTCH/:
- (example assumes 4 partitions with mesh files in OUTPUT_FILES/)
-
- > make
- > ./xdecompose_mesh_SCOTCH 4 ../EXAMPLES/homogeneous_halfspace/MESH/ ../DATABASES_MPI/
+ - run decomposer in directory /SPECFEM3D_SESAME/decompose_mesh_SCOTCH/:
+ (example assumes 4 partitions with mesh files in ../EXAMPLES/homogeneous_halfspace/MESH/)
+ > cd /SPECFEM3D_SESAME/decompose_mesh_SCOTCH
+ > make
+
+ NOTE 1: check that the two scotch libraries are properly specified in Makefile
+ NOTE 2: compile with the same compiler (ifort or gfortran) used
+ for the SCOTCH libraries
+
+ > ./xdecompose_mesh_SCOTCH 4 ../EXAMPLES/homogeneous_halfspace/MESH/ ../DATABASES_MPI/
- which creates mesh partitions "proc0000***_Database" in directory "DATABASES_MPI".
- you can then specify "DATABASES_MPI" in "Par_file" for your "LOCAL_PATH"
+ which creates mesh partitions "proc0000***_Database" in directory DATABASES_MPI/.
+ (you can then specify "DATABASES_MPI" in "Par_file" for your "LOCAL_PATH")
-3. generate databases:
+4. generate databases:
- - copy Par_file, CMTSOLUTION & STATIONS files provided in this examples directory to DATA/ directory in
- the SPECFEM3D_SESAME root directory
+ - copy three files -- Par_file, CMTSOLUTION, STATIONS -- from
+ /SPECFEM3D_SESAME/EXAMPLES/homogeneous_halfspace/ to /SPECFEM3D_SESAME/DATA/
- - compile generate_databases:
- > make xgenerate_databases
+ - compile generate_databases from /SPECFEM3D_SESAME/ :
+ > cd /SPECFEM3D_SESAME
+ > make xgenerate_databases
- - submit job script:
- > qsub go_generate_database_pbs.sesame.bash
-
-4. run simulation:
+ - submit job script
+ > qsub go_generate_database_pbs.sesame.bash
- - compile specfem3D:
- > make xspecfem3D
+ NOTE: this script will need to be tailored to your cluster, e.g.,
+ > bsub < go_generate_database_lsf.sesame.bash
+
+ this will create binary mesh files, e.g. "proc000***_external_mesh.bin"
+ in directory DATABASES_MPI/.
+
+
+5. run simulation:
+
+ - compile specfem3D:
+ > make xspecfem3D
- - submit job script:
- > qsub go_solver_pbs.sesame.bash
+ - submit job script:
+ > qsub go_solver_pbs.sesame.bash
+ NOTE 1: this script will need to be tailored to your cluster
+ NOTE 2: the simulation runs on 4 cores and should take about 15 minutes,
+ and you can track the progress with the timestamp files
+ NOTE 3: you should have 672 x 3 (semd,semv,sema) seismograms in OUTPUT_FILES
-seismogram outputs:
- Reference solutions can be found in subdirectory REF_SEIS/
-
\ No newline at end of file
+6. check with 6 reference seismograms in
+ /SPECFEM3D_SESAME/EXAMPLES/homogeneous_halfspace/REF_SEIS/
+
+ - execute gnuplot script
+ > cd /SPECFEM3D_SESAME/EXAMPLES/homogeneous_halfspace/REF_SEIS
+ > gnuplot
+
+ gnuplot> load "X1-50.BHZ.gnuplot"
+
+ You should see a figure in a render window.
+ Writing the figure to a file may depend on your gnuplot settings.
+ One example to generate a postscript is shown below:
+
+ gnuplot> load "X1-50.BHZ.gnuplot"
+ gnuplot> set term postscript color solid
+ Terminal type set to 'postscript'
+ Options are 'landscape noenhanced color colortext \
+ solid dashlength 1.0 linewidth 1.0 defaultplex \
+ palfuncparam 2000,0.003 \
+ butt "Helvetica" 14'
+ gnuplot> set output 'my.ps'
+ gnuplot> replot
+ gnuplot> quit
+
+
+7. plot your output seismograms in /SPECFEM3D_SESAME/OUTPUT_FILES/
+
+ - copy gnuplot script X1-50.BHZ.gnuplot to local directory:
+ > cp /SPECFEM3D_SESAME/EXAMPLES/homogeneous_halfspace/REF_SEIS/X1-50.BHZ.gnuplot /SPECFEM3D_SESAME/OUTPUT_FILES
+
+ - execute same commands as above
+
+ - you should see the same image as generated from the reference seismograms,
+ but the record length is 25 s (instead of 42 s)
+
+===========================================================
+
Added: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README_kernel
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README_kernel (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/README_kernel 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,108 @@
+----------------------------------------------------------------------
+README - single travel-time adjoint kernel
+----------------------------------------------------------------------
+
+note: make yourself familiar with how to run a forward simulation.
+ a detailed step-by-step tutorial is given in the file
+ /SPECFEM3D_SESAME/EXAMPLES/homogeneous_halfspace/README
+
+
+step-by-step kernel tutorial:
+
+
+1. run forward simulation with saving wavefields:
+
+ - assuming that you have configured and setup the root directory
+ /SPECFEM3D_SESAME as described in the step-by-step tutorial described
+ in the file /SPECFEM3D_SESAME/EXAMPLES/homogeneous_halfspace/README,
+ update the Par_file:
+
+ > cd /SPECFEM3D_SESAME
+ > ./UTILS/change_simulation_type.pl -F
+
+ or change manually in /SPECFEM3D_SESAME/DATA/Par_file:
+ # forward or adjoint simulation
+ SIMULATION_TYPE = 1
+ SAVE_FORWARD = .true.
+
+ - run the forward simulation, submitting the job script:
+ > qsub go_solver_pbs.sesame.bash
+
+ you should have now the necessary seismograms in directory OUTPUT_FILES/:
+ ...
+ OUTPUT_FILES/X20.BHE.semd
+ OUTPUT_FILES/X20.BHN.semd
+ OUTPUT_FILES/X20.BHZ.semd
+ ...
+
+
+2. create adjoint source files:
+
+ - compile the utility xcut_velocity:
+ > cd /SPECFEM3D_SEAME/UTILS/cut_velocity
+ > make
+
+ - specify which receiver station becomes an adjoint source,
+ e.g. using the seismograms from station 20, and create the
+ corresponding adjoint source files:
+ > cd /SPECFEM3D_SESAME
+ > ./UTILS/cut_velocity/xcut_velocity 15. 21. 0 OUTPUT_FILES/X20.DB.BH*.semd
+
+ - make designated directory for adjoint sources:
+ > mkdir SEM/
+ > mv OUTPUT_FILES/*.adj SEM/
+ > cd SEM/
+ > rename .semd.adj .adj *.adj
+
+ this should create the files:
+ SEM/X20.DB.BHE.adj
+ SEM/X20.DB.BHN.adj
+ SEM/X20.DB.BHZ.adj
+
+ - setup adjoint stations file STATIONS_ADJOINT containing the receiver stations locations
+ which will have adjoint source files in SEM/:
+ > cd /SPECFEM3D_SESAME
+ > cp EXAMPLES/homogeneous_halfspace/STATIONS_ADJOINT DATA/
+
+
+3. run adjoint simulation with restored backward wavefields:
+
+ - update the Par_file:
+ > cd /SPECFEM3D_SESAME
+ > ./UTILS/change_simulation_type.pl -b
+
+ or change manually in /SPECFEM3D_SESAME/DATA/Par_file:
+ # forward or adjoint simulation
+ SIMULATION_TYPE = 3
+ SAVE_FORWARD = .false.
+
+
+ - run the backward simulation, submitting the job script:
+ > qsub go_solver_pbs.sesame.bash
+
+
+ this will create adjoint kernel files in directory DATABASES_MPI/
+ according to travel-time kernels as e.g. defined in Tromp et al. (2005) :
+ DATABASES_MPI/proc000***_alpha_kernel.bin
+ DATABASES_MPI/proc000***_beta_kernel.bin
+ DATABASES_MPI/proc000***_kappa_kernel.bin
+ DATABASES_MPI/proc000***_mu_kernel.bin
+ DATABASES_MPI/proc000***_rho_kernel.bin
+ DATABASES_MPI/proc000***_rhop_kernel.bin
+
+
+ - visualize with Paraview, e.g. :
+
+ > ./xcombine_vol_data slices.txt kappa_kernel DATABASES_MPI/ OUTPUT_FILES/ 1
+
+ where slices.txt contains numbers from 0 to 3 to include all 4 processor partitions
+
+ > mesh2vtu.pl -i OUTPUT_FILES/kappa_kernel.mesh -o OUTPUT_FILES/kappa_kernel.vtu
+
+ which creates the *.vtu file: Paraview -> Menu File -> Open ...
+ (and choose the kappa_kernel.vtu)
+
+
+
+
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/REF_SEIS/X1-50.BHZ.gnuplot
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/REF_SEIS/X1-50.BHZ.gnuplot 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/REF_SEIS/X1-50.BHZ.gnuplot 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,149 +1,8 @@
#!/usr/local/bin/gnuplot -persist
#
#
-# G N U P L O T
-# Version 4.3 patchlevel 0
-# last modified February 2008
-# System: Darwin 9.8.0
-#
-# Copyright (C) 1986 - 1993, 1998, 2004, 2007, 2008
-# Thomas Williams, Colin Kelley and many others
-#
-# Type `help` to access the on-line reference manual.
-# The gnuplot FAQ is available from
-# http://www.gnuplot.info/faq/
-#
-# Send comments and help requests to <gnuplot-beta at lists.sourceforge.net>
-# Send bug reports and suggestions to <gnuplot-beta at lists.sourceforge.net>
-#
-# set terminal aqua 0 title "Figure 0" size 846 594 font "Times-Roman,14" noenhanced solid
-# set output
-unset clip points
-set clip one
-unset clip two
-set bar 1.000000 front
-set border 31 front linetype -1 linewidth 1.000
-set xdata
-set ydata
-set zdata
-set x2data
-set y2data
-set timefmt x "%d/%m/%y,%H:%M"
-set timefmt y "%d/%m/%y,%H:%M"
-set timefmt z "%d/%m/%y,%H:%M"
-set timefmt x2 "%d/%m/%y,%H:%M"
-set timefmt y2 "%d/%m/%y,%H:%M"
-set timefmt cb "%d/%m/%y,%H:%M"
-set boxwidth
-set style fill empty border
-set style rectangle back fc lt -3 fillstyle solid 1.00 border -1
-set dummy x,y
-set format x "% g"
-set format y "% g"
-set format x2 "% g"
-set format y2 "% g"
-set format z "% g"
-set format cb "% g"
-set angles radians
-unset grid
-set key title ""
-set key inside right top vertical Right noreverse enhanced autotitles nobox
-set key noinvert samplen 4 spacing 1 width 0 height 0
-unset label
-unset arrow
-set style increment default
-unset style line
-unset style arrow
-set style histogram clustered gap 2 title offset character 0, 0, 0
-unset logscale
-set offsets 0, 0, 0, 0
-set pointsize 1
-set encoding default
-unset polar
-unset parametric
-unset decimalsign
-set view 60, 30, 1, 1
-set samples 100, 100
-set isosamples 10, 10
-set surface
-unset contour
-set clabel '%8.3g'
-set mapping cartesian
-set datafile separator whitespace
-unset hidden3d
-set cntrparam order 4
-set cntrparam linear
-set cntrparam levels auto 5
-set cntrparam points 5
-set size ratio 0 1,1
-set origin 0,0
-set style data points
-set style function lines
-set xzeroaxis linetype -2 linewidth 1.000
-set yzeroaxis linetype -2 linewidth 1.000
-set zzeroaxis linetype -2 linewidth 1.000
-set x2zeroaxis linetype -2 linewidth 1.000
-set y2zeroaxis linetype -2 linewidth 1.000
-set ticslevel 0.5
-set mxtics default
-set mytics default
-set mztics default
-set mx2tics default
-set my2tics default
-set mcbtics default
-set xtics border in scale 1,0.5 mirror norotate offset character 0, 0, 0
-set xtics autofreq
-set ytics border in scale 1,0.5 mirror norotate offset character 0, 0, 0
-set ytics autofreq
-set ztics border in scale 1,0.5 nomirror norotate offset character 0, 0, 0
-set ztics autofreq
-set nox2tics
-set noy2tics
-set cbtics border in scale 1,0.5 mirror norotate offset character 0, 0, 0
-set cbtics autofreq
-set title ""
-set title offset character 0, 0, 0 font "" norotate
-set timestamp bottom
-set timestamp ""
-set timestamp offset character 0, 0, 0 font "" norotate
-set rrange [ * : * ] noreverse nowriteback # (currently [8.98847e+307:-8.98847e+307] )
-set trange [ * : * ] noreverse nowriteback # (currently [-5.00000:5.00000] )
-set urange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] )
-set vrange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] )
-set xlabel "time (s)"
-set xlabel offset character 0, 0, 0 font "" textcolor lt -1 norotate
-set x2label ""
-set x2label offset character 0, 0, 0 font "" textcolor lt -1 norotate
-set xrange [ * : * ] noreverse nowriteback # (currently [-10.0000:45.0000] )
-set x2range [ * : * ] noreverse nowriteback # (currently [-7.50000:41.2435] )
-set ylabel "displacement (m)"
-set ylabel offset character 0, 0, 0 font "" textcolor lt -1 rotate by 90
-set y2label ""
-set y2label offset character 0, 0, 0 font "" textcolor lt -1 rotate by 90
-set yrange [ * : * ] noreverse nowriteback # (currently [-0.000100000:0.000300000] )
-set y2range [ * : * ] noreverse nowriteback # (currently [-8.99690e-05:0.000282874] )
-set zlabel ""
-set zlabel offset character 0, 0, 0 font "" textcolor lt -1 norotate
-set zrange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] )
-set cblabel ""
-set cblabel offset character 0, 0, 0 font "" textcolor lt -1 rotate by 90
-set cbrange [ * : * ] noreverse nowriteback # (currently [8.98847e+307:-8.98847e+307] )
-set zero 1e-08
-set lmargin -1
-set bmargin -1
-set rmargin -1
-set tmargin -1
-set locale "C"
-set pm3d explicit at s
-set pm3d scansautomatic
-set pm3d interpolate 1,1 flush begin noftriangles nohidden3d corners2color mean
-set palette positive nops_allcF maxcolors 0 gamma 1.5 color model RGB
-set palette rgbformulae 7, 5, 15
-set colorbox default
-set colorbox vertical origin screen 0.9, 0.2, 0 size screen 0.05, 0.6, 0 front bdefault
-set loadpath
-set fontpath
-set fit noerrorvariables
-GNUTERM = "aqua"
+
+set xlabel "time (s)"
+set ylabel "displacement (m)"
+
plot 'X1.DB.BHZ.semd' w l,'X10.DB.BHZ.semd' w l,'X20.DB.BHZ.semd' w l,'X30.DB.BHZ.semd' w l,'X40.DB.BHZ.semd' w l,'X50.DB.BHZ.semd' w l
-# EOF
Added: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/STATIONS_ADJOINT
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/STATIONS_ADJOINT (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/STATIONS_ADJOINT 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1 @@
+X20 DB 67000.00 22732.14 0.0 0.0
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/block_mesh.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -30,7 +30,7 @@
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
-cubit.cmd('block 1 name "elastic" ') # elastic material region
+cubit.cmd('block 1 name "elastic 1" ') # elastic material region
cubit.cmd('block 1 attribute count 6')
cubit.cmd('block 1 attribute index 1 1') # flag for material: 1 for 1. material
cubit.cmd('block 1 attribute index 2 2800') # vp
@@ -40,7 +40,7 @@
cubit.cmd('block 1 attribute index 6 0 ') # anisotropy_flag
-#cubit.cmd('block 1 name "acoustic" ') # acoustic material region
+#cubit.cmd('block 1 name "acoustic 1" ') # acoustic material region
#cubit.cmd('block 1 attribute count 4')
#cubit.cmd('block 1 attribute index 1 1 ') # material 1
#cubit.cmd('block 1 attribute index 2 1480 ') # vp
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/cubit2specfem3d.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/cubit2specfem3d.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/cubit2specfem3d.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -113,10 +113,8 @@
#
#############################################################################
-
import cubit
-
class mtools(object):
"""docstring for ciao"""
def __init__(self,frequency,list_surf,list_vp):
@@ -289,7 +287,7 @@
elif dot < 0:
return nodes[0],nodes[3],nodes[2],nodes[1]
else:
- print 'error, dot=0', axb,normal,dot,p0,p1,p2
+ print 'error: surface normal, dot=0', axb,normal,dot,p0,p1,p2
def mesh_analysis(self,frequency):
from sets import Set
cubit.cmd('set info off')
@@ -350,14 +348,15 @@
self.freename='free_surface_file'
self.recname='STATIONS'
self.face='QUAD4'
+ self.face2='SHELL4'
self.hex='HEX8'
self.edge='BAR2'
self.topo='face_topo'
self.rec='receivers'
- self.block_definition()
self.ngll=5
self.percent_gll=0.172
self.point_wavelength=5
+ self.block_definition()
cubit.cmd('compress')
def __repr__(self):
pass
@@ -371,9 +370,10 @@
blocks=cubit.get_block_id_list()
for block in blocks:
name=cubit.get_exodus_entity_name('block',block)
- ty=cubit.get_block_element_type(block)
- print block,name,blocks,ty,self.hex,self.face
- if ty == self.hex:
+ type=cubit.get_block_element_type(block)
+ print block,name,blocks,type,self.hex,self.face
+ # block has hexahedral elements (HEX8)
+ if type == self.hex:
flag=None
vel=None
vs=None
@@ -381,14 +381,18 @@
q=0
ani=0
# material domain id
- if name == "acoustic" :
+ if name.find("acoustic") >= 0 :
imaterial = 1
- elif name == "elastic" :
+ elif name.find("elastic") >= 0 :
imaterial = 2
- elif name == "poroelastic" :
+ elif name.find("poroelastic") >= 0 :
imaterial = 3
else :
imaterial = 0
+ print "block: ",name
+ print " could not find appropriate material for this block..."
+ print ""
+ break
nattrib=cubit.get_block_attribute_count(block)
if nattrib != 0:
@@ -442,14 +446,28 @@
elif flag==0:
par=tuple([imaterial,flag,name])
material[block]=par
- elif ty == self.face: #Stacey condition, we need hex here for pml
+ elif (type == self.face) or (type == self.face2) :
+ # block has surface elements (QUAD4 or SHELL4)
block_bc_flag.append(4)
block_bc.append(block)
bc[block]=4 #face has connectivity = 4
if name == self.topo: topography_face=block
else:
- print 'blocks no properly defined',ty
- return None, None,None,None,None,None,None,None
+ # block elements differ from HEX8/QUAD4/SHELL4
+ print '****************************************'
+ print 'block not properly defined:'
+ print ' name:',name
+ print ' type:',type
+ print
+ print 'please check your block definitions!'
+ print
+ print 'only supported types are:'
+ print ' HEX8 for volumes'
+ print ' QUAD4 for surface'
+ print ' SHELL4 for surface'
+ print '****************************************'
+ continue
+
nsets=cubit.get_nodeset_id_list()
if len(nsets) == 0: self.receivers=None
for nset in nsets:
@@ -468,7 +486,8 @@
self.bc=bc
self.topography=topography_face
except:
- print 'blocks no properly defined'
+ print '****************************************'
+ print 'sorry, no blocks or blocks not properly defined'
print block_mat
print block_flag
print block_bc
@@ -476,8 +495,9 @@
print material
print bc
print topography
+ print '****************************************'
def mat_parameter(self,properties):
- #TODO: material property acoustic/elastic/poroelastic ? .... where?
+ #note: material property acoustic/elastic/poroelastic are defined by the block's name
print "#material properties:"
print properties
imaterial=properties[0]
@@ -558,22 +578,23 @@
nodecoord.close()
print 'Ok'
def free_write(self,freename=None):
+ # free surface
cubit.cmd('set info off')
cubit.cmd('set echo off')
cubit.cmd('set journal off')
from sets import Set
normal=(0,0,1)
if not freename: freename=self.freename
+ # writes free surface file
+ print 'Writing '+freename+'.....'
freehex=open(freename,'w')
- print 'Writing '+freename+'.....'
- #
- #
+ # searches block definition with name face_topo
for block,flag in zip(self.block_bc,self.block_bc_flag):
if block == self.topography:
name=cubit.get_exodus_entity_name('block',block)
- print name,block
+ print ' block name:',name,'id:',block
quads_all=cubit.get_block_faces(block)
- print 'face = ',len(quads_all)
+ print ' face = ',len(quads_all)
dic_quads_all=dict(zip(quads_all,quads_all))
freehex.write('%10i\n' % len(quads_all))
list_hex=cubit.parse_cubit_list('hex','all')
@@ -587,11 +608,12 @@
txt='%10i %10i %10i %10i %10i\n' % (h,nodes_ok[0],\
nodes_ok[1],nodes_ok[2],nodes_ok[3])
freehex.write(txt)
- freehex.close()
+ freehex.close()
print 'Ok'
cubit.cmd('set info on')
cubit.cmd('set echo on')
def abs_write(self,absname=None):
+ # absorbing boundaries
import re
cubit.cmd('set info off')
cubit.cmd('set echo off')
@@ -599,7 +621,7 @@
from sets import Set
if not absname: absname=self.absname
#
- #
+ # loops through all block definitions
list_hex=cubit.parse_cubit_list('hex','all')
for block,flag in zip(self.block_bc,self.block_bc_flag):
if block != self.topography:
@@ -607,33 +629,31 @@
print name,block
absflag=False
if re.search('xmin',name):
- print 'xmin'
- abshex_local=open(absname+'_xmin','w')
+ filename=absname+'_xmin'
normal=(-1,0,0)
elif re.search('xmax',name):
- print "xmax"
- abshex_local=open(absname+'_xmax','w')
+ filename=absname+'_xmax'
normal=(1,0,0)
elif re.search('ymin',name):
- print "ymin"
- abshex_local=open(absname+'_ymin','w')
+ filename=absname+'_ymin'
normal=(0,-1,0)
elif re.search('ymax',name):
- print "ymax"
- abshex_local=open(absname+'_ymax','w')
+ filename=absname+'_ymax'
normal=(0,1,0)
elif re.search('bottom',name):
- print "bottom"
- abshex_local=open(absname+'_bottom','w')
+ filename=absname+'_bottom'
normal=(0,0,-1)
- elif re.search('abs',name):
- print "abs all - no implemented yet"
- absflag=True
- abshex_local=open(absname,'w')
- #
- #
+ elif re.search('abs',name):
+ print " ...face_abs - not used so far..."
+ continue
+ else:
+ continue
+ # opens file
+ print 'Writing '+filename+'.....'
+ abshex_local=open(filename,'w')
+ # gets face elements
quads_all=cubit.get_block_faces(block)
- dic_quads_all=dict(zip(quads_all,quads_all))
+ dic_quads_all=dict(zip(quads_all,quads_all))
abshex_local.write('%10i\n' % len(quads_all))
#command = "group 'list_hex' add hex in face "+str(quads_all)
#command = command.replace("["," ").replace("]"," ").replace("("," ").replace(")"," ")
@@ -648,6 +668,7 @@
if dic_quads_all.has_key(f):
nodes=cubit.get_connectivity('Face',f)
if not absflag:
+ # checks with specified normal
nodes_ok=self.normal_check(nodes,normal)
txt='%10i %10i %10i %10i %10i\n' % (h,nodes_ok[0],\
nodes_ok[1],nodes_ok[2],nodes_ok[3])
@@ -655,10 +676,55 @@
txt='%10i %10i %10i %10i %10i\n' % (h,nodes[0],\
nodes[1],nodes[2],nodes[3])
abshex_local.write(txt)
+ # closes file
abshex_local.close()
print 'Ok'
cubit.cmd('set info on')
cubit.cmd('set echo on')
+ def surface_write(self,pathdir=None):
+ # optional surfaces, e.g. moho_surface
+ # should be created like e.g.:
+ # > block 10 face in surface 2
+ # > block 10 name 'moho_surface'
+ import re
+ from sets import Set
+ for block in self.block_bc :
+ if block != self.topography:
+ name=cubit.get_exodus_entity_name('block',block)
+ # skips block names like face_abs**, face_topo**
+ if re.search('abs',name):
+ continue
+ elif re.search('topo',name):
+ continue
+ elif re.search('surface',name):
+ filename=pathdir+name+'_file'
+ else:
+ continue
+ # gets face elements
+ print ' surface block name: ',name,'id: ',block
+ quads_all=cubit.get_block_faces(block)
+ print ' face = ',len(quads_all)
+ if len(quads_all) == 0 :
+ continue
+ # writes out surface infos to file
+ print 'Writing '+filename+'.....'
+ surfhex_local=open(filename,'w')
+ dic_quads_all=dict(zip(quads_all,quads_all))
+ # writes number of surface elements
+ surfhex_local.write('%10i\n' % len(quads_all))
+ # writes out element node ids
+ list_hex=cubit.parse_cubit_list('hex','all')
+ for h in list_hex:
+ faces=cubit.get_sub_elements('hex',h,2)
+ for f in faces:
+ if dic_quads_all.has_key(f):
+ nodes=cubit.get_connectivity('Face',f)
+ txt='%10i %10i %10i %10i %10i\n' % (h,nodes[0],\
+ nodes[1],nodes[2],nodes[3])
+ surfhex_local.write(txt)
+ # closes file
+ surfhex_local.close()
+ print 'Ok'
def rec_write(self,recname):
print 'Writing '+self.recname+'.....'
recfile=open(self.recname,'w')
@@ -674,25 +740,36 @@
cubit.cmd('set journal off')
if len(path) != 0:
if path[-1] != '/': path=path+'/'
+ # mesh file
self.mesh_write(path+self.mesh_name)
+ # mesh material
self.material_write(path+self.material_name)
+ # mesh coordinates
self.nodescoord_write(path+self.nodecoord_name)
+ # material definitions
+ self.nummaterial_write(path+self.nummaterial_name)
+ # free surface: face_top
self.free_write(path+self.freename)
+ # absorbing surfaces: abs_***
self.abs_write(path+self.absname)
- self.nummaterial_write(path+self.nummaterial_name)
+ # any other surfaces: ***surface***
+ self.surface_write(path)
+ # receivers
if self.receivers: self.rec_write(path+self.recname)
cubit.cmd('set info on')
cubit.cmd('set echo on')
def export2SESAME(path_exporting_mesh_SPECFEM3D_SESAME):
+ cubit.cmd('set info on')
+ cubit.cmd('set echo on')
sem_mesh=mesh()
sem_mesh.write(path=path_exporting_mesh_SPECFEM3D_SESAME)
-
if __name__ == '__main__':
- path='/Users/emanuele/Desktop/'
- export2SESAME(path)
-
-#TODO: change the algorithm for the abs detection of the hex
-
+ path='MESH/'
+ export2SESAME(path)
+
+# call by:
+# import cubit2specfem3d
+# cubit2specfem3d.export2SESAME('MESH')
Added: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/run_boundary_definition.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/run_boundary_definition.py (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/run_boundary_definition.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,18 @@
+#!python
+#!/usr/bin/env python
+
+import cubit
+import boundary_definition
+import cubit2specfem3d
+
+import os
+import sys
+
+
+###### This is boundary_definition.py of GEOCUBIT
+#..... which extracts the bounding faces and defines them into blocks
+reload(boundary_definition)
+boundary_definition.entities=['face']
+boundary_definition.define_bc(boundary_definition.entities,parallel=True)
+
+
Property changes on: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/run_boundary_definition.py
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/run_cubit2specfem3d.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/run_cubit2specfem3d.py (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/run_cubit2specfem3d.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,26 @@
+#!python
+#!/usr/bin/env python
+
+import cubit
+import boundary_definition
+import cubit2specfem3d
+
+import os
+import sys
+
+
+###### This is boundary_definition.py of GEOCUBIT
+#..... which extracts the bounding faces and defines them into blocks
+#reload(boundary_definition)
+#boundary_definition.entities=['face']
+#boundary_definition.define_bc(boundary_definition.entities,parallel=True)
+
+
+#### Export to SESAME format using cubit2specfem3d.py of GEOCUBIT
+os.system('mkdir -p MESH')
+
+reload(cubit2specfem3d)
+cubit2specfem3d.export2SESAME('MESH')
+
+# all files needed by SCOTCH are now in directory MESH
+
Property changes on: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/run_cubit2specfem3d.py
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/slices.txt
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/slices.txt (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/homogeneous_halfspace/slices.txt 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,4 @@
+0
+1
+2
+3
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8-nodoubling.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8-nodoubling.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8-nodoubling.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -73,7 +73,7 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
-cubit.cmd('block 1 name "elastic" ') # elastic material region
+cubit.cmd('block 1 name "elastic 1" ') # elastic material region
cubit.cmd('block 1 attribute count 6')
cubit.cmd('block 1 attribute index 1 1 ') # volume 1
cubit.cmd('block 1 attribute index 2 2800 ') # vp
@@ -82,7 +82,7 @@
cubit.cmd('block 1 attribute index 5 6 ') # Q_flag
cubit.cmd('block 1 attribute index 6 0 ') # anisotropy_flag
-cubit.cmd('block 2 name "elastic" ') # elastic material region
+cubit.cmd('block 2 name "elastic 2" ') # elastic material region
cubit.cmd('block 2 attribute count 6')
cubit.cmd('block 2 attribute index 1 2 ') # volume 2
cubit.cmd('block 2 attribute index 2 7500 ') # vp
@@ -91,7 +91,7 @@
cubit.cmd('block 2 attribute index 5 6') # Q_flag
cubit.cmd('block 2 attribute index 6 0 ') # anisotropy_flag
-cubit.cmd('block 3 name "elastic" ') # elastic material region
+cubit.cmd('block 3 name "elastic 3" ') # elastic material region
cubit.cmd('block 3 attribute count 6')
cubit.cmd('block 3 attribute index 1 3 ') # same material properties as for volume 2
cubit.cmd('block 3 attribute index 2 7500 ')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/2lay_mesh_boundary_fig8.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -70,7 +70,7 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
-cubit.cmd('block 1 name "elastic" ') # elastic material region
+cubit.cmd('block 1 name "elastic 1" ') # elastic material region
cubit.cmd('block 1 attribute count 6')
cubit.cmd('block 1 attribute index 1 1 ') # volume 1
cubit.cmd('block 1 attribute index 2 2800 ') # vp
@@ -79,7 +79,7 @@
cubit.cmd('block 1 attribute index 5 6 ') # Q_flag
cubit.cmd('block 1 attribute index 6 0 ') # anisotropy_flag
-cubit.cmd('block 2 name "elastic" ') # elastic material region
+cubit.cmd('block 2 name "elastic 2" ') # elastic material region
cubit.cmd('block 2 attribute count 6')
cubit.cmd('block 2 attribute index 1 2 ') # volume 2
cubit.cmd('block 2 attribute index 2 7500 ')
@@ -88,7 +88,7 @@
cubit.cmd('block 2 attribute index 5 6 ')
cubit.cmd('block 2 attribute index 6 0 ') # anisotropy_flag
-cubit.cmd('block 3 name "elastic" ') # elastic material region
+cubit.cmd('block 3 name "elastic 3" ') # elastic material region
cubit.cmd('block 3 attribute count 6')
cubit.cmd('block 3 attribute index 1 3 ') # same properties as for volume 2
cubit.cmd('block 3 attribute index 2 7500 ')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/REF_SEIS/X10-50.BHZ.gnuplot
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/REF_SEIS/X10-50.BHZ.gnuplot 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/REF_SEIS/X10-50.BHZ.gnuplot 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,149 +1,8 @@
#!/usr/local/bin/gnuplot -persist
#
#
-# G N U P L O T
-# Version 4.3 patchlevel 0
-# last modified February 2008
-# System: Darwin 9.8.0
-#
-# Copyright (C) 1986 - 1993, 1998, 2004, 2007, 2008
-# Thomas Williams, Colin Kelley and many others
-#
-# Type `help` to access the on-line reference manual.
-# The gnuplot FAQ is available from
-# http://www.gnuplot.info/faq/
-#
-# Send comments and help requests to <gnuplot-beta at lists.sourceforge.net>
-# Send bug reports and suggestions to <gnuplot-beta at lists.sourceforge.net>
-#
-# set terminal aqua 0 title "Figure 0" size 846 594 font "Times-Roman,14" noenhanced solid
-# set output
-unset clip points
-set clip one
-unset clip two
-set bar 1.000000 front
-set border 31 front linetype -1 linewidth 1.000
-set xdata
-set ydata
-set zdata
-set x2data
-set y2data
-set timefmt x "%d/%m/%y,%H:%M"
-set timefmt y "%d/%m/%y,%H:%M"
-set timefmt z "%d/%m/%y,%H:%M"
-set timefmt x2 "%d/%m/%y,%H:%M"
-set timefmt y2 "%d/%m/%y,%H:%M"
-set timefmt cb "%d/%m/%y,%H:%M"
-set boxwidth
-set style fill empty border
-set style rectangle back fc lt -3 fillstyle solid 1.00 border -1
-set dummy x,y
-set format x "% g"
-set format y "% g"
-set format x2 "% g"
-set format y2 "% g"
-set format z "% g"
-set format cb "% g"
-set angles radians
-unset grid
-set key title ""
-set key inside right top vertical Right noreverse enhanced autotitles nobox
-set key noinvert samplen 4 spacing 1 width 0 height 0
-unset label
-unset arrow
-set style increment default
-unset style line
-unset style arrow
-set style histogram clustered gap 2 title offset character 0, 0, 0
-unset logscale
-set offsets 0, 0, 0, 0
-set pointsize 1
-set encoding default
-unset polar
-unset parametric
-unset decimalsign
-set view 60, 30, 1, 1
-set samples 100, 100
-set isosamples 10, 10
-set surface
-unset contour
-set clabel '%8.3g'
-set mapping cartesian
-set datafile separator whitespace
-unset hidden3d
-set cntrparam order 4
-set cntrparam linear
-set cntrparam levels auto 5
-set cntrparam points 5
-set size ratio 0 1,1
-set origin 0,0
-set style data points
-set style function lines
-set xzeroaxis linetype -2 linewidth 1.000
-set yzeroaxis linetype -2 linewidth 1.000
-set zzeroaxis linetype -2 linewidth 1.000
-set x2zeroaxis linetype -2 linewidth 1.000
-set y2zeroaxis linetype -2 linewidth 1.000
-set ticslevel 0.5
-set mxtics default
-set mytics default
-set mztics default
-set mx2tics default
-set my2tics default
-set mcbtics default
-set xtics border in scale 1,0.5 mirror norotate offset character 0, 0, 0
-set xtics autofreq
-set ytics border in scale 1,0.5 mirror norotate offset character 0, 0, 0
-set ytics autofreq
-set ztics border in scale 1,0.5 nomirror norotate offset character 0, 0, 0
-set ztics autofreq
-set nox2tics
-set noy2tics
-set cbtics border in scale 1,0.5 mirror norotate offset character 0, 0, 0
-set cbtics autofreq
-set title ""
-set title offset character 0, 0, 0 font "" norotate
-set timestamp bottom
-set timestamp ""
-set timestamp offset character 0, 0, 0 font "" norotate
-set rrange [ * : * ] noreverse nowriteback # (currently [8.98847e+307:-8.98847e+307] )
-set trange [ * : * ] noreverse nowriteback # (currently [-5.00000:5.00000] )
-set urange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] )
-set vrange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] )
-set xlabel "time (s)"
-set xlabel offset character 0, 0, 0 font "" textcolor lt -1 norotate
-set x2label ""
-set x2label offset character 0, 0, 0 font "" textcolor lt -1 norotate
-set xrange [ * : * ] noreverse nowriteback # (currently [-10.0000:45.0000] )
-set x2range [ * : * ] noreverse nowriteback # (currently [-7.50000:41.2435] )
-set ylabel "displacement (m)"
-set ylabel offset character 0, 0, 0 font "" textcolor lt -1 rotate by 90
-set y2label ""
-set y2label offset character 0, 0, 0 font "" textcolor lt -1 rotate by 90
-set yrange [ * : * ] noreverse nowriteback # (currently [-0.000100000:0.000300000] )
-set y2range [ * : * ] noreverse nowriteback # (currently [-8.99690e-05:0.000282874] )
-set zlabel ""
-set zlabel offset character 0, 0, 0 font "" textcolor lt -1 norotate
-set zrange [ * : * ] noreverse nowriteback # (currently [-10.0000:10.0000] )
-set cblabel ""
-set cblabel offset character 0, 0, 0 font "" textcolor lt -1 rotate by 90
-set cbrange [ * : * ] noreverse nowriteback # (currently [8.98847e+307:-8.98847e+307] )
-set zero 1e-08
-set lmargin -1
-set bmargin -1
-set rmargin -1
-set tmargin -1
-set locale "C"
-set pm3d explicit at s
-set pm3d scansautomatic
-set pm3d interpolate 1,1 flush begin noftriangles nohidden3d corners2color mean
-set palette positive nops_allcF maxcolors 0 gamma 1.5 color model RGB
-set palette rgbformulae 7, 5, 15
-set colorbox default
-set colorbox vertical origin screen 0.9, 0.2, 0 size screen 0.05, 0.6, 0 front bdefault
-set loadpath
-set fontpath
-set fit noerrorvariables
-GNUTERM = "aqua"
-plot 'X10.DB.BHZ.semd' w l,'X20.DB.BHZ.semd' w l,'X30.DB.BHZ.semd' w l,'X40.DB.BHZ.semd' w l,'X50.DB.BHZ.semd' w l
-# EOF
+
+set xlabel "time (s)"
+set ylabel "displacement (m)"
+
+plot 'X1.DB.BHZ.semd' w l,'X10.DB.BHZ.semd' w l,'X20.DB.BHZ.semd' w l,'X30.DB.BHZ.semd' w l,'X40.DB.BHZ.semd' w l,'X50.DB.BHZ.semd' w l
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/cubit2specfem3d.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/cubit2specfem3d.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/layered_halfspace/cubit2specfem3d.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -113,10 +113,8 @@
#
#############################################################################
-
import cubit
-
class mtools(object):
"""docstring for ciao"""
def __init__(self,frequency,list_surf,list_vp):
@@ -289,7 +287,7 @@
elif dot < 0:
return nodes[0],nodes[3],nodes[2],nodes[1]
else:
- print 'error, dot=0', axb,normal,dot,p0,p1,p2
+ print 'error: surface normal, dot=0', axb,normal,dot,p0,p1,p2
def mesh_analysis(self,frequency):
from sets import Set
cubit.cmd('set info off')
@@ -350,14 +348,15 @@
self.freename='free_surface_file'
self.recname='STATIONS'
self.face='QUAD4'
+ self.face2='SHELL4'
self.hex='HEX8'
self.edge='BAR2'
self.topo='face_topo'
self.rec='receivers'
- self.block_definition()
self.ngll=5
self.percent_gll=0.172
self.point_wavelength=5
+ self.block_definition()
cubit.cmd('compress')
def __repr__(self):
pass
@@ -371,9 +370,10 @@
blocks=cubit.get_block_id_list()
for block in blocks:
name=cubit.get_exodus_entity_name('block',block)
- ty=cubit.get_block_element_type(block)
- print block,name,blocks,ty,self.hex,self.face
- if ty == self.hex:
+ type=cubit.get_block_element_type(block)
+ print block,name,blocks,type,self.hex,self.face
+ # block has hexahedral elements (HEX8)
+ if type == self.hex:
flag=None
vel=None
vs=None
@@ -381,14 +381,18 @@
q=0
ani=0
# material domain id
- if name == "acoustic" :
+ if name.find("acoustic") >= 0 :
imaterial = 1
- elif name == "elastic" :
+ elif name.find("elastic") >= 0 :
imaterial = 2
- elif name == "poroelastic" :
+ elif name.find("poroelastic") >= 0 :
imaterial = 3
else :
imaterial = 0
+ print "block: ",name
+ print " could not find appropriate material for this block..."
+ print ""
+ break
nattrib=cubit.get_block_attribute_count(block)
if nattrib != 0:
@@ -442,14 +446,28 @@
elif flag==0:
par=tuple([imaterial,flag,name])
material[block]=par
- elif ty == self.face: #Stacey condition, we need hex here for pml
+ elif (type == self.face) or (type == self.face2) :
+ # block has surface elements (QUAD4 or SHELL4)
block_bc_flag.append(4)
block_bc.append(block)
bc[block]=4 #face has connectivity = 4
if name == self.topo: topography_face=block
else:
- print 'blocks no properly defined',ty
- return None, None,None,None,None,None,None,None
+ # block elements differ from HEX8/QUAD4/SHELL4
+ print '****************************************'
+ print 'block not properly defined:'
+ print ' name:',name
+ print ' type:',type
+ print
+ print 'please check your block definitions!'
+ print
+ print 'only supported types are:'
+ print ' HEX8 for volumes'
+ print ' QUAD4 for surface'
+ print ' SHELL4 for surface'
+ print '****************************************'
+ continue
+
nsets=cubit.get_nodeset_id_list()
if len(nsets) == 0: self.receivers=None
for nset in nsets:
@@ -468,7 +486,8 @@
self.bc=bc
self.topography=topography_face
except:
- print 'blocks no properly defined'
+ print '****************************************'
+ print 'sorry, no blocks or blocks not properly defined'
print block_mat
print block_flag
print block_bc
@@ -476,8 +495,9 @@
print material
print bc
print topography
+ print '****************************************'
def mat_parameter(self,properties):
- #TODO: material property acoustic/elastic/poroelastic ? .... where?
+ #note: material property acoustic/elastic/poroelastic are defined by the block's name
print "#material properties:"
print properties
imaterial=properties[0]
@@ -558,22 +578,23 @@
nodecoord.close()
print 'Ok'
def free_write(self,freename=None):
+ # free surface
cubit.cmd('set info off')
cubit.cmd('set echo off')
cubit.cmd('set journal off')
from sets import Set
normal=(0,0,1)
if not freename: freename=self.freename
+ # writes free surface file
+ print 'Writing '+freename+'.....'
freehex=open(freename,'w')
- print 'Writing '+freename+'.....'
- #
- #
+ # searches block definition with name face_topo
for block,flag in zip(self.block_bc,self.block_bc_flag):
if block == self.topography:
name=cubit.get_exodus_entity_name('block',block)
- print name,block
+ print ' block name:',name,'id:',block
quads_all=cubit.get_block_faces(block)
- print 'face = ',len(quads_all)
+ print ' face = ',len(quads_all)
dic_quads_all=dict(zip(quads_all,quads_all))
freehex.write('%10i\n' % len(quads_all))
list_hex=cubit.parse_cubit_list('hex','all')
@@ -587,11 +608,12 @@
txt='%10i %10i %10i %10i %10i\n' % (h,nodes_ok[0],\
nodes_ok[1],nodes_ok[2],nodes_ok[3])
freehex.write(txt)
- freehex.close()
+ freehex.close()
print 'Ok'
cubit.cmd('set info on')
cubit.cmd('set echo on')
def abs_write(self,absname=None):
+ # absorbing boundaries
import re
cubit.cmd('set info off')
cubit.cmd('set echo off')
@@ -599,7 +621,7 @@
from sets import Set
if not absname: absname=self.absname
#
- #
+ # loops through all block definitions
list_hex=cubit.parse_cubit_list('hex','all')
for block,flag in zip(self.block_bc,self.block_bc_flag):
if block != self.topography:
@@ -607,33 +629,31 @@
print name,block
absflag=False
if re.search('xmin',name):
- print 'xmin'
- abshex_local=open(absname+'_xmin','w')
+ filename=absname+'_xmin'
normal=(-1,0,0)
elif re.search('xmax',name):
- print "xmax"
- abshex_local=open(absname+'_xmax','w')
+ filename=absname+'_xmax'
normal=(1,0,0)
elif re.search('ymin',name):
- print "ymin"
- abshex_local=open(absname+'_ymin','w')
+ filename=absname+'_ymin'
normal=(0,-1,0)
elif re.search('ymax',name):
- print "ymax"
- abshex_local=open(absname+'_ymax','w')
+ filename=absname+'_ymax'
normal=(0,1,0)
elif re.search('bottom',name):
- print "bottom"
- abshex_local=open(absname+'_bottom','w')
+ filename=absname+'_bottom'
normal=(0,0,-1)
- elif re.search('abs',name):
- print "abs all - no implemented yet"
- absflag=True
- abshex_local=open(absname,'w')
- #
- #
+ elif re.search('abs',name):
+ print " ...face_abs - not used so far..."
+ continue
+ else:
+ continue
+ # opens file
+ print 'Writing '+filename+'.....'
+ abshex_local=open(filename,'w')
+ # gets face elements
quads_all=cubit.get_block_faces(block)
- dic_quads_all=dict(zip(quads_all,quads_all))
+ dic_quads_all=dict(zip(quads_all,quads_all))
abshex_local.write('%10i\n' % len(quads_all))
#command = "group 'list_hex' add hex in face "+str(quads_all)
#command = command.replace("["," ").replace("]"," ").replace("("," ").replace(")"," ")
@@ -648,6 +668,7 @@
if dic_quads_all.has_key(f):
nodes=cubit.get_connectivity('Face',f)
if not absflag:
+ # checks with specified normal
nodes_ok=self.normal_check(nodes,normal)
txt='%10i %10i %10i %10i %10i\n' % (h,nodes_ok[0],\
nodes_ok[1],nodes_ok[2],nodes_ok[3])
@@ -655,10 +676,55 @@
txt='%10i %10i %10i %10i %10i\n' % (h,nodes[0],\
nodes[1],nodes[2],nodes[3])
abshex_local.write(txt)
+ # closes file
abshex_local.close()
print 'Ok'
cubit.cmd('set info on')
cubit.cmd('set echo on')
+ def surface_write(self,pathdir=None):
+ # optional surfaces, e.g. moho_surface
+ # should be created like e.g.:
+ # > block 10 face in surface 2
+ # > block 10 name 'moho_surface'
+ import re
+ from sets import Set
+ for block in self.block_bc :
+ if block != self.topography:
+ name=cubit.get_exodus_entity_name('block',block)
+ # skips block names like face_abs**, face_topo**
+ if re.search('abs',name):
+ continue
+ elif re.search('topo',name):
+ continue
+ elif re.search('surface',name):
+ filename=pathdir+name+'_file'
+ else:
+ continue
+ # gets face elements
+ print ' surface block name: ',name,'id: ',block
+ quads_all=cubit.get_block_faces(block)
+ print ' face = ',len(quads_all)
+ if len(quads_all) == 0 :
+ continue
+ # writes out surface infos to file
+ print 'Writing '+filename+'.....'
+ surfhex_local=open(filename,'w')
+ dic_quads_all=dict(zip(quads_all,quads_all))
+ # writes number of surface elements
+ surfhex_local.write('%10i\n' % len(quads_all))
+ # writes out element node ids
+ list_hex=cubit.parse_cubit_list('hex','all')
+ for h in list_hex:
+ faces=cubit.get_sub_elements('hex',h,2)
+ for f in faces:
+ if dic_quads_all.has_key(f):
+ nodes=cubit.get_connectivity('Face',f)
+ txt='%10i %10i %10i %10i %10i\n' % (h,nodes[0],\
+ nodes[1],nodes[2],nodes[3])
+ surfhex_local.write(txt)
+ # closes file
+ surfhex_local.close()
+ print 'Ok'
def rec_write(self,recname):
print 'Writing '+self.recname+'.....'
recfile=open(self.recname,'w')
@@ -674,25 +740,36 @@
cubit.cmd('set journal off')
if len(path) != 0:
if path[-1] != '/': path=path+'/'
+ # mesh file
self.mesh_write(path+self.mesh_name)
+ # mesh material
self.material_write(path+self.material_name)
+ # mesh coordinates
self.nodescoord_write(path+self.nodecoord_name)
+ # material definitions
+ self.nummaterial_write(path+self.nummaterial_name)
+ # free surface: face_top
self.free_write(path+self.freename)
+ # absorbing surfaces: abs_***
self.abs_write(path+self.absname)
- self.nummaterial_write(path+self.nummaterial_name)
+ # any other surfaces: ***surface***
+ self.surface_write(path)
+ # receivers
if self.receivers: self.rec_write(path+self.recname)
cubit.cmd('set info on')
cubit.cmd('set echo on')
def export2SESAME(path_exporting_mesh_SPECFEM3D_SESAME):
+ cubit.cmd('set info on')
+ cubit.cmd('set echo on')
sem_mesh=mesh()
sem_mesh.write(path=path_exporting_mesh_SPECFEM3D_SESAME)
-
if __name__ == '__main__':
- path='/Users/emanuele/Desktop/'
- export2SESAME(path)
-
-#TODO: change the algorithm for the abs detection of the hex
-
+ path='MESH/'
+ export2SESAME(path)
+
+# call by:
+# import cubit2specfem3d
+# cubit2specfem3d.export2SESAME('MESH')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/CMTSOLUTION
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/CMTSOLUTION 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/CMTSOLUTION 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,5 +1,5 @@
-PDE 1999 01 01 00 00 00.00 67000 67000 -25000 4.2 4.2 FIG8
-event name: FIG8_vertical
+PDE 1999 01 01 00 00 00.00 67000 67000 -25000 4.2 4.2 water_vertical
+event name: water_vertical
time shift: 0.0000
half duration: 2.0
latitude: 67000.0
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/Par_file
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/Par_file 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/Par_file 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,15 +1,15 @@
-# forward or adjoint simulation
-SIMULATION_TYPE = 1 # 1 = forward, 2 = adjoint, 3 = both simultaneously
+# forward or adjoint simulation:
+# 1 = forward, 2 = adjoint, 3 = both simultaneously
+SIMULATION_TYPE = 1
SAVE_FORWARD = .false.
# UTM projection parameters
UTM_PROJECTION_ZONE = 11
SUPPRESS_UTM_PROJECTION = .true.
-# number of MPI processors along xi and eta (can be different)
-NPROC_XI = 2
-NPROC_ETA = 2
+# number of MPI processors
+NPROC = 4
# time step parameters
NSTEP = 4500
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/cubit2specfem3d.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/cubit2specfem3d.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/cubit2specfem3d.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -113,10 +113,8 @@
#
#############################################################################
-
import cubit
-
class mtools(object):
"""docstring for ciao"""
def __init__(self,frequency,list_surf,list_vp):
@@ -289,7 +287,7 @@
elif dot < 0:
return nodes[0],nodes[3],nodes[2],nodes[1]
else:
- print 'error, dot=0', axb,normal,dot,p0,p1,p2
+ print 'error: surface normal, dot=0', axb,normal,dot,p0,p1,p2
def mesh_analysis(self,frequency):
from sets import Set
cubit.cmd('set info off')
@@ -350,14 +348,15 @@
self.freename='free_surface_file'
self.recname='STATIONS'
self.face='QUAD4'
+ self.face2='SHELL4'
self.hex='HEX8'
self.edge='BAR2'
self.topo='face_topo'
self.rec='receivers'
- self.block_definition()
self.ngll=5
self.percent_gll=0.172
self.point_wavelength=5
+ self.block_definition()
cubit.cmd('compress')
def __repr__(self):
pass
@@ -371,9 +370,10 @@
blocks=cubit.get_block_id_list()
for block in blocks:
name=cubit.get_exodus_entity_name('block',block)
- ty=cubit.get_block_element_type(block)
- print block,name,blocks,ty,self.hex,self.face
- if ty == self.hex:
+ type=cubit.get_block_element_type(block)
+ print block,name,blocks,type,self.hex,self.face
+ # block has hexahedral elements (HEX8)
+ if type == self.hex:
flag=None
vel=None
vs=None
@@ -381,14 +381,18 @@
q=0
ani=0
# material domain id
- if name == "acoustic" :
+ if name.find("acoustic") >= 0 :
imaterial = 1
- elif name == "elastic" :
+ elif name.find("elastic") >= 0 :
imaterial = 2
- elif name == "poroelastic" :
+ elif name.find("poroelastic") >= 0 :
imaterial = 3
else :
imaterial = 0
+ print "block: ",name
+ print " could not find appropriate material for this block..."
+ print ""
+ break
nattrib=cubit.get_block_attribute_count(block)
if nattrib != 0:
@@ -442,14 +446,28 @@
elif flag==0:
par=tuple([imaterial,flag,name])
material[block]=par
- elif ty == self.face: #Stacey condition, we need hex here for pml
+ elif (type == self.face) or (type == self.face2) :
+ # block has surface elements (QUAD4 or SHELL4)
block_bc_flag.append(4)
block_bc.append(block)
bc[block]=4 #face has connectivity = 4
if name == self.topo: topography_face=block
else:
- print 'blocks no properly defined',ty
- return None, None,None,None,None,None,None,None
+ # block elements differ from HEX8/QUAD4/SHELL4
+ print '****************************************'
+ print 'block not properly defined:'
+ print ' name:',name
+ print ' type:',type
+ print
+ print 'please check your block definitions!'
+ print
+ print 'only supported types are:'
+ print ' HEX8 for volumes'
+ print ' QUAD4 for surface'
+ print ' SHELL4 for surface'
+ print '****************************************'
+ continue
+
nsets=cubit.get_nodeset_id_list()
if len(nsets) == 0: self.receivers=None
for nset in nsets:
@@ -468,7 +486,8 @@
self.bc=bc
self.topography=topography_face
except:
- print 'blocks no properly defined'
+ print '****************************************'
+ print 'sorry, no blocks or blocks not properly defined'
print block_mat
print block_flag
print block_bc
@@ -476,8 +495,9 @@
print material
print bc
print topography
+ print '****************************************'
def mat_parameter(self,properties):
- #TODO: material property acoustic/elastic/poroelastic ? .... where?
+ #note: material property acoustic/elastic/poroelastic are defined by the block's name
print "#material properties:"
print properties
imaterial=properties[0]
@@ -558,22 +578,23 @@
nodecoord.close()
print 'Ok'
def free_write(self,freename=None):
+ # free surface
cubit.cmd('set info off')
cubit.cmd('set echo off')
cubit.cmd('set journal off')
from sets import Set
normal=(0,0,1)
if not freename: freename=self.freename
+ # writes free surface file
+ print 'Writing '+freename+'.....'
freehex=open(freename,'w')
- print 'Writing '+freename+'.....'
- #
- #
+ # searches block definition with name face_topo
for block,flag in zip(self.block_bc,self.block_bc_flag):
if block == self.topography:
name=cubit.get_exodus_entity_name('block',block)
- print name,block
+ print ' block name:',name,'id:',block
quads_all=cubit.get_block_faces(block)
- print 'face = ',len(quads_all)
+ print ' face = ',len(quads_all)
dic_quads_all=dict(zip(quads_all,quads_all))
freehex.write('%10i\n' % len(quads_all))
list_hex=cubit.parse_cubit_list('hex','all')
@@ -587,11 +608,12 @@
txt='%10i %10i %10i %10i %10i\n' % (h,nodes_ok[0],\
nodes_ok[1],nodes_ok[2],nodes_ok[3])
freehex.write(txt)
- freehex.close()
+ freehex.close()
print 'Ok'
cubit.cmd('set info on')
cubit.cmd('set echo on')
def abs_write(self,absname=None):
+ # absorbing boundaries
import re
cubit.cmd('set info off')
cubit.cmd('set echo off')
@@ -599,7 +621,7 @@
from sets import Set
if not absname: absname=self.absname
#
- #
+ # loops through all block definitions
list_hex=cubit.parse_cubit_list('hex','all')
for block,flag in zip(self.block_bc,self.block_bc_flag):
if block != self.topography:
@@ -607,33 +629,31 @@
print name,block
absflag=False
if re.search('xmin',name):
- print 'xmin'
- abshex_local=open(absname+'_xmin','w')
+ filename=absname+'_xmin'
normal=(-1,0,0)
elif re.search('xmax',name):
- print "xmax"
- abshex_local=open(absname+'_xmax','w')
+ filename=absname+'_xmax'
normal=(1,0,0)
elif re.search('ymin',name):
- print "ymin"
- abshex_local=open(absname+'_ymin','w')
+ filename=absname+'_ymin'
normal=(0,-1,0)
elif re.search('ymax',name):
- print "ymax"
- abshex_local=open(absname+'_ymax','w')
+ filename=absname+'_ymax'
normal=(0,1,0)
elif re.search('bottom',name):
- print "bottom"
- abshex_local=open(absname+'_bottom','w')
+ filename=absname+'_bottom'
normal=(0,0,-1)
- elif re.search('abs',name):
- print "abs all - no implemented yet"
- absflag=True
- abshex_local=open(absname,'w')
- #
- #
+ elif re.search('abs',name):
+ print " ...face_abs - not used so far..."
+ continue
+ else:
+ continue
+ # opens file
+ print 'Writing '+filename+'.....'
+ abshex_local=open(filename,'w')
+ # gets face elements
quads_all=cubit.get_block_faces(block)
- dic_quads_all=dict(zip(quads_all,quads_all))
+ dic_quads_all=dict(zip(quads_all,quads_all))
abshex_local.write('%10i\n' % len(quads_all))
#command = "group 'list_hex' add hex in face "+str(quads_all)
#command = command.replace("["," ").replace("]"," ").replace("("," ").replace(")"," ")
@@ -648,6 +668,7 @@
if dic_quads_all.has_key(f):
nodes=cubit.get_connectivity('Face',f)
if not absflag:
+ # checks with specified normal
nodes_ok=self.normal_check(nodes,normal)
txt='%10i %10i %10i %10i %10i\n' % (h,nodes_ok[0],\
nodes_ok[1],nodes_ok[2],nodes_ok[3])
@@ -655,10 +676,55 @@
txt='%10i %10i %10i %10i %10i\n' % (h,nodes[0],\
nodes[1],nodes[2],nodes[3])
abshex_local.write(txt)
+ # closes file
abshex_local.close()
print 'Ok'
cubit.cmd('set info on')
cubit.cmd('set echo on')
+ def surface_write(self,pathdir=None):
+ # optional surfaces, e.g. moho_surface
+ # should be created like e.g.:
+ # > block 10 face in surface 2
+ # > block 10 name 'moho_surface'
+ import re
+ from sets import Set
+ for block in self.block_bc :
+ if block != self.topography:
+ name=cubit.get_exodus_entity_name('block',block)
+ # skips block names like face_abs**, face_topo**
+ if re.search('abs',name):
+ continue
+ elif re.search('topo',name):
+ continue
+ elif re.search('surface',name):
+ filename=pathdir+name+'_file'
+ else:
+ continue
+ # gets face elements
+ print ' surface block name: ',name,'id: ',block
+ quads_all=cubit.get_block_faces(block)
+ print ' face = ',len(quads_all)
+ if len(quads_all) == 0 :
+ continue
+ # writes out surface infos to file
+ print 'Writing '+filename+'.....'
+ surfhex_local=open(filename,'w')
+ dic_quads_all=dict(zip(quads_all,quads_all))
+ # writes number of surface elements
+ surfhex_local.write('%10i\n' % len(quads_all))
+ # writes out element node ids
+ list_hex=cubit.parse_cubit_list('hex','all')
+ for h in list_hex:
+ faces=cubit.get_sub_elements('hex',h,2)
+ for f in faces:
+ if dic_quads_all.has_key(f):
+ nodes=cubit.get_connectivity('Face',f)
+ txt='%10i %10i %10i %10i %10i\n' % (h,nodes[0],\
+ nodes[1],nodes[2],nodes[3])
+ surfhex_local.write(txt)
+ # closes file
+ surfhex_local.close()
+ print 'Ok'
def rec_write(self,recname):
print 'Writing '+self.recname+'.....'
recfile=open(self.recname,'w')
@@ -674,25 +740,36 @@
cubit.cmd('set journal off')
if len(path) != 0:
if path[-1] != '/': path=path+'/'
+ # mesh file
self.mesh_write(path+self.mesh_name)
+ # mesh material
self.material_write(path+self.material_name)
+ # mesh coordinates
self.nodescoord_write(path+self.nodecoord_name)
+ # material definitions
+ self.nummaterial_write(path+self.nummaterial_name)
+ # free surface: face_top
self.free_write(path+self.freename)
+ # absorbing surfaces: abs_***
self.abs_write(path+self.absname)
- self.nummaterial_write(path+self.nummaterial_name)
+ # any other surfaces: ***surface***
+ self.surface_write(path)
+ # receivers
if self.receivers: self.rec_write(path+self.recname)
cubit.cmd('set info on')
cubit.cmd('set echo on')
def export2SESAME(path_exporting_mesh_SPECFEM3D_SESAME):
+ cubit.cmd('set info on')
+ cubit.cmd('set echo on')
sem_mesh=mesh()
sem_mesh.write(path=path_exporting_mesh_SPECFEM3D_SESAME)
-
if __name__ == '__main__':
- path='/Users/emanuele/Desktop/'
- export2SESAME(path)
-
-#TODO: change the algorithm for the abs detection of the hex
-
+ path='MESH/'
+ export2SESAME(path)
+
+# call by:
+# import cubit2specfem3d
+# cubit2specfem3d.export2SESAME('MESH')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8-nodoubling.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8-nodoubling.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8-nodoubling.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -77,7 +77,7 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
-cubit.cmd('block 1 name "acoustic" ') # acoustic material region
+cubit.cmd('block 1 name "acoustic 1" ') # acoustic material region
cubit.cmd('block 1 attribute count 4')
cubit.cmd('block 1 attribute index 1 1 ') # material 1
cubit.cmd('block 1 attribute index 2 1480 ') # vp
@@ -85,7 +85,7 @@
cubit.cmd('block 1 attribute index 4 1028 ') # rho (ocean salt water density:
# http://www.windows.ucar.edu/tour/link=/earth/Water/density.html
-cubit.cmd('block 2 name "elastic" ') # elastic material region
+cubit.cmd('block 2 name "elastic 1" ') # elastic material region
cubit.cmd('block 2 attribute count 6')
cubit.cmd('block 2 attribute index 1 2 ') # material 2
cubit.cmd('block 2 attribute index 2 7500 ') # vp
@@ -94,7 +94,7 @@
cubit.cmd('block 2 attribute index 5 6') # Q_flag
cubit.cmd('block 2 attribute index 6 0 ') # anisotropy_flag
-cubit.cmd('block 3 name "elastic" ') # elastic material region
+cubit.cmd('block 3 name "elastic 2" ') # elastic material region
cubit.cmd('block 3 attribute count 6')
cubit.cmd('block 3 attribute index 1 3 ') # same properties as material 2
cubit.cmd('block 3 attribute index 2 7500 ') # vp
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -70,7 +70,7 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
-cubit.cmd('block 1 name "acoustic" ') # material region
+cubit.cmd('block 1 name "acoustic 1" ') # material region
cubit.cmd('block 1 attribute count 4')
cubit.cmd('block 1 attribute index 1 1 ') # volume 1
cubit.cmd('block 1 attribute index 2 1480 ') # vp
@@ -79,7 +79,7 @@
#cubit.cmd('block 1 attribute index 5 0 ') # Q_flag
#cubit.cmd('block 1 attribute index 6 0 ') # anisotropy_flag
-cubit.cmd('block 2 name "elastic" ') # material region
+cubit.cmd('block 2 name "elastic 1" ') # material region
cubit.cmd('block 2 attribute count 6')
cubit.cmd('block 2 attribute index 1 2 ') # volume 2
cubit.cmd('block 2 attribute index 2 7500 ')
@@ -88,7 +88,7 @@
cubit.cmd('block 2 attribute index 5 6 ')
cubit.cmd('block 2 attribute index 6 0 ') # anisotropy_flag
-cubit.cmd('block 3 name "elastic" ') # material region
+cubit.cmd('block 3 name "elastic 2" ') # material region
cubit.cmd('block 3 attribute count 6')
cubit.cmd('block 3 attribute index 1 3 ') # same properties as for volume 2
cubit.cmd('block 3 attribute index 2 7500 ')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_vertical.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_vertical.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_vertical.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -7,7 +7,7 @@
import os
import sys
-# two volumes separating 134000x134000x60000 block in middle vertically
+# two volumes separating whole 134000x134000x60000 block in middle vertically
cubit.cmd('reset')
cubit.cmd('brick x 67000 y 134000 z 60000')
cubit.cmd('volume 1 move x 33500 y 67000 z -30000')
@@ -32,14 +32,14 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
-cubit.cmd('block 1 name "acoustic" ') # material region
+cubit.cmd('block 1 name "acoustic 1" ') # material region
cubit.cmd('block 1 attribute count 4')
cubit.cmd('block 1 attribute index 1 1') # flag for material: 1 for 1. material
cubit.cmd('block 1 attribute index 2 3000') # vp
cubit.cmd('block 1 attribute index 3 0') # vs
cubit.cmd('block 1 attribute index 4 2300') # rho
-cubit.cmd('block 2 name "elastic" ') # material region
+cubit.cmd('block 2 name "elastic 1" ') # material region
cubit.cmd('block 2 attribute count 6')
cubit.cmd('block 2 attribute index 1 2') # flag for material: 2 for 2. material
cubit.cmd('block 2 attribute index 2 3000') # vp
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_only-nodoubling.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_only-nodoubling.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_only-nodoubling.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -77,7 +77,7 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
-cubit.cmd('block 1 name "acoustic" ') # acoustic material region
+cubit.cmd('block 1 name "acoustic 1" ') # acoustic material region
cubit.cmd('block 1 attribute count 4')
cubit.cmd('block 1 attribute index 1 1 ') # material 1
cubit.cmd('block 1 attribute index 2 1480 ') # vp
@@ -85,14 +85,14 @@
cubit.cmd('block 1 attribute index 4 1028 ') # rho (ocean salt water density:
# http://www.windows.ucar.edu/tour/link=/earth/Water/density.html
-cubit.cmd('block 2 name "acoustic" ') # acoustic material region
+cubit.cmd('block 2 name "acoustic 2" ') # acoustic material region
cubit.cmd('block 2 attribute count 4')
cubit.cmd('block 2 attribute index 1 2 ') # material 1
cubit.cmd('block 2 attribute index 2 1480 ') # vp
cubit.cmd('block 2 attribute index 3 0 ') # vs
cubit.cmd('block 2 attribute index 4 1028 ') # rho (ocean salt water density:
-cubit.cmd('block 3 name "acoustic" ') # acoustic material region
+cubit.cmd('block 3 name "acoustic 3" ') # acoustic material region
cubit.cmd('block 3 attribute count 4')
cubit.cmd('block 3 attribute index 1 3 ') # material 1
cubit.cmd('block 3 attribute index 2 1480 ') # vp
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2010-02-23 02:41:02 UTC (rev 16315)
@@ -88,6 +88,7 @@
$O/locate_source.o \
$O/generate_databases.o \
$O/netlib_specfun_erf.o \
+ $O/param_reader.o \
$O/prepare_assemble_MPI.o \
$O/read_topo_bathy_file.o \
$O/read_parameter_file.o \
@@ -101,8 +102,6 @@
$O/write_AVS_DX_global_faces_data.o \
$O/write_AVS_DX_surface_data.o \
$O/write_VTK_data.o \
- $O/write_seismograms.o \
- $O/compute_boundary_kernel.o \
$O/memory_eval.o \
$(EMPTY_MACRO)
@@ -130,16 +129,27 @@
SOLVER_ARRAY_OBJECTS = \
$O/specfem3D_par.o \
$O/PML_init.o \
- $O/compute_forces_no_Deville.o \
- $O/compute_forces_with_Deville.o \
+ $O/compute_boundary_kernel.o \
+ $O/compute_forces_acoustic.o \
+ $O/compute_forces_acoustic_pot.o \
+ $O/compute_forces_acoustic_PML.o \
$O/compute_forces_elastic.o \
- $O/compute_forces_acoustic_PML.o \
- $O/compute_forces_acoustic.o \
+ $O/compute_forces_elastic_Dev.o \
+ $O/compute_forces_elastic_noDev.o \
+ $O/compute_add_sources_acoustic.o \
+ $O/compute_add_sources_elastic.o \
+ $O/compute_coupling_acoustic_el.o \
+ $O/compute_coupling_elastic_ac.o \
+ $O/compute_stacey_acoustic.o \
+ $O/compute_stacey_elastic.o \
$O/compute_gradient.o \
+ $O/compute_interpolated_dva.o \
$O/initialize_simulation.o \
$O/read_mesh_databases.o \
$O/setup_GLL_points.o \
+ $O/write_movie_output.o \
$O/write_PNM_GIF_data.o \
+ $O/write_seismograms.o \
$O/detect_mesh_surfaces.o \
$O/setup_movie_meshes.o \
$O/read_topography_bathymetry.o \
@@ -147,6 +157,7 @@
$O/prepare_timerun.o \
$O/iterate_time.o \
$O/finalize_simulation.o \
+ $O/save_adjoint_kernels.o \
$O/specfem3D.o \
$O/assemble_MPI_vector.o \
$(EMPTY_MACRO)
@@ -225,8 +236,8 @@
#@COND_PYRE_FALSE at xcreate_movie_shakemap_AVS_DX_GMT: $O/create_movie_shakemap_AVS_DX_GMT.o $(LIBSPECFEM) OUTPUT_FILES/values_from_mesher.h
#@COND_PYRE_FALSE@ ${FCCOMPILE_CHECK} -o xcreate_movie_shakemap_AVS_DX_GMT $O/create_movie_shakemap_AVS_DX_GMT.o $(LIBSPECFEM)
- at COND_PYRE_FALSE@xcreate_movie_shakemap_AVS_DX_GMT: $O/create_movie_shakemap_AVS_DX_GMT.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o OUTPUT_FILES/surface_from_mesher.h
- at COND_PYRE_FALSE@ ${FCCOMPILE_CHECK} -o xcreate_movie_shakemap_AVS_DX_GMT $O/create_movie_shakemap_AVS_DX_GMT.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o
+ at COND_PYRE_FALSE@xcreate_movie_shakemap_AVS_DX_GMT: $O/create_movie_shakemap_AVS_DX_GMT.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o OUTPUT_FILES/surface_from_mesher.h $O/param_reader.o
+ at COND_PYRE_FALSE@ ${FCCOMPILE_CHECK} -o xcreate_movie_shakemap_AVS_DX_GMT $O/create_movie_shakemap_AVS_DX_GMT.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o $O/param_reader.o
@@ -237,15 +248,18 @@
xcheck_buffers_2D: $O/check_buffers_2D.o $(LIBSPECFEM)
${FCCOMPILE_CHECK} -o xcheck_buffers_2D $O/check_buffers_2D.o $(LIBSPECFEM)
-xcombine_vol_data: $O/combine_vol_data.o $O/write_c_binary.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o
- ${FCCOMPILE_CHECK} -o xcombine_vol_data $O/combine_vol_data.o $O/write_c_binary.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o
+xcombine_vol_data: $O/combine_vol_data.o $O/write_c_binary.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o $O/param_reader.o
+ ${FCCOMPILE_CHECK} -o xcombine_vol_data $O/combine_vol_data.o $O/write_c_binary.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o $O/param_reader.o
-xcombine_surf_data: $O/combine_surf_data.o $O/write_c_binary.o
- ${FCCOMPILE_CHECK} -o xcombine_surf_data $O/combine_surf_data.o $O/write_c_binary.o
+xcombine_surf_data: $O/combine_surf_data.o $O/write_c_binary.o $O/param_reader.o
+ ${FCCOMPILE_CHECK} -o xcombine_surf_data $O/combine_surf_data.o $O/write_c_binary.o $O/param_reader.o
clean:
- rm -f $O/* *.o *.gnu *.mod OUTPUT_FILES/timestamp* OUTPUT_FILES/starttime*txt work.pc* xgenerate_databases xspecfem3D xcombine_AVS_DX xcheck_buffers_2D xconvolve_source_timefunction xcreate_header_file xcreate_movie_shakemap_AVS_DX_GMT xcombine_vol_data xcombine_surf_data
+ rm -f $O/* *.o *.gnu *.mod OUTPUT_FILES/timestamp* OUTPUT_FILES/starttime*txt work.pc* \
+ xgenerate_databases xspecfem3D xcombine_AVS_DX xcheck_buffers_2D \
+ xconvolve_source_timefunction xcreate_header_file \
+ xcreate_movie_shakemap_AVS_DX_GMT xcombine_vol_data xcombine_surf_data
###
### rule for the archive library
@@ -267,6 +281,51 @@
$O/specfem3D_par.o: constants.h specfem3D_par.f90
${FCCOMPILE_NO_CHECK} -c -o $O/specfem3D_par.o specfem3D_par.f90
+$O/specfem3D.o: constants.h specfem3D.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/specfem3D.o specfem3D.f90
+
+$O/compute_forces_elastic_noDev.o: constants.h compute_forces_elastic_noDev.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_elastic_noDev.o compute_forces_elastic_noDev.f90
+
+$O/compute_forces_elastic_Dev.o: constants.h compute_forces_elastic_Dev.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_elastic_Dev.o compute_forces_elastic_Dev.f90
+
+$O/compute_forces_elastic.o: constants.h compute_forces_elastic.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_elastic.o compute_forces_elastic.f90
+
+$O/compute_forces_acoustic.o: constants.h compute_forces_acoustic.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_acoustic.o compute_forces_acoustic.f90
+
+$O/compute_forces_acoustic_pot.o: constants.h compute_forces_acoustic_pot.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_acoustic_pot.o compute_forces_acoustic_pot.f90
+
+$O/compute_forces_acoustic_PML.o: constants.h compute_forces_acoustic_PML.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_acoustic_PML.o compute_forces_acoustic_PML.f90
+
+$O/compute_add_sources_acoustic.o: constants.h compute_add_sources_acoustic.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_add_sources_acoustic.o compute_add_sources_acoustic.f90
+
+$O/compute_add_sources_elastic.o: constants.h compute_add_sources_elastic.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_add_sources_elastic.o compute_add_sources_elastic.f90
+
+$O/compute_coupling_acoustic_el.o: constants.h compute_coupling_acoustic_el.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_coupling_acoustic_el.o compute_coupling_acoustic_el.f90
+
+$O/compute_coupling_elastic_ac.o: constants.h compute_coupling_elastic_ac.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_coupling_elastic_ac.o compute_coupling_elastic_ac.f90
+
+$O/compute_stacey_acoustic.o: constants.h compute_stacey_acoustic.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_stacey_acoustic.o compute_stacey_acoustic.f90
+
+$O/compute_stacey_elastic.o: constants.h compute_stacey_elastic.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_stacey_elastic.o compute_stacey_elastic.f90
+
+$O/compute_gradient.o: constants.h compute_gradient.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_gradient.o compute_gradient.f90
+
+$O/compute_interpolated_dva.o: constants.h compute_interpolated_dva.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_interpolated_dva.o compute_interpolated_dva.f90
+
$O/initialize_simulation.o: constants.h initialize_simulation.f90
${FCCOMPILE_NO_CHECK} -c -o $O/initialize_simulation.o initialize_simulation.f90
@@ -303,6 +362,19 @@
$O/assemble_MPI_scalar.o: constants.h assemble_MPI_scalar.f90
${FCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_scalar.o assemble_MPI_scalar.f90
+$O/save_adjoint_kernels.o: constants.h save_adjoint_kernels.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/save_adjoint_kernels.o save_adjoint_kernels.f90
+
+$O/write_movie_output.o: constants.h write_movie_output.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/write_movie_output.o write_movie_output.f90
+
+$O/write_PNM_GIF_data.o: constants.h write_PNM_GIF_data.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/write_PNM_GIF_data.o write_PNM_GIF_data.f90
+
+$O/write_seismograms.o: constants.h write_seismograms.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/write_seismograms.o write_seismograms.f90
+
+
###
### MPI compilation without optimization
###
@@ -422,9 +494,6 @@
$O/write_VTK_data.o: constants.h write_VTK_data.f90
${FCCOMPILE_CHECK} -c -o $O/write_VTK_data.o write_VTK_data.f90
-$O/write_PNM_GIF_data.o: constants.h write_PNM_GIF_data.f90
- ${FCCOMPILE_CHECK} -c -o $O/write_PNM_GIF_data.o write_PNM_GIF_data.f90
-
$O/get_shape3D.o: constants.h get_shape3D.f90
${FCCOMPILE_CHECK} -c -o $O/get_shape3D.o get_shape3D.f90
@@ -449,9 +518,6 @@
$O/read_topo_bathy_file.o: constants.h read_topo_bathy_file.f90
${FCCOMPILE_CHECK} -c -o $O/read_topo_bathy_file.o read_topo_bathy_file.f90
-$O/write_seismograms.o: constants.h write_seismograms.f90
- ${FCCOMPILE_CHECK} -c -o $O/write_seismograms.o write_seismograms.f90
-
$O/lagrange_poly.o: constants.h lagrange_poly.f90
${FCCOMPILE_CHECK} -c -o $O/lagrange_poly.o lagrange_poly.f90
@@ -491,30 +557,10 @@
$O/PML_init.o: constants.h PML_init.f90
${FCCOMPILE_CHECK} -c -o $O/PML_init.o PML_init.f90
-### compilation with optimization
-$O/specfem3D.o: constants.h specfem3D.f90
- ${FCCOMPILE_NO_CHECK} -c -o $O/specfem3D.o specfem3D.f90
-$O/compute_forces_no_Deville.o: constants.h compute_forces_no_Deville.f90
- ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_no_Deville.o compute_forces_no_Deville.f90
-$O/compute_forces_with_Deville.o: constants.h compute_forces_with_Deville.f90
- ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_with_Deville.o compute_forces_with_Deville.f90
-$O/compute_forces_elastic.o: constants.h compute_forces_elastic.f90
- ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_elastic.o compute_forces_elastic.f90
-
-$O/compute_forces_acoustic.o: constants.h compute_forces_acoustic.f90
- ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_acoustic.o compute_forces_acoustic.f90
-
-$O/compute_forces_acoustic_PML.o: constants.h compute_forces_acoustic_PML.f90
- ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_acoustic_PML.o compute_forces_acoustic_PML.f90
-
-$O/compute_gradient.o: constants.h compute_gradient.f90
- ${FCCOMPILE_NO_CHECK} -c -o $O/compute_gradient.o compute_gradient.f90
-
-
###
### all obsolete files ?
###
@@ -582,6 +628,9 @@
### C files below
###
+$O/param_reader.o: param_reader.c
+ ${CC} -c $(CFLAGS) -o $O/param_reader.o param_reader.c
+
$O/write_c_binary.o: write_c_binary.c
- cc -c -o $O/write_c_binary.o write_c_binary.c
+ ${CC} -c $(CFLAGS) -o $O/write_c_binary.o write_c_binary.c
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/mesh2vtu/Makefile
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/mesh2vtu/Makefile 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/mesh2vtu/Makefile 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,10 +1,20 @@
+# Makefile
+#############################################################
+## modify to match your compiler defaults
CXX=g++
+
+## modify to match your library paths
+# VTK libraries
VTK=/opt/seismo-util
-INCLUDES=-I$(VTK)/include
-CPPFLAGS=$(INCLUDES) -Wno-deprecated
LIBS=-L$(VTK)/lib/vtk -lvtkCommon -lvtkIO -lvtkRendering -lvtkFiltering -lvtkGraphics
+INCLUDES=-I$(VTK)/include -I$(VTK)/include/vtk
+CPPFLAGS=$(INCLUDES) -Wno-deprecated
+
+#############################################################
+
+
all: mesh2vtu ugrid ugrid_pts
mesh2vtu: mesh2vtu.o
Added: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cut_velocity/Makefile
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cut_velocity/Makefile (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cut_velocity/Makefile 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,29 @@
+# Makefile
+
+#############################################################
+## modify to match your compiler defaults
+
+# compilers
+F90 = gfortran
+CC = gcc
+
+#############################################################
+
+
+LIB_OBJS = cut_velocity.o rw_ascfile_c.o
+
+# targets
+all: xcut_velocity
+
+xcut_velocity: $(LIB_OBJS)
+ ${F90} -Wall -o xcut_velocity $(LIB_OBJS)
+
+cut_velocity.o: cut_velocity.f90
+ ${F90} -Wall -c cut_velocity.f90
+
+rw_ascfile_c.o: ../lib/rw_ascfile_c.c
+ ${CC} -c -o rw_ascfile_c.o ../lib/rw_ascfile_c.c
+
+
+clean:
+ rm -f *.o xcut_velocity
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cut_velocity/cut_velocity.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cut_velocity/cut_velocity.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/cut_velocity/cut_velocity.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,13 +1,16 @@
program cut_velocity
-! this program cuts certain portion of the seismograms and convert them into
-! the adjoints sources for generating banana-dougnut kernels.
+! this program cuts certain portion of the seismograms and converts them into
+! the adjoint sources for generating banana-dougnut kernels.
! Qinya Liu, Caltech, May 2007
-
+!
+! call by: ./xcut_velocity t1 t2 ifile[0-5] E/N/Z-ascii-files [baz]
+!
implicit none
- integer :: i, nfile, is, ie, nstep, j, itime ,ifile,ios, i1, i2, nstep_old
- character(len=100) :: arg(100), file(100)
+ integer :: i, is, ie, nstep, j, itime ,ifile,ios, i1, i2, nstep_old
+ character(len=256) :: arg(100), file(100)
+ character(len=256) :: filename
integer,parameter :: NMAX = 30000
real*8, parameter :: EPS = 1.0d-17
real*8, parameter :: PI = 3.1415926d0
@@ -18,9 +21,25 @@
i = 1
lrot = .false.
+ ! reads in file arguments
do while (1 == 1)
call getarg(i,arg(i))
- if (i < 6 .and. trim(arg(i)) == '') stop 'cut_velocity t1 t2 ifile[0-5] E/N/Z-ascii-files [baz]'
+ if (i < 6 .and. trim(arg(i)) == '') then
+ print*,'Usage: '
+ print*,' xcut_velocity t1 t2 ifile[0-5] E/N/Z-ascii-files [baz]'
+ print*,'with'
+ print*,' t1: window start time'
+ print*,' t2: window end time'
+ print*,' ifile: 0 = adjoint source calculated for each seismogram component'
+ print*,' ifile: 1 = adjoint source given by East component only'
+ print*,' ifile: 2 = adjoint source given by North component'
+ print*,' ifile: 3 = adjoint source given by Z component'
+ print*,' ifile: 4 = adjoint source given by rotated transversal component (requires baz)'
+ print*,' ifile: 5 = adjoint source given by rotated radial component (requires baz)'
+ print*,' E/N/Z-ascii-files : displacement traces stored as ascii files'
+ print*,' [baz]: (optional) back-azimuth, requires ifile = 4 or ifile = 5'
+ stop 'cut_velocity t1 t2 ifile[0-5] E/N/Z-ascii-files [baz]'
+ endif
if (trim(arg(i)) == '') exit
if (i == 1) then
read(arg(i),*,iostat=ios) ts
@@ -43,6 +62,7 @@
i = i + 1
enddo
+ ! checks rotation baz and ifile parameter
i = i - 1
if (lrot) then
if (i /= 7) stop 'cut_velocity t1 t2 ifile[0-5] E/N/Z-ascii-files [baz]'
@@ -55,52 +75,73 @@
if (i /= 6) stop 'cut_velocity t1 t2 ifile[0-5] E/N/Z-ascii-files [baz]'
endif
+ ! user output
print *, 'ifile = ', ifile, ' lrot = ', lrot
print *, ' '
-
+ ! reads seismograms (ascii format)
do i = 1, 3
- print *, 'reading asc file '//trim(file(i))//' ...'
- call dread_ascfile_f(file(i),t0,dt,nstep,data(i,:))
+ filename = trim(file(i))
+ print *, 'reading asc file '//trim(filename)//' ...'
+ call dread_ascfile_c(trim(filename)//char(0),t0,dt,nstep,data(i,:))
if (nstep > NMAX) stop 'Change the data array range limit'
if (i == 1) then
t0_old = t0; dt_old = dt; nstep_old = nstep
else
- if (i > 1 .and. abs(t0_old - t0) > EPS .and. abs(dt_old - dt) > EPS .and. nstep_old /= nstep) &
+ if (i > 1 .and. abs(t0_old - t0) > EPS &
+ .and. abs(dt_old - dt) > EPS &
+ .and. nstep_old /= nstep) &
stop 'Error different t0, dt, nstep'
endif
enddo
+ print *, ' '
+ print *, 'start time:',t0
+ print *, 'time step:',dt
+ print *, 'number of steps:',nstep
+ print *, ' '
+ ! component rotation
if (lrot) then
data(4,:) = costh * data(1,:) - sinth * data(2,:)
data(5,:) = sinth * data(1,:) + costh * data(2,:)
- call dwrite_ascfile_f('t.txt',t0,dt,nstep,data(4,:))
- call dwrite_ascfile_f('r.txt',t0,dt,nstep,data(5,:))
+ call dwrite_ascfile_c('t.txt',t0,dt,nstep,data(4,:))
+ call dwrite_ascfile_c('r.txt',t0,dt,nstep,data(5,:))
i1 = 3; i2 = 5
else
i1 = 1; i2 = 3
endif
-
+ ! loops over seismogram components
do i = i1, i2
+ ! start and end index
is = (ts - t0) / dt + 1
ie = (te - t0) / dt + 1
if (is < 1 .or. ie <= is .or. ie > nstep) then
print *, 'Error in ts, te'; stop
endif
+
+ ! time window (parabola shaped)
tw(1:nstep) = 0.
+ if( i == i1 ) open(44,file='plot_time_window.txt',status='unknown')
do j = is, ie
tw(j) = 1 - (2 * (dble(j) - is)/(ie - is) - 1) ** 2
+ if( i == i1 ) write(44,*) j,tw(j)
enddo
+ if( i == i1 ) close(44)
+
+ ! calculates velocity (by finite-differences)
do itime = 2, nstep-1
out(itime) = (data(i,itime+1) - data(i,itime-1)) / (2 * dt)
enddo
out(1) = (data(i,2) - data(i,1)) / dt
out(nstep) = (data(i,nstep) - data(i,nstep-1)) /dt
+
+ ! normalization factor
norm = dt * sum( tw(1:nstep) * out(1:nstep) * out(1:nstep))
print *, 'i = ', i, 'norm = ', norm
if (ifile /= 0 .and. ifile /= i) norm = 0.0
-
+
+ ! adjoint source
if (abs(norm) > EPS) then
adj(1:nstep) = - out(1:nstep) * tw(1:nstep) / norm
else
@@ -108,18 +149,25 @@
adj(:) = 0.
endif
data(i,:) = adj(:)
+
enddo
+ print *, ' '
+ ! component rotation back to cartesian x-y-z
if (lrot) then
- call dwrite_ascfile_f('t-cut.txt',t0,dt,nstep,data(4,:))
- call dwrite_ascfile_f('r-cut.txt',t0,dt,nstep,data(5,:))
+ call dwrite_ascfile_c('t-cut.txt',t0,dt,nstep,data(4,:))
+ call dwrite_ascfile_c('r-cut.txt',t0,dt,nstep,data(5,:))
data(1,:) = costh * data(4,:) + sinth * data(5,:)
data(2,:) = -sinth * data(4,:) + costh * data(5,:)
endif
+ ! file output for component BHE/BHN/BHZ
do i = 1, 3
- print *, 'write to asc file '//trim(file(i))//'.ad'
- call dwrite_ascfile_f(trim(file(i))//'.ad',t0,dt,nstep,data(i,:))
+ filename = trim(file(i))//'.adj'
+ print *, 'write to asc file '//trim(filename)
+ call dwrite_ascfile_c(trim(filename)//char(0),t0,dt,nstep,data(i,:))
enddo
end program cut_velocity
+
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/go_mesher_solver_lsf_basin.kernel
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/go_mesher_solver_lsf_basin.kernel 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/go_mesher_solver_lsf_basin.kernel 2010-02-23 02:41:02 UTC (rev 16315)
@@ -29,11 +29,11 @@
cd $current_pwd/SEM
collect_seismo_lsf_multi.pl ../OUTPUT_FILES/lsf_machines ../DATA/Par_file
xcut_velocity 29.0 32.5 3 GSC*.semd
-rename .semd.ad .adj *.semd.ad
+rename .semd.adj .adj *.semd.ad
cd $current_pwd
##########################################################################
-#change_simulation_type.pl -b
+change_simulation_type.pl -b
mpirun.lsf --gm-no-shmem --gm-copy-env $current_pwd/xspecfem3D
shmux -M50 -Sall -c "cp $BASEMPIDIR.$LSB_JOBID/*alpha_kernel.bin $current_pwd/MESH" - < OUTPUT_FILES/machines >/dev/null
Added: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/Makefile
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/Makefile (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/Makefile 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,38 @@
+# Makefile
+
+#############################################################
+## modify to match your compiler defaults
+
+F90 = gfortran
+CC = gcc
+
+#############################################################
+
+
+F90FLAGS = -O2
+CCFLAGS = -O2
+
+CSRC = rw_ascfile_c
+F90SRC = rw_ascfile_f
+
+F90OBJ = $(patsubst %,%.o,$(F90SRC))
+COBJ = $(patsubst %,%.o,$(CSRC))
+OBJ = $(F90OBJ) $(COBJ)
+
+
+all : lib
+
+lib : $(OBJ)
+
+
+$(F90OBJ) : %.o : %.f90
+ $(F90) $(F90FLAGS) -c $*.f90
+
+$(COBJ): %.o : %.c
+ $(CC) $(CCFLAGS) -c $*.c
+
+clean:
+ \rm -f $(OBJS) *~ *.o
+
+cleanall:
+ \rm -f $(OBJS) *.o *~
Added: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/drw_ascfile.h
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/drw_ascfile.h (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/drw_ascfile.h 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,30 @@
+// Qinya Liu, May 2007, Caltech
+#ifndef _drw_ascfile_h
+#define _drw_ascfile_h
+
+void dread_ascfile(const char *ascfile,
+ double *t0, double *dt, int *n,
+ double *data);
+void dwrite_ascfile(const char *ascfile,
+ double *t0, double *dt, int *n,
+ const double *data);
+
+void dread_ascfile_c(const char *ascfile,
+ double *t0, double *dt, int *n,
+ double *data);
+void dwrite_ascfile_c(const char *ascfile,
+ const double *t0, const double *dt, const int *n,
+ const double *data);
+
+void DREAD_ASCFILE_C(const char *ascfile,
+ double *t0, double *dt, int *n,
+ double *data);
+void DWRITE_ASCFILE_C(const char *ascfile,
+ const double *t0, const double *dt, const int *n,
+ const double *data);
+
+
+
+
+
+#endif
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/rw_ascfile_c.c
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/rw_ascfile_c.c 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/rw_ascfile_c.c 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,9 +1,10 @@
#include <stdio.h>
-#include "drw_ascfile.h"
+#include <stdlib.h>
+//#include "drw_ascfile.h"
// Qinya Liu, Caltech, May 2007
-void dread_ascfile(const char *ascfile,
+void dread_ascfile_c_(const char *ascfile,
double *t0, double *dt, int *n,
double *data)
@@ -20,33 +21,41 @@
while ( fscanf(fd,"%lf %lf\n",&junk, data+i) != EOF ) {
if (i == 0) junk1 = junk;
if (i == 1) *dt = junk - junk1;
- i++;}
+ i++;
+ }
*t0 = junk1;
*n = i;
if (fclose(fd) != 0) {
printf(" file %s cannot be closed\n",ascfile);
- exit(1);}
+ exit(1);
+ }
}
-void dwrite_ascfile(const char *ascfile,
- double t0, double dt, int n,
+void dwrite_ascfile_c_(const char *ascfile,
+ double *t0, double *dt, int *n,
const double *data)
{
FILE *fd;
int i;
+ double tmp,tmp0;
+ //printf("t0: %f ,dt: %f ,n: %i \n",*t0,*dt,*n);
+
if ((fd = fopen(ascfile,"w")) == NULL) {
printf(" file %s cannot be opened to write\n",ascfile);
exit(1);
}
i = 0;
- for (i=0; i<n; i++) {
- fprintf(fd,"%14.7g %18.7g\n", t0+i*dt, data[i]);
+ tmp = *dt;
+ tmp0 = *t0;
+ for (i=0; i< *n; i++) {
+ fprintf(fd,"%14.7g %18.7g\n", tmp0+i*tmp, data[i]);
}
if (fclose(fd) != 0) {
printf("file %s cannot be closed\n",ascfile);
- exit(1);}
+ exit(1);
+ }
}
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/rw_ascfile_f.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/rw_ascfile_f.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/lib/rw_ascfile_f.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -24,6 +24,8 @@
real*8 :: t0, dt, data(*)
integer :: n
+ print *,'asc_f:',t0,dt,n
+
call dwrite_ascfile_c(trim(name)//char(0), t0, dt, n, data)
end subroutine dwrite_ascfile_f
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -133,6 +133,8 @@
request_send_vector_ext_mesh,request_recv_vector_ext_mesh &
)
+! sends data
+
implicit none
include "constants.h"
@@ -153,8 +155,6 @@
integer ipoin,iinterface
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
! here we have to assemble all the contributions between partitions using MPI
! assemble only if more than one partition
@@ -196,6 +196,8 @@
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+! waits for data to receive and assembles
+
implicit none
include "constants.h"
@@ -216,8 +218,6 @@
integer ipoin,iinterface
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
! here we have to assemble all the contributions between partitions using MPI
! assemble only if more than one partition
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/calc_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/calc_jacobian.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/calc_jacobian.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -161,203 +161,203 @@
! output: xixstore,xiystore,xizstore,
! etaxstore,etaystore,etazstore,
! gammaxstore,gammaystore,gammazstore ------ parameters used for calculating jacobian
-
-
- subroutine recalc_jacobian_gll3D(myrank,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore,jacobianstore, &
- xstore,ystore,zstore, &
- ispec,nspec, &
- xigll,yigll,zigll, &
- ACTUALLY_STORE_ARRAYS)
-
- implicit none
-
- include "constants.h"
-
- ! input parameter
- integer::myrank,ispec,nspec
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision, dimension(NGLLX):: xigll
- double precision, dimension(NGLLY):: yigll
- double precision, dimension(NGLLZ):: zigll
- logical::ACTUALLY_STORE_ARRAYS
-
-
- ! output results
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xixstore,xiystore,xizstore,&
- etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore,&
- jacobianstore
-
-
- ! other parameters for this subroutine
- integer:: i,j,k,i1,j1,k1
- double precision:: xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
- double precision:: xi,eta,gamma
- double precision,dimension(NGLLX):: hxir,hpxir
- double precision,dimension(NGLLY):: hetar,hpetar
- double precision,dimension(NGLLZ):: hgammar,hpgammar
- double precision:: hlagrange,hlagrange_xi,hlagrange_eta,hlagrange_gamma
- double precision:: jacobian
- double precision:: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-
-
-
- ! test parameters which can be deleted
- double precision:: xmesh,ymesh,zmesh
- double precision:: sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
-
- ! first go over all 125 gll points
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- xxi = 0.0
- xeta = 0.0
- xgamma = 0.0
- yxi = 0.0
- yeta = 0.0
- ygamma = 0.0
- zxi = 0.0
- zeta = 0.0
- zgamma = 0.0
-
- xi = xigll(i)
- eta = yigll(j)
- gamma = zigll(k)
-
- ! calculate lagrange polynomial and its derivative
- call lagrange_any(xi,NGLLX,xigll,hxir,hpxir)
- call lagrange_any(eta,NGLLY,yigll,hetar,hpetar)
- call lagrange_any(gamma,NGLLZ,zigll,hgammar,hpgammar)
-
- ! test parameters
- sumshape = 0.0
- sumdershapexi = 0.0
- sumdershapeeta = 0.0
- sumdershapegamma = 0.0
- xmesh = 0.0
- ymesh = 0.0
- zmesh = 0.0
-
-
- do k1 = 1,NGLLZ
- do j1 = 1,NGLLY
- do i1 = 1,NGLLX
- hlagrange = hxir(i1)*hetar(j1)*hgammar(k1)
- hlagrange_xi = hpxir(i1)*hetar(j1)*hgammar(k1)
- hlagrange_eta = hxir(i1)*hpetar(j1)*hgammar(k1)
- hlagrange_gamma = hxir(i1)*hetar(j1)*hpgammar(k1)
-
-
- xxi = xxi + xstore(i1,j1,k1,ispec)*hlagrange_xi
- xeta = xeta + xstore(i1,j1,k1,ispec)*hlagrange_eta
- xgamma = xgamma + xstore(i1,j1,k1,ispec)*hlagrange_gamma
-
- yxi = yxi + ystore(i1,j1,k1,ispec)*hlagrange_xi
- yeta = yeta + ystore(i1,j1,k1,ispec)*hlagrange_eta
- ygamma = ygamma + ystore(i1,j1,k1,ispec)*hlagrange_gamma
-
- zxi = zxi + zstore(i1,j1,k1,ispec)*hlagrange_xi
- zeta = zeta + zstore(i1,j1,k1,ispec)*hlagrange_eta
- zgamma = zgamma + zstore(i1,j1,k1,ispec)*hlagrange_gamma
-
- ! test the lagrange polynomial and its derivate
- xmesh = xmesh + xstore(i1,j1,k1,ispec)*hlagrange
- ymesh = ymesh + ystore(i1,j1,k1,ispec)*hlagrange
- zmesh = zmesh + zstore(i1,j1,k1,ispec)*hlagrange
- sumshape = sumshape + hlagrange
- sumdershapexi = sumdershapexi + hlagrange_xi
- sumdershapeeta = sumdershapeeta + hlagrange_eta
- sumdershapegamma = sumdershapegamma + hlagrange_gamma
-
- end do
- end do
- end do
-
- ! Check the lagrange polynomial and its derivative
- if (xmesh /=xstore(i,j,k,ispec).or.ymesh/=ystore(i,j,k,ispec).or.zmesh/=zstore(i,j,k,ispec)) then
- call exit_MPI(myrank,'new mesh positions are wrong in recalc_jacobian_gall3D.f90')
- end if
- if(abs(sumshape-one) > TINYVAL) then
- call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll3D.f90')
- end if
- if(abs(sumdershapexi) > TINYVAL) then
- call exit_MPI(myrank,'error derivative xi shape functions in recalc_jacobian_gll3D.f90')
- end if
- if(abs(sumdershapeeta) > TINYVAL) then
- call exit_MPI(myrank,'error derivative eta shape functions in recalc_jacobian_gll3D.f90')
- end if
- if(abs(sumdershapegamma) > TINYVAL) then
- call exit_MPI(myrank,'error derivative gamma shape functions in recalc_jacobian_gll3D.f90')
- end if
-
-
- jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
- xeta*(yxi*zgamma-ygamma*zxi) + &
- xgamma*(yxi*zeta-yeta*zxi)
-
- ! Check the jacobian
- if(jacobian <= ZERO) then
- call exit_MPI(myrank,'3D Jacobian undefined in recalc_jacobian_gll3D.f90')
- end if
-
- ! invert the relation (Fletcher p. 50 vol. 2)
- xix = (yeta*zgamma-ygamma*zeta) / jacobian
- xiy = (xgamma*zeta-xeta*zgamma) / jacobian
- xiz = (xeta*ygamma-xgamma*yeta) / jacobian
- etax = (ygamma*zxi-yxi*zgamma) / jacobian
- etay = (xxi*zgamma-xgamma*zxi) / jacobian
- etaz = (xgamma*yxi-xxi*ygamma) / jacobian
- gammax = (yxi*zeta-yeta*zxi) / jacobian
- gammay = (xeta*zxi-xxi*zeta) / jacobian
- gammaz = (xxi*yeta-xeta*yxi) / jacobian
-
-
- ! compute and store the jacobian for the solver
- jacobian = 1. / (xix*(etay*gammaz-etaz*gammay) &
- -xiy*(etax*gammaz-etaz*gammax) &
- +xiz*(etax*gammay-etay*gammax))
-
- ! resave the derivatives and the jacobian
- ! distinguish between single and double precision for reals
- if (ACTUALLY_STORE_ARRAYS) then
-
- if (myrank == 0) then
- print*,'xix before',xixstore(i,j,k,ispec),'after',xix
- print*,'etax before',etaxstore(i,j,k,ispec),'after',etax
- print*,'gammax before',gammaxstore(i,j,k,ispec),'after',gammax
- end if
-
- if(CUSTOM_REAL == SIZE_REAL) then
- xixstore(i,j,k,ispec) = sngl(xix)
- xiystore(i,j,k,ispec) = sngl(xiy)
- xizstore(i,j,k,ispec) = sngl(xiz)
- etaxstore(i,j,k,ispec) = sngl(etax)
- etaystore(i,j,k,ispec) = sngl(etay)
- etazstore(i,j,k,ispec) = sngl(etaz)
- gammaxstore(i,j,k,ispec) = sngl(gammax)
- gammaystore(i,j,k,ispec) = sngl(gammay)
- gammazstore(i,j,k,ispec) = sngl(gammaz)
- jacobianstore(i,j,k,ispec) = sngl(jacobian)
- else
- xixstore(i,j,k,ispec) = xix
- xiystore(i,j,k,ispec) = xiy
- xizstore(i,j,k,ispec) = xiz
- etaxstore(i,j,k,ispec) = etax
- etaystore(i,j,k,ispec) = etay
- etazstore(i,j,k,ispec) = etaz
- gammaxstore(i,j,k,ispec) = gammax
- gammaystore(i,j,k,ispec) = gammay
- gammazstore(i,j,k,ispec) = gammaz
- jacobianstore(i,j,k,ispec) = jacobian
- endif
- end if
- enddo
- enddo
- enddo
-
- end subroutine recalc_jacobian_gll3D
-
+!
+!
+! subroutine recalc_jacobian_gll3D(myrank,xixstore,xiystore,xizstore, &
+! etaxstore,etaystore,etazstore, &
+! gammaxstore,gammaystore,gammazstore,jacobianstore, &
+! xstore,ystore,zstore, &
+! ispec,nspec, &
+! xigll,yigll,zigll, &
+! ACTUALLY_STORE_ARRAYS)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! ! input parameter
+! integer::myrank,ispec,nspec
+! double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+! double precision, dimension(NGLLX):: xigll
+! double precision, dimension(NGLLY):: yigll
+! double precision, dimension(NGLLZ):: zigll
+! logical::ACTUALLY_STORE_ARRAYS
+!
+!
+! ! output results
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+! xixstore,xiystore,xizstore,&
+! etaxstore,etaystore,etazstore,&
+! gammaxstore,gammaystore,gammazstore,&
+! jacobianstore
+!
+!
+! ! other parameters for this subroutine
+! integer:: i,j,k,i1,j1,k1
+! double precision:: xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
+! double precision:: xi,eta,gamma
+! double precision,dimension(NGLLX):: hxir,hpxir
+! double precision,dimension(NGLLY):: hetar,hpetar
+! double precision,dimension(NGLLZ):: hgammar,hpgammar
+! double precision:: hlagrange,hlagrange_xi,hlagrange_eta,hlagrange_gamma
+! double precision:: jacobian
+! double precision:: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+!
+!
+!
+! ! test parameters which can be deleted
+! double precision:: xmesh,ymesh,zmesh
+! double precision:: sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
+!
+! ! first go over all 125 gll points
+! do k=1,NGLLZ
+! do j=1,NGLLY
+! do i=1,NGLLX
+!
+! xxi = 0.0
+! xeta = 0.0
+! xgamma = 0.0
+! yxi = 0.0
+! yeta = 0.0
+! ygamma = 0.0
+! zxi = 0.0
+! zeta = 0.0
+! zgamma = 0.0
+!
+! xi = xigll(i)
+! eta = yigll(j)
+! gamma = zigll(k)
+!
+! ! calculate lagrange polynomial and its derivative
+! call lagrange_any(xi,NGLLX,xigll,hxir,hpxir)
+! call lagrange_any(eta,NGLLY,yigll,hetar,hpetar)
+! call lagrange_any(gamma,NGLLZ,zigll,hgammar,hpgammar)
+!
+! ! test parameters
+! sumshape = 0.0
+! sumdershapexi = 0.0
+! sumdershapeeta = 0.0
+! sumdershapegamma = 0.0
+! xmesh = 0.0
+! ymesh = 0.0
+! zmesh = 0.0
+!
+!
+! do k1 = 1,NGLLZ
+! do j1 = 1,NGLLY
+! do i1 = 1,NGLLX
+! hlagrange = hxir(i1)*hetar(j1)*hgammar(k1)
+! hlagrange_xi = hpxir(i1)*hetar(j1)*hgammar(k1)
+! hlagrange_eta = hxir(i1)*hpetar(j1)*hgammar(k1)
+! hlagrange_gamma = hxir(i1)*hetar(j1)*hpgammar(k1)
+!
+!
+! xxi = xxi + xstore(i1,j1,k1,ispec)*hlagrange_xi
+! xeta = xeta + xstore(i1,j1,k1,ispec)*hlagrange_eta
+! xgamma = xgamma + xstore(i1,j1,k1,ispec)*hlagrange_gamma
+!
+! yxi = yxi + ystore(i1,j1,k1,ispec)*hlagrange_xi
+! yeta = yeta + ystore(i1,j1,k1,ispec)*hlagrange_eta
+! ygamma = ygamma + ystore(i1,j1,k1,ispec)*hlagrange_gamma
+!
+! zxi = zxi + zstore(i1,j1,k1,ispec)*hlagrange_xi
+! zeta = zeta + zstore(i1,j1,k1,ispec)*hlagrange_eta
+! zgamma = zgamma + zstore(i1,j1,k1,ispec)*hlagrange_gamma
+!
+! ! test the lagrange polynomial and its derivate
+! xmesh = xmesh + xstore(i1,j1,k1,ispec)*hlagrange
+! ymesh = ymesh + ystore(i1,j1,k1,ispec)*hlagrange
+! zmesh = zmesh + zstore(i1,j1,k1,ispec)*hlagrange
+! sumshape = sumshape + hlagrange
+! sumdershapexi = sumdershapexi + hlagrange_xi
+! sumdershapeeta = sumdershapeeta + hlagrange_eta
+! sumdershapegamma = sumdershapegamma + hlagrange_gamma
+!
+! end do
+! end do
+! end do
+!
+! ! Check the lagrange polynomial and its derivative
+! if (xmesh /=xstore(i,j,k,ispec).or.ymesh/=ystore(i,j,k,ispec).or.zmesh/=zstore(i,j,k,ispec)) then
+! call exit_MPI(myrank,'new mesh positions are wrong in recalc_jacobian_gall3D.f90')
+! end if
+! if(abs(sumshape-one) > TINYVAL) then
+! call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll3D.f90')
+! end if
+! if(abs(sumdershapexi) > TINYVAL) then
+! call exit_MPI(myrank,'error derivative xi shape functions in recalc_jacobian_gll3D.f90')
+! end if
+! if(abs(sumdershapeeta) > TINYVAL) then
+! call exit_MPI(myrank,'error derivative eta shape functions in recalc_jacobian_gll3D.f90')
+! end if
+! if(abs(sumdershapegamma) > TINYVAL) then
+! call exit_MPI(myrank,'error derivative gamma shape functions in recalc_jacobian_gll3D.f90')
+! end if
+!
+!
+! jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+! xeta*(yxi*zgamma-ygamma*zxi) + &
+! xgamma*(yxi*zeta-yeta*zxi)
+!
+! ! Check the jacobian
+! if(jacobian <= ZERO) then
+! call exit_MPI(myrank,'3D Jacobian undefined in recalc_jacobian_gll3D.f90')
+! end if
+!
+! ! invert the relation (Fletcher p. 50 vol. 2)
+! xix = (yeta*zgamma-ygamma*zeta) / jacobian
+! xiy = (xgamma*zeta-xeta*zgamma) / jacobian
+! xiz = (xeta*ygamma-xgamma*yeta) / jacobian
+! etax = (ygamma*zxi-yxi*zgamma) / jacobian
+! etay = (xxi*zgamma-xgamma*zxi) / jacobian
+! etaz = (xgamma*yxi-xxi*ygamma) / jacobian
+! gammax = (yxi*zeta-yeta*zxi) / jacobian
+! gammay = (xeta*zxi-xxi*zeta) / jacobian
+! gammaz = (xxi*yeta-xeta*yxi) / jacobian
+!
+!
+! ! compute and store the jacobian for the solver
+! jacobian = 1. / (xix*(etay*gammaz-etaz*gammay) &
+! -xiy*(etax*gammaz-etaz*gammax) &
+! +xiz*(etax*gammay-etay*gammax))
+!
+! ! resave the derivatives and the jacobian
+! ! distinguish between single and double precision for reals
+! if (ACTUALLY_STORE_ARRAYS) then
+!
+! if (myrank == 0) then
+! print*,'xix before',xixstore(i,j,k,ispec),'after',xix
+! print*,'etax before',etaxstore(i,j,k,ispec),'after',etax
+! print*,'gammax before',gammaxstore(i,j,k,ispec),'after',gammax
+! end if
+!
+! if(CUSTOM_REAL == SIZE_REAL) then
+! xixstore(i,j,k,ispec) = sngl(xix)
+! xiystore(i,j,k,ispec) = sngl(xiy)
+! xizstore(i,j,k,ispec) = sngl(xiz)
+! etaxstore(i,j,k,ispec) = sngl(etax)
+! etaystore(i,j,k,ispec) = sngl(etay)
+! etazstore(i,j,k,ispec) = sngl(etaz)
+! gammaxstore(i,j,k,ispec) = sngl(gammax)
+! gammaystore(i,j,k,ispec) = sngl(gammay)
+! gammazstore(i,j,k,ispec) = sngl(gammaz)
+! jacobianstore(i,j,k,ispec) = sngl(jacobian)
+! else
+! xixstore(i,j,k,ispec) = xix
+! xiystore(i,j,k,ispec) = xiy
+! xizstore(i,j,k,ispec) = xiz
+! etaxstore(i,j,k,ispec) = etax
+! etaystore(i,j,k,ispec) = etay
+! etazstore(i,j,k,ispec) = etaz
+! gammaxstore(i,j,k,ispec) = gammax
+! gammaystore(i,j,k,ispec) = gammay
+! gammazstore(i,j,k,ispec) = gammaz
+! jacobianstore(i,j,k,ispec) = jacobian
+! endif
+! end if
+! enddo
+! enddo
+! enddo
+!
+! end subroutine recalc_jacobian_gll3D
+!
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -53,10 +53,7 @@
logical:: DT_PRESENT
- integer :: myrank
-
-!! DK DK May 2009: added this to print the minimum and maximum number of elements
-!! DK DK May 2009: and points in the CUBIT + SCOTCH mesh
+ integer :: myrank
integer :: NSPEC_AB_global_min,NSPEC_AB_global_max,NSPEC_AB_global_sum
integer :: NGLOB_AB_global_min,NGLOB_AB_global_max,NGLOB_AB_global_sum
integer :: i,j,k,ispec,iglob_a,iglob_b,sizeprocs
@@ -66,7 +63,7 @@
real(kind=CUSTOM_REAL),parameter :: NELEM_PER_WAVELENGTH = 1.5
logical :: has_vs_zero
-! initializes
+! initializations
if( DT <= 0.0d0) then
DT_PRESENT = .false.
else
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -357,7 +357,7 @@
! get source information for frequency for number of points per lambda
print *,'reading source duration from the CMTSOLUTION file'
- call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,NSOURCES)
+ call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,NSOURCES)
! set global element and point offsets to zero
iglobpointoffset = 0
@@ -580,7 +580,7 @@
! get source information
print *,'reading position of the source from the CMTSOLUTION file'
- call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,NSOURCES)
+ call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,NSOURCES)
! the point for the source is put at the surface for clarity (depth ignored)
! even slightly above to superimpose to real surface
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -25,49 +25,45 @@
program combine_paraview_data_ext_mesh
-! puts the output of SPECFEM3D in ParaView format.
-! see http://www.paraview.org for details
-
+! puts the output of SPECFEM3D into '***.mesh' format,
+! which can be converted via mesh2vtu into ParaView format.
+!
+! for Paraview, see http://www.paraview.org for details
+!
! combines the database files on several slices.
! the local database file needs to have been collected onto the frontend (copy_local_database.pl)
-
+!
! works for external, unregular meshes
implicit none
include 'constants.h'
-! include 'OUTPUT_FILES/values_from_mesher.h'
-! comment next line if using old basin version
- integer :: NSPEC_AB, NGLOB_AB
-
-! parameters
! data must be of dimension: (NGLLX,NGLLY,NGLLZ,NSPEC_AB)
real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable :: data
+ ! real array for data
+ real,dimension(:,:,:,:),allocatable :: dat
! mesh coordinates
real(kind=CUSTOM_REAL),dimension(:),allocatable :: xstore, ystore, zstore
-
integer, dimension(:,:,:,:),allocatable :: ibool
- logical, dimension(:),allocatable :: mask_ibool
- integer,dimension(:),allocatable :: num_ibool
- real,dimension(:,:,:,:),allocatable :: dat
-
+
+ integer :: NSPEC_AB, NGLOB_AB
integer :: numpoin
integer :: i, ios, it
- integer :: iproc, proc1, proc2, num_node, node_list(300), nspec, nglob
+ integer :: iproc, proc1, proc2, num_node, node_list(300)
integer :: np, ne, npp, nee, nelement, njunk
character(len=256) :: sline, arg(6), filename, indir, outdir
character(len=256) :: prname, prname_lp
- character(len=256) :: mesh_file,local_data_file, local_ibool_file
+ character(len=256) :: mesh_file,local_data_file
logical :: HIGH_RESOLUTION_MESH
integer :: ires
! for read_parameter_files
double precision :: DT
double precision :: HDUR_MOVIE
- integer :: NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP, &
+ integer :: NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP, &
UTM_PROJECTION_ZONE,SIMULATION_TYPE
integer :: NSOURCES
integer :: NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
@@ -93,9 +89,9 @@
print *, ' xcombine_data slice_list filename input_dir output_dir high/low-resolution'
print *
print *, ' possible filenames are '
- print *, ' rho_vp, rho_vs, kappastore, mustore etc'
+ print *, ' rho_vp, rho_vs, kappastore, mustore, alpha_kernel, etc'
print *
- print *, ' that are stored in the local directory as real(kind=CUSTOM_REAL) filename(NGLLX,NGLLY,NGLLZ,nspec) '
+ print *, ' that are stored in the local directory as real(kind=CUSTOM_REAL) filename(NGLLX,NGLLY,NGLLZ,NSPEC_AB) '
print *, ' in filename.bin'
print *
print *, ' files have been collected in input_dir, output mesh file goes to output_dir '
@@ -146,18 +142,15 @@
endif
! needs local_path for mesh files
- call read_parameter_file( &
- NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
- UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
- ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
- OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
- MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
- SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
- NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
+ call read_parameter_file( NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
+ OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
+ MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
+ SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
-
-
print *, 'Slice list: '
print *, node_list(1:num_node)
@@ -168,11 +161,12 @@
! counts total number of points (all slices)
npp = 0
nee = 0
- call combine_vol_data_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH,&
+ call cvd_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH,&
npp,nee,HIGH_RESOLUTION_MESH)
- ! write point and scalar information
+ ! writes point and scalar information
+ ! loops over slices (process partitions)
np = 0
do it = 1, num_node
@@ -180,63 +174,58 @@
print *, ' '
print *, 'Reading slice ', iproc
- write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_'
+ ! gets number of elements and global points for this partition
+ write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_'
open(unit=27,file=prname_lp(1:len_trim(prname_lp))//'external_mesh.bin',&
status='old',action='read',form='unformatted')
read(27) NSPEC_AB
read(27) NGLOB_AB
- close(27)
- nspec = NSPEC_AB
- nglob = NGLOB_AB
-
- allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(mask_ibool(NGLOB_AB))
- allocate(data(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB))
! ibool file
- local_ibool_file = trim(prname_lp) // 'ibool' // '.bin'
- open(unit = 28,file = trim(local_ibool_file),status='old',&
- action='read', iostat = ios, form='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_data_file)
- stop
- endif
- read(28) ibool
- close(28)
- print *, trim(local_ibool_file)
+ allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ read(27) ibool
+ ! global point arrays
+ allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB))
+ read(27) xstore
+ read(27) ystore
+ read(27) zstore
+ close(27)
+
+
! data file
write(prname,'(a,i6.6,a)') trim(indir)//'proc',iproc,'_'
local_data_file = trim(prname) // trim(filename) // '.bin'
- open(unit = 27,file = trim(local_data_file),status='old',&
+ open(unit = 28,file = trim(local_data_file),status='old',&
action='read', iostat = ios,form ='unformatted')
if (ios /= 0) then
print *,'Error opening ',trim(local_data_file)
stop
endif
- read(27) data
- close(27)
+ allocate(data(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ read(28) data
+ close(28)
print *, trim(local_data_file)
- ! uses implicit conversion to real values
- dat = data
+ ! uses conversion to real values
+ allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ if( CUSTOM_REAL == 4 ) then
+ dat = data
+ else
+ dat = sngl(data)
+ endif
-
! writes point coordinates and scalar value to mesh file
if (.not. HIGH_RESOLUTION_MESH) then
! writes out element corners only
- call combine_vol_data_write_corners(nspec,nglob,ibool,mask_ibool,&
- xstore,ystore,zstore,dat, &
- it,npp,prname_lp,numpoin)
+ call cvd_write_corners(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat, &
+ it,npp,numpoin)
else
! high resolution, all GLL points
- call combine_vol_data_write_GLL_points(nspec,nglob,ibool,mask_ibool,&
- xstore,ystore,zstore,dat,&
- it,npp,prname_lp,numpoin)
+ call cvd_write_GLL_points(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat,&
+ it,npp,numpoin)
endif
print*,' points:',np,numpoin
@@ -244,7 +233,8 @@
! stores total number of points written
np = np + numpoin
- deallocate(ibool,mask_ibool,data,dat,xstore,ystore,zstore)
+ ! cleans up memory allocations
+ deallocate(ibool,data,dat,xstore,ystore,zstore)
enddo ! all slices for points
@@ -253,7 +243,7 @@
print *, ' '
-! write element information
+! writes element information
ne = 0
np = 0
do it = 1, num_node
@@ -263,39 +253,26 @@
print *, 'Reading slice ', iproc
write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_'
+ ! gets number of elements and global points for this partition
open(unit=27,file=prname_lp(1:len_trim(prname_lp))//'external_mesh.bin',&
status='old',action='read',form='unformatted')
read(27) NSPEC_AB
read(27) NGLOB_AB
- close(27)
- nspec = NSPEC_AB
- nglob = NGLOB_AB
+ ! ibool file
allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(mask_ibool(NGLOB_AB))
- allocate(num_ibool(NGLOB_AB))
+ read(27) ibool
+ close(27)
- ! ibool file
- local_ibool_file = trim(prname_lp) // 'ibool' // '.bin'
- open(unit = 28,file = trim(local_ibool_file),status='old',&
- action='read', iostat = ios, form='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_data_file)
- stop
- endif
- read(28) ibool
- close(28)
-
+ ! writes out element corner indices
if (.not. HIGH_RESOLUTION_MESH) then
! spectral elements
- call combine_vol_data_write_corner_elements(nspec,nglob,ibool,mask_ibool,num_ibool, &
- np,nelement, &
- it,nee,numpoin)
+ call cvd_write_corner_elements(NSPEC_AB,NGLOB_AB,ibool, &
+ np,nelement,it,nee,numpoin)
else
! subdivided spectral elements
- call combine_vol_data_write_GLL_elements(nspec,nglob,ibool,mask_ibool,num_ibool, &
- np,nelement, &
- it,nee,numpoin)
+ call cvd_write_GLL_elements(NSPEC_AB,NGLOB_AB,ibool, &
+ np,nelement,it,nee,numpoin)
endif
print*,' elements:',ne,nelement
@@ -303,7 +280,7 @@
ne = ne + nelement
- deallocate(ibool,mask_ibool,num_ibool)
+ deallocate(ibool)
enddo ! num_node
@@ -324,11 +301,13 @@
!=============================================================
-! counts total number of points and elements for external meshes in given slice list
- subroutine combine_vol_data_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH,&
+ subroutine cvd_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH,&
npp,nee,HIGH_RESOLUTION_MESH)
+! counts total number of points and elements for external meshes in given slice list
+! returns: total number of elements (nee) and number of points (npp)
+
implicit none
include 'constants.h'
@@ -345,18 +324,32 @@
integer :: iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
character(len=256) :: prname_lp
+
+ ! loops over all slices (process partitions)
npp = 0
nee = 0
do it = 1, num_node
+
! gets number of elements and points for this slice
iproc = node_list(it)
write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_'
open(unit=27,file=prname_lp(1:len_trim(prname_lp))//'external_mesh.bin',&
- status='old',action='read',form='unformatted')
+ status='old',action='read',form='unformatted',iostat=ios)
+ if (ios /= 0) then
+ print *,'Error opening: ',prname_lp(1:len_trim(prname_lp))//'external_mesh.bin'
+ stop
+ endif
+
read(27) NSPEC_AB
read(27) NGLOB_AB
+ ! gets ibool
+ if( .not. HIGH_RESOLUTION_MESH ) then
+ allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ read(27) ibool
+ endif
close(27)
-
+
+ ! calculates totals
if( HIGH_RESOLUTION_MESH ) then
! total number of global points
npp = npp + NGLOB_AB
@@ -368,22 +361,9 @@
nee = nee + nelement
else
- ! counts element corners only
- allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(mask_ibool(NGLOB_AB))
- ! ibool file
- open(unit = 28,file = prname_lp(1:len_trim(prname_lp))//'ibool'//'.bin',&
- status='old',action='read',&
- iostat = ios,form='unformatted')
- if (ios /= 0) then
- print *,'Error opening: ',prname_lp(1:len_trim(prname_lp))//'ibool'//'.bin'
- stop
- endif
- read(28) ibool
- close(28)
-
! mark element corners (global AVS or DX points)
+ allocate(mask_ibool(NGLOB_AB))
mask_ibool = .false.
do ispec=1,NSPEC_AB
iglob1=ibool(1,1,1,ispec)
@@ -411,77 +391,45 @@
! total number of spectral elements
nee = nee + NSPEC_AB
- deallocate(ibool,mask_ibool)
endif ! HIGH_RESOLUTION_MESH
enddo
+
+ end subroutine cvd_count_totals_ext_mesh
-
- end subroutine combine_vol_data_count_totals_ext_mesh
-
!=============================================================
-! writes out locations of spectral element corners only
- subroutine combine_vol_data_write_corners(nspec,nglob,ibool,mask_ibool,&
- xstore,ystore,zstore,dat,&
- it,npp,prname_lp,numpoin)
+ subroutine cvd_write_corners(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat,&
+ it,npp,numpoin)
+! writes out locations of spectral element corners only
+
implicit none
include 'constants.h'
- integer,intent(in) :: nspec,nglob
- integer,dimension(NGLLX,NGLLY,NGLLZ,nspec),intent(in) :: ibool
- logical,dimension(nglob) :: mask_ibool
- real(kind=CUSTOM_REAL),dimension(nglob) :: xstore, ystore, zstore
- real,dimension(NGLLY,NGLLY,NGLLZ,nspec),intent(in) :: dat
+ integer,intent(in) :: NSPEC_AB,NGLOB_AB
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB) :: xstore, ystore, zstore
+ real,dimension(NGLLY,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: dat
integer:: it
integer :: npp,numpoin
- character(len=256) :: prname_lp
- !integer :: npoint,num_node
-
! local parameters
+ logical,dimension(:),allocatable :: mask_ibool
real :: x, y, z
- integer :: ios,ispec !,njunk
+ integer :: ispec
integer :: iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
- character(len=256) :: local_file
-! corner locations
- ! reads in coordinate files
- local_file = trim(prname_lp)//'x.bin'
- open(unit = 27,file = trim(prname_lp)//'x.bin',status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_file)
- stop
- endif
- read(27) xstore
- close(27)
- local_file = trim(prname_lp)//'y.bin'
- open(unit = 27,file = trim(prname_lp)//'y.bin',status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_file)
- stop
- endif
- read(27) ystore
- close(27)
- local_file = trim(prname_lp)//'z.bin'
- open(unit = 27,file = trim(prname_lp)//'z.bin',status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_file)
- stop
- endif
- read(27) zstore
- close(27)
-
! writes out total number of points
if (it == 1) then
call write_integer(npp)
endif
+ ! writes our corner point locations
+ allocate(mask_ibool(NGLOB_AB))
mask_ibool(:) = .false.
numpoin = 0
-
- do ispec=1,nspec
+ do ispec=1,NSPEC_AB
iglob1=ibool(1,1,1,ispec)
iglob2=ibool(NGLLX,1,1,ispec)
iglob3=ibool(NGLLX,NGLLY,1,ispec)
@@ -581,72 +529,41 @@
endif
enddo ! ispec
- end subroutine combine_vol_data_write_corners
+ end subroutine cvd_write_corners
!=============================================================
-! writes out locations of all GLL points of spectral elements
- subroutine combine_vol_data_write_GLL_points(nspec,nglob,ibool,mask_ibool,&
- xstore,ystore,zstore,dat,&
- it,npp,prname_lp,numpoin)
+ subroutine cvd_write_GLL_points(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat,&
+ it,npp,numpoin)
+! writes out locations of all GLL points of spectral elements
+
implicit none
include 'constants.h'
- integer,intent(in) :: nspec,nglob
- integer,dimension(NGLLX,NGLLY,NGLLZ,nspec),intent(in) :: ibool
- logical,dimension(nglob) :: mask_ibool
- real(kind=CUSTOM_REAL),dimension(nglob) :: xstore, ystore, zstore
- real,dimension(NGLLY,NGLLY,NGLLZ,nspec),intent(in) :: dat
+ integer,intent(in) :: NSPEC_AB,NGLOB_AB
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB) :: xstore, ystore, zstore
+ real,dimension(NGLLY,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: dat
integer:: it,npp,numpoin
- character(len=256) :: prname_lp
! local parameters
+ logical,dimension(:),allocatable :: mask_ibool
real :: x, y, z
- integer :: ios,ispec,i,j,k,iglob
- character(len=256) :: local_file
+ integer :: ispec,i,j,k,iglob
! writes out total number of points
if (it == 1) then
- !npoint = nglob
call write_integer(npp)
endif
- ! reads in coordinate files
- local_file = trim(prname_lp)//'x.bin'
- open(unit = 27,file = trim(prname_lp)//'x.bin',status='old',&
- action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_file)
- stop
- endif
- read(27) xstore
- close(27)
- local_file = trim(prname_lp)//'y.bin'
- open(unit = 27,file = trim(prname_lp)//'y.bin',status='old',&
- action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_file)
- stop
- endif
- read(27) ystore
- close(27)
- local_file = trim(prname_lp)//'z.bin'
- open(unit = 27,file = trim(prname_lp)//'z.bin',status='old',&
- action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_file)
- stop
- endif
- read(27) zstore
- close(27)
-
+ ! writes out point locations and values
+ allocate(mask_ibool(NGLOB_AB))
mask_ibool(:) = .false.
numpoin = 0
-
- do ispec=1,nspec
+ do ispec=1,NSPEC_AB
do k = 1, NGLLZ
do j = 1, NGLLY
do i = 1, NGLLX
@@ -667,45 +584,41 @@
enddo ! k
enddo !ispec
- end subroutine combine_vol_data_write_GLL_points
+ end subroutine cvd_write_GLL_points
!=============================================================
! writes out locations of spectral element corners only
- subroutine combine_vol_data_write_corner_elements(nspec,nglob,ibool,mask_ibool,num_ibool,&
- np,nelement, &
- it,nee,numpoin)
+ subroutine cvd_write_corner_elements(NSPEC_AB,NGLOB_AB,ibool,&
+ np,nelement,it,nee,numpoin)
implicit none
include 'constants.h'
- integer,intent(in) :: nspec,nglob
- integer,dimension(NGLLX,NGLLY,NGLLZ,nspec),intent(in) :: ibool
- logical,dimension(nglob) :: mask_ibool
- integer,dimension(nglob) :: num_ibool
+ integer,intent(in) :: NSPEC_AB,NGLOB_AB
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
integer:: it,nee,np,nelement,numpoin
- !character(len=256) :: prname
- !integer :: num_node
-
! local parameters
- integer :: ispec !,i,ios,njunk,njunk2
+ logical,dimension(:),allocatable :: mask_ibool
+ integer,dimension(:),allocatable :: num_ibool
+ integer :: ispec
integer :: iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
integer :: n1, n2, n3, n4, n5, n6, n7, n8
- !character(len=256) :: local_element_file
-
! outputs total number of elements for all slices
if (it == 1) then
call write_integer(nee)
end if
- num_ibool(:) = 0
+ ! writes out element indices
+ allocate(mask_ibool(NGLOB_AB))
+ allocate(num_ibool(NGLOB_AB))
mask_ibool(:) = .false.
- numpoin = 0
-
- do ispec=1,nspec
+ num_ibool(:) = 0
+ numpoin = 0
+ do ispec=1,NSPEC_AB
! gets corner indices
iglob1=ibool(1,1,1,ispec)
iglob2=ibool(NGLLX,1,1,ispec)
@@ -780,32 +693,32 @@
enddo
! elements written
- nelement = nspec
+ nelement = NSPEC_AB
! updates points written
np = np + numpoin
- end subroutine combine_vol_data_write_corner_elements
+ end subroutine cvd_write_corner_elements
!=============================================================
-! writes out locations of spectral element corners only
- subroutine combine_vol_data_write_GLL_elements(nspec,nglob,ibool,mask_ibool,num_ibool,&
- np,nelement,&
- it,nee,numpoin)
+ subroutine cvd_write_GLL_elements(NSPEC_AB,NGLOB_AB,ibool, &
+ np,nelement,it,nee,numpoin)
+! writes out indices of elements given by GLL points
+
implicit none
include 'constants.h'
- integer,intent(in):: nspec,nglob
- integer,dimension(NGLLX,NGLLY,NGLLZ,nspec),intent(in) :: ibool
- logical,dimension(nglob) :: mask_ibool
- integer,dimension(nglob) :: num_ibool
+ integer,intent(in):: NSPEC_AB,NGLOB_AB
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
integer:: it,nee,np,numpoin,nelement
! local parameters
+ logical,dimension(:),allocatable :: mask_ibool
+ integer,dimension(:),allocatable :: num_ibool
integer :: ispec,i,j,k
integer :: iglob,iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
integer :: n1, n2, n3, n4, n5, n6, n7, n8
@@ -816,11 +729,13 @@
call write_integer(nee)
endif
- numpoin = 0
- mask_ibool = .false.
-
! sets numbering num_ibool respecting mask
- do ispec=1,nspec
+ allocate(mask_ibool(NGLOB_AB))
+ allocate(num_ibool(NGLOB_AB))
+ mask_ibool(:) = .false.
+ num_ibool(:) = 0
+ numpoin = 0
+ do ispec=1,NSPEC_AB
do k = 1, NGLLZ
do j = 1, NGLLY
do i = 1, NGLLX
@@ -836,7 +751,7 @@
enddo !ispec
! outputs GLL subelement
- do ispec = 1, nspec
+ do ispec = 1, NSPEC_AB
do k = 1, NGLLZ-1
do j = 1, NGLLY-1
do i = 1, NGLLX-1
@@ -869,9 +784,10 @@
enddo
enddo
! elements written
- nelement = nspec * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1)
+ nelement = NSPEC_AB * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1)
! updates points written
np = np + numpoin
- end subroutine combine_vol_data_write_GLL_elements
\ No newline at end of file
+ end subroutine cvd_write_GLL_elements
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/comp_source_time_function.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/comp_source_time_function.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/comp_source_time_function.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -33,8 +33,57 @@
double precision, external :: netlib_specfun_erf
-! quasi Heaviside, small Gaussian moment-rate tensor with hdur
+ ! quasi Heaviside, small Gaussian moment-rate tensor with hdur
comp_source_time_function = 0.5d0*(1.0d0 + netlib_specfun_erf(t/hdur))
end function comp_source_time_function
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ double precision function comp_source_time_function_gauss(t,hdur)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: t,hdur
+ double precision :: hdur_decay
+ double precision,parameter :: SOURCE_DECAY_STRONG = 2.0d0/SOURCE_DECAY_MIMIC_TRIANGLE
+
+ ! note: hdur given is hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
+ ! and SOURCE_DECAY_MIMIC_TRIANGLE ~ 1.68
+ hdur_decay = hdur
+
+ ! this here uses a stronger gaussian decay rate (empirical value) to avoid non-zero onset times;
+ ! however, it should mimik a triangle source time function...
+ !hdur_decay = hdur / SOURCE_DECAY_STRONG
+
+ ! note: a nonzero time to start the simulation with would lead to more high-frequency noise
+ ! due to the (spatial) discretization of the point source on the mesh
+
+ ! gaussian
+ comp_source_time_function_gauss = exp(-(t/hdur_decay)**2)/(sqrt(PI)*hdur_decay)
+
+ end function comp_source_time_function_gauss
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ double precision function comp_source_time_function_rickr(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision t,f0
+
+ ! ricker
+ comp_source_time_function_rickr = (1.d0 - 2.d0*PI*PI*f0*f0*t*t ) &
+ * exp( -PI*PI*f0*f0*t*t )
+
+ end function comp_source_time_function_rickr
+
\ No newline at end of file
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_add_sources_acoustic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_add_sources_acoustic.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_add_sources_acoustic.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,331 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! for acoustic solver
+
+ subroutine compute_add_sources_acoustic(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source, &
+ hdur,hdur_gaussian,t_cmt,dt,t0, &
+ sourcearrays,kappastore,ispec_is_acoustic,&
+ SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ nadj_rec_local,adj_sourcearrays,b_potential_dot_dot_acoustic )
+
+ use specfem_par,only: PRINT_SOURCE_TIME_FUNCTION,stf_used_total
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: kappastore
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! source
+ integer :: NSOURCES,myrank,it
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(NSOURCES) :: hdur,hdur_gaussian,t_cmt
+ double precision :: dt,t0
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
+
+ double precision, external :: comp_source_time_function,comp_source_time_function_rickr,&
+ comp_source_time_function_gauss
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+!adjoint simulations
+ integer:: SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT
+ integer:: nrec
+ integer,dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+ integer:: nadj_rec_local
+ real(kind=CUSTOM_REAL),dimension(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ):: adj_sourcearrays
+ real(kind=CUSTOM_REAL),dimension(NGLOB_ADJOINT):: b_potential_dot_dot_acoustic
+
+! local parameters
+ double precision :: f0
+ double precision :: stf
+ real(kind=CUSTOM_REAL) stf_used,stf_used_total_all,time_source
+ integer :: isource,iglob,ispec,i,j,k
+ integer :: irec_local,irec
+
+! plotting source time function
+ if(PRINT_SOURCE_TIME_FUNCTION .and. .not. phase_is_inner ) then
+ ! initializes total
+ stf_used_total = 0.0_CUSTOM_REAL
+ endif
+
+! forward simulations
+ if (SIMULATION_TYPE == 1) then
+
+ ! adds acoustic sources
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec)
+
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+ t0 = 1.2d0/f0
+
+ if (it == 1 .and. myrank == 0) then
+ print *,'using a source of dominant frequency ',f0
+ print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ endif
+
+ ! gaussian source time function
+ !stf_used = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! we use nu_source(:,3) here because we want a source normal to the surface.
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ stf_used = 1.d10 * comp_source_time_function_rickr(dble(it-1)*DT-t0-t_cmt(isource),f0)
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+ ! to add minus the source to Chi_dot_dot to get plus the source in pressure:
+
+ ! acoustic source for pressure gets divided by kappa
+ ! source contribution
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - stf_used / kappastore(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)),ispec)
+
+ else
+
+ ! gaussian source time
+ stf = comp_source_time_function_gauss(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! quasi-heaviside
+ !stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! distinguishes between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+ ! to add minus the source to Chi_dot_dot to get plus the source in pressure
+
+ ! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! adds source contribution
+ ! note: acoustic source for pressure gets divided by kappa
+ iglob = ibool(i,j,k,ispec)
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - sourcearrays(isource,1,i,j,k) * stf_used / kappastore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+
+ stf_used_total = stf_used_total + stf_used
+
+ endif ! ispec_is_elastic
+ endif ! ispec_is_inner
+ endif ! myrank
+
+ enddo ! NSOURCES
+ endif
+
+! NOTE: adjoint sources and backward wavefield timing:
+! idea is to start with the backward field b_potential.. at time (T)
+! and convolve with the adjoint field at time (T-t)
+!
+! backward/reconstructed wavefields:
+! time for b_potential..( it ) corresponds to (NSTEP - it - 1 )*DT - t0 ...
+! since we start with saved wavefields b_potential..( 0 ) = potential..( NSTEP ) which correspond
+! to a time (NSTEP - 1)*DT - t0
+! (see sources for simulation_type 1 and seismograms)
+! now, at the beginning of the time loop, the numerical Newark time scheme updates
+! the wavefields, that is b_potential..( it=1) corresponds now to time (NSTEP -1 - 1)*DT - t0
+!
+! let's define the start time t to (1-1)*DT - t0 = -t0, and the end time T to (NSTEP-1)*DT - t0
+! these are the start and end times of all seismograms
+!
+! adjoint wavefields:
+! since the adjoint source traces were derived from the seismograms,
+! it follows that for the adjoint wavefield, the time equivalent to ( T - t ) uses the time-reversed
+! adjoint source traces which start at -t0 and end at time (NSTEP-1)*DT - t0
+! for it=1: (NSTEP -1 - 1)*DT - t0 for backward wavefields corresponds to time T-1
+! and time (T-1) corresponds now to index (NSTEP -1) in the adjoint source array
+
+! adjoint simulations
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+
+ if( it < NSTEP ) then
+ ! receivers act as sources
+ irec_local = 0
+ do irec = 1,nrec
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+ ! adds source array
+ ispec = ispec_selected_rec(irec)
+ do k = 1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - adj_sourcearrays(irec_local,NSTEP-it,1,i,j,k) / kappastore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ endif
+ enddo ! nrec
+ endif ! it
+ endif
+
+! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ ! adds acoustic sources
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec)
+
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+ t0 = 1.2d0/f0
+
+ if (it == 1 .and. myrank == 0) then
+ print *,'using a source of dominant frequency ',f0
+ print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ endif
+
+ ! gaussian source time function
+ !stf_used = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! we use nu_source(:,3) here because we want a source normal to the surface.
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ stf_used = 1.d10 * comp_source_time_function_rickr(dble(NSTEP-it-1)*DT-t0-t_cmt(isource),f0)
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+ ! to add minus the source to Chi_dot_dot to get plus the source in pressure:
+
+ ! acoustic source for pressure gets divided by kappa
+ ! source contribution
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
+ - stf_used / kappastore(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)),ispec)
+
+ else
+
+ ! gaussian source time
+ stf = comp_source_time_function_gauss(dble(NSTEP-it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! distinguishes between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+ ! to add minus the source to Chi_dot_dot to get plus the source in pressure
+
+ ! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! adds source contribution
+ ! note: acoustic source for pressure gets divided by kappa
+ iglob = ibool(i,j,k,ispec)
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
+ - sourcearrays(isource,1,i,j,k) * stf_used / kappastore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+
+ stf_used_total = stf_used_total + stf_used
+
+ endif ! ispec_is_elastic
+ endif ! ispec_is_inner
+ endif ! myrank
+
+ enddo ! NSOURCES
+ endif
+
+ ! master prints out source time function to file
+ if(PRINT_SOURCE_TIME_FUNCTION .and. phase_is_inner) then
+ time_source = (it-1)*DT - t0
+ call sum_all_cr(stf_used_total,stf_used_total_all)
+ if( myrank == 0 ) write(IOSTF,*) time_source,stf_used_total_all
+ endif
+
+
+end subroutine compute_add_sources_acoustic
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_add_sources_elastic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_add_sources_elastic.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_add_sources_elastic.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,290 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! for elastic solver
+
+ subroutine compute_add_sources_elastic( NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source,nu_source, &
+ hdur,hdur_gaussian,t_cmt,dt,t0,sourcearrays, &
+ ispec_is_elastic,SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ nadj_rec_local,adj_sourcearrays,b_accel )
+
+ use specfem_par,only: PRINT_SOURCE_TIME_FUNCTION,stf_used_total
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! source
+ integer :: NSOURCES,myrank,it
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(3,3,NSOURCES) :: nu_source
+ double precision, dimension(NSOURCES) :: hdur,hdur_gaussian,t_cmt
+ double precision :: dt,t0
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
+
+ double precision, external :: comp_source_time_function,comp_source_time_function_rickr
+
+ logical, dimension(NSPEC_AB) :: ispec_is_elastic
+
+!adjoint simulations
+ integer:: SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT
+ integer:: nrec
+ integer,dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+ integer:: nadj_rec_local
+ real(kind=CUSTOM_REAL),dimension(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ):: adj_sourcearrays
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_ADJOINT):: b_accel
+
+! local parameters
+ double precision :: f0
+ double precision :: stf
+ real(kind=CUSTOM_REAL) stf_used,stf_used_total_all,time_source
+ integer :: isource,iglob,i,j,k,ispec
+ integer :: irec_local,irec
+
+! plotting source time function
+ if(PRINT_SOURCE_TIME_FUNCTION .and. .not. phase_is_inner ) then
+ ! initializes total
+ stf_used_total = 0.0_CUSTOM_REAL
+ endif
+
+! forward simulations
+ if (SIMULATION_TYPE == 1) then
+
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_elastic(ispec) ) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec_selected_source(isource))
+
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+ t0 = 1.2d0/f0
+
+ if (it == 1 .and. myrank == 0) then
+ print *,'using a source of dominant frequency ',f0
+ print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ endif
+
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ stf_used = 1.d10 * comp_source_time_function_rickr(dble(it-1)*DT-t0-t_cmt(isource),f0)
+
+ ! we use nu_source(:,3) here because we want a source normal to the surface.
+ accel(:,iglob) = accel(:,iglob) &
+ + sngl( nu_source(:,3,isource) ) * stf_used
+
+ else
+
+ stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+ ! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ accel(:,iglob) = accel(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+
+ stf_used_total = stf_used_total + stf_used
+
+ endif ! ispec_is_elastic
+ endif ! ispec_is_inner
+ endif ! myrank
+
+ enddo ! NSOURCES
+ endif ! forward
+
+! NOTE: adjoint sources and backward wavefield timing:
+! idea is to start with the backward field b_displ,.. at time (T)
+! and convolve with the adjoint field at time (T-t)
+!
+! backward/reconstructed wavefields:
+! time for b_displ( it ) corresponds to (NSTEP - it - 1 )*DT - t0 ...
+! since we start with saved wavefields b_displ( 0 ) = displ( NSTEP ) which correspond
+! to a time (NSTEP - 1)*DT - t0
+! (see sources for simulation_type 1 and seismograms)
+! now, at the beginning of the time loop, the numerical Newark time scheme updates
+! the wavefields, that is b_displ( it=1) corresponds now to time (NSTEP -1 - 1)*DT - t0
+!
+! let's define the start time t to (1-1)*DT - t0 = -t0, and the end time T to (NSTEP-1)*DT - t0
+! these are the start and end times of all seismograms
+!
+! adjoint wavefields:
+! since the adjoint source traces were derived from the seismograms,
+! it follows that for the adjoint wavefield, the time equivalent to ( T - t ) uses the time-reversed
+! adjoint source traces which start at -t0 and end at time (NSTEP-1)*DT - t0
+! for it=1: (NSTEP -1 - 1)*DT - t0 for backward wavefields corresponds to time T-1
+! and time (T-1) corresponds now to index (NSTEP -1) in the adjoint source array
+
+
+! adjoint simulations
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+
+ if( it < NSTEP ) then
+
+ ! receivers act as sources
+ irec_local = 0
+ do irec = 1,nrec
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+ ! adds source array
+ do k = 1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec_selected_rec(irec))
+ accel(:,iglob) = accel(:,iglob) + adj_sourcearrays(irec_local,NSTEP-it,:,i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+ enddo ! nrec
+
+ endif ! it
+
+ endif !adjoint
+
+! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+
+ ! backward source reconstruction
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_elastic(ispec) ) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec_selected_source(isource))
+
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+ t0 = 1.2d0/f0
+
+ if (it == 1 .and. myrank == 0) then
+ print *,'using a source of dominant frequency ',f0
+ print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ endif
+
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ stf_used = 1.d10 * comp_source_time_function_rickr(dble(NSTEP-it-1)*DT-t0-t_cmt(isource),f0)
+
+ ! we use nu_source(:,3) here because we want a source normal to the surface.
+ ! note: time step is now at NSTEP-it
+ b_accel(:,iglob) = b_accel(:,iglob) &
+ + sngl( nu_source(:,3,isource) ) * stf_used
+
+
+ else
+
+ ! see note above: time step corresponds now to NSTEP-it-1
+ ! (also compare to it-1 for forward simulation)
+ stf = comp_source_time_function(dble(NSTEP-it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+ ! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec_selected_source(isource))
+ b_accel(:,iglob) = b_accel(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
+ enddo
+ enddo
+ enddo
+ endif ! USE_FORCE_POINT_SOURCE
+
+ stf_used_total = stf_used_total + stf_used
+
+ endif ! elastic
+ endif ! phase_inner
+ endif ! myrank
+
+ enddo ! NSOURCES
+ endif ! adjoint
+
+ ! master prints out source time function to file
+ if(PRINT_SOURCE_TIME_FUNCTION .and. phase_is_inner) then
+ time_source = (it-1)*DT - t0
+ call sum_all_cr(stf_used_total,stf_used_total_all)
+ if( myrank == 0 ) write(IOSTF,*) time_source,stf_used_total_all
+ endif
+
+
+ end subroutine compute_add_sources_elastic
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_arrays_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_arrays_source.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_arrays_source.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -166,8 +166,8 @@
!=============================================================================
subroutine compute_arrays_adjoint_source(myrank, adj_source_file, &
- xi_receiver,eta_receiver,gamma_receiver, adj_sourcearray, &
- xigll,yigll,zigll,NSTEP)
+ xi_receiver,eta_receiver,gamma_receiver, adj_sourcearray, &
+ xigll,yigll,zigll,NSTEP)
implicit none
@@ -182,43 +182,52 @@
character(len=*) adj_source_file
! output
- real(kind=CUSTOM_REAL) :: adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ)
+ real(kind=CUSTOM_REAL),dimension(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ) :: adj_sourcearray
! Gauss-Lobatto-Legendre points of integration and weights
double precision, dimension(NGLLX) :: xigll
double precision, dimension(NGLLY) :: yigll
double precision, dimension(NGLLZ) :: zigll
-
double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
hgammar(NGLLZ), hpgammar(NGLLZ)
+
real(kind=CUSTOM_REAL) :: adj_src(NSTEP,NDIM)
integer icomp, itime, i, j, k, ios
double precision :: junk
- character(len=3) :: comp(3)
+ character(len=3),dimension(NDIM) :: comp = (/ "BHN", "BHE", "BHZ" /)
character(len=256) :: filename
- call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
- call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
- call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
-
- adj_sourcearray(:,:,:,:,:) = 0.
-
- comp = (/"BHE", "BHN", "BHZ"/)
-
+ !adj_sourcearray(:,:,:,:,:) = 0.
+ adj_src = 0._CUSTOM_REAL
+
+ ! loops over components
do icomp = 1, NDIM
filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
- open(unit = IIN, file = trim(filename), iostat = ios)
- if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//'does not exist')
+ open(unit=IIN,file=trim(filename),status='old',action='read',iostat = ios)
+ if (ios /= 0) cycle ! cycles to next file
+ !if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//'does not exist')
+
+ ! reads in adjoint source trace
do itime = 1, NSTEP
- read(IIN,*) junk, adj_src(itime,icomp)
- enddo
+
+ read(IIN,*,iostat=ios) junk, adj_src(itime,icomp)
+ if( ios /= 0 ) &
+ call exit_MPI(myrank, &
+ 'file '//trim(filename)//' has wrong length, please check with your simulation duration')
+ enddo
close(IIN)
enddo
+ ! lagrange interpolators for receiver location
+ call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
+
+ ! interpolates adjoint source onto GLL points within this element
do k = 1, NGLLZ
do j = 1, NGLLY
do i = 1, NGLLX
@@ -227,7 +236,6 @@
enddo
enddo
-
end subroutine compute_arrays_adjoint_source
@@ -443,7 +451,7 @@
sourcearray(:,:,:,:) = 0._CUSTOM_REAL
sourcearrayd(:,:,:,:) = 0.d0
-! compute Lagrange polynomials at the source location
+! computes Lagrange polynomials at the source location
call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
call lagrange_any(eta_source,NGLLY,yigll,hetas,hpetas)
call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_boundary_kernel.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_boundary_kernel.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_boundary_kernel.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -23,9 +23,140 @@
!
!=====================================================================
-subroutine compute_boundary_kernel(kernel, mul, kappal, rho_vsl, accel, b_displ, ds, b_ds, norm)
+subroutine compute_boundary_kernel()
+
+! isotropic topography kernel computation
+! compare with Tromp et al. (2005), eq. (25), or see Liu & Tromp (2008), eq. (65)
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL):: kernel_moho_top,kernel_moho_bot
+ integer :: i,j,k
+ integer :: ispec2D,igll,jgll
+ integer :: ispec_top,ispec_bot,iglob_top,iglob_bot
+ logical :: is_done
+
+ ! loops over top/bottom elements of moho surface
+ do ispec2D = 1, NSPEC2D_MOHO
+ ispec_top = ibelm_moho_top(ispec2D)
+ ispec_bot = ibelm_moho_bot(ispec2D)
+
+ ! elements on both sides available
+ if( ispec_top > 0 .and. ispec_bot > 0 ) then
+ ! loops over surface
+ do igll=1,NGLLSQUARE
+ i = ijk_moho_top(1,igll,ispec2D)
+ j = ijk_moho_top(2,igll,ispec2D)
+ k = ijk_moho_top(3,igll,ispec2D)
+ iglob_top = ibool(i,j,k,ispec_top)
+
+ ! computes contribution from top element
+ call compute_boundary_kernel_elem( kernel_moho_top, &
+ mustore(i,j,k,ispec_top), &
+ kappastore(i,j,k,ispec_top),rho_vs(i,j,k,ispec_top), &
+ accel(:,iglob_top),b_displ(:,iglob_top), &
+ dsdx_top(:,:,i,j,k,ispec2D),b_dsdx_top(:,:,i,j,k,ispec2D), &
+ normal_moho_top(:,igll,ispec2D) )
+
+ ! finds corresponding global node in bottom element
+ is_done = .false.
+ do jgll = 1,NGLLSQUARE
+ i = ijk_moho_bot(1,jgll,ispec2D)
+ j = ijk_moho_bot(2,jgll,ispec2D)
+ k = ijk_moho_bot(3,jgll,ispec2D)
+ iglob_bot = ibool(i,j,k,ispec_bot)
+
+ if( iglob_bot /= iglob_top ) cycle
+ ! iglob_top == iglob_bot!
+
+ ! computes contribution from bottom element
+ call compute_boundary_kernel_elem( kernel_moho_bot, &
+ mustore(i,j,k,ispec_bot), &
+ kappastore(i,j,k,ispec_bot),rho_vs(i,j,k,ispec_bot), &
+ accel(:,iglob_bot),b_displ(:,iglob_bot), &
+ dsdx_bot(:,:,i,j,k,ispec2D),b_dsdx_bot(:,:,i,j,k,ispec2D), &
+ normal_moho_bot(:,jgll,ispec2D) )
+
+ ! note: kernel point position: indices given by ijk_moho_top(:,igll,ispec2D)
+ moho_kl(igll,ispec2D) = moho_kl(igll,ispec2D) &
+ + (kernel_moho_top - kernel_moho_bot) * deltat
+
+ ! kernel done for this point
+ is_done = .true.
+ enddo
+
+ ! checks
+ if( .not. is_done ) then
+ print*,'error : moho kernel not computed'
+ print*,'ispec:',ispec_top,ispec_bot,iglob_top,i,j,k
+ call exit_mpi(myrank,'error moho kernel computation')
+ endif
+
+ enddo
+
+ ! only one element available
+ ! e.g. free-surface: see Tromp et al. (2005), eq. (28)
+ else if( ispec_bot > 0 .or. ispec_top > 0 ) then
+
+ ! loops over surface
+ do igll=1,NGLLSQUARE
+
+ if( ispec_top > 0 ) then
+ i = ijk_moho_top(1,igll,ispec2D)
+ j = ijk_moho_top(2,igll,ispec2D)
+ k = ijk_moho_top(3,igll,ispec2D)
+ iglob_top = ibool(i,j,k,ispec_top)
+
+ ! computes contribution from top element
+ call compute_boundary_kernel_elem( kernel_moho_top, &
+ mustore(i,j,k,ispec_top), &
+ kappastore(i,j,k,ispec_top),rho_vs(i,j,k,ispec_top), &
+ accel(:,iglob_top),b_displ(:,iglob_top), &
+ dsdx_top(:,:,i,j,k,ispec2D),b_dsdx_top(:,:,i,j,k,ispec2D), &
+ normal_moho_top(:,igll,ispec2D) )
+
+ ! note: kernel point position igll: indices given by ijk_moho_top(:,igll,ispec2D)
+ moho_kl(igll,ispec2D) = moho_kl(igll,ispec2D) + kernel_moho_top * deltat
+
+ else
+ i = ijk_moho_bot(1,igll,ispec2D)
+ j = ijk_moho_bot(2,igll,ispec2D)
+ k = ijk_moho_bot(3,igll,ispec2D)
+ iglob_bot = ibool(i,j,k,ispec_bot)
+
+ ! computes contribution from bottom element
+ call compute_boundary_kernel_elem( kernel_moho_bot, &
+ mustore(i,j,k,ispec_bot), &
+ kappastore(i,j,k,ispec_bot),rho_vs(i,j,k,ispec_bot), &
+ accel(:,iglob_bot),b_displ(:,iglob_bot), &
+ dsdx_bot(:,:,i,j,k,ispec2D),b_dsdx_bot(:,:,i,j,k,ispec2D), &
+ normal_moho_bot(:,igll,ispec2D) )
+
+ ! note: kernel point position igll: indices given by ijk_moho_bot(:,igll,ispec2D)
+ moho_kl(igll,ispec2D) = moho_kl(igll,ispec2D) - kernel_moho_bot * deltat
+
+ endif
+ enddo
+ endif
+ enddo ! ispec2D
+
+
+end subroutine compute_boundary_kernel
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_boundary_kernel_elem(kernel, mul, kappal, rho_vsl, &
+ accel, b_displ, ds, b_ds, norm)
+
! compute the boundary kernel contribution from one side of the boundary
+! see e.g.: Tromp et al. (2005), eq. (25), or Liu & Tromp (2008), eq. (65)
implicit none
include 'constants.h'
@@ -41,8 +172,10 @@
normal(:,1) = norm
one_matrix(1,1) = ONE
+ ! adjoint strain (epsilon) trace
eps3 = ds(1,1) + ds(2,2) + ds(3,3)
+ ! adjoint strain tensor
eps(1,1) = ds(1,1)
eps(2,2) = ds(2,2)
eps(3,3) = ds(3,3)
@@ -53,14 +186,17 @@
eps(3,1) = eps(1,3)
eps(3,2) = eps(2,3)
+ ! adjoint deviatoric strain component
epsdev = eps
epsdev(1,1) = eps(1,1) - eps3 / 3
epsdev(2,2) = eps(2,2) - eps3 / 3
epsdev(3,3) = eps(3,3) - eps3 / 3
+ ! backward/reconstructed-forward strain (epsilon) trace
b_eps3 = b_ds(1,1) + b_ds(2,2) + b_ds(3,3)
+ ! backward/reconstructed-forward strain tensor
b_eps(1,1) = b_ds(1,1)
b_eps(2,2) = b_ds(2,2)
b_eps(3,3) = b_ds(3,3)
@@ -71,23 +207,27 @@
b_eps(3,1) = b_eps(1,3)
b_eps(3,2) = b_eps(2,3)
+ ! backward/reconstructed-forward deviatoric strain
b_epsdev = b_eps
b_epsdev(1,1) = b_eps(1,1) - b_eps3 / 3
b_epsdev(2,2) = b_eps(2,2) - b_eps3 / 3
b_epsdev(3,3) = b_eps(3,3) - b_eps3 / 3
+ ! matrix multiplication
temp1 = matmul(epsdev,b_epsdev)
+ ! density value
rhol = rho_vsl ** 2 / mul
- kl = (rhol * dot_product(accel(:), b_displ(:)) &
- + kappal * eps3 * b_eps3 &
- + 2 * mul * (temp1(1,1) + temp1(2,2) + temp1(3,3))) * one_matrix &
- - kappal * matmul(transpose(normal),matmul(eps,normal)) * b_eps3 &
- - kappal * matmul(transpose(normal),matmul(b_eps,normal)) * eps3 &
- - 2 * mul * matmul(transpose(normal), matmul(matmul(b_epsdev,ds), normal)) &
- - 2 * mul * matmul(transpose(normal), matmul(matmul(epsdev,b_ds), normal))
+ ! isotropic kernel value
+ ! see e.g.: Tromp et al. (2005), eq. (25), or Liu & Tromp 2008, eq. (65)
+ kl = ( rhol * dot_product(accel(:), b_displ(:)) + kappal * eps3 * b_eps3 &
+ + 2 * mul * (temp1(1,1) + temp1(2,2) + temp1(3,3)) ) * one_matrix &
+ - kappal * matmul(transpose(normal),matmul(eps,normal)) * b_eps3 &
+ - kappal * matmul(transpose(normal),matmul(b_eps,normal)) * eps3 &
+ - 2 * mul * matmul(transpose(normal), matmul(matmul(b_epsdev,ds), normal)) &
+ - 2 * mul * matmul(transpose(normal), matmul(matmul(epsdev,b_ds), normal))
kernel = kl(1,1)
-end subroutine compute_boundary_kernel
+end subroutine compute_boundary_kernel_elem
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_coupling_acoustic_el.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_coupling_acoustic_el.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_coupling_acoustic_el.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,123 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! for acoustic solver
+
+ subroutine compute_coupling_acoustic_el(NSPEC_AB,NGLOB_AB, &
+ ibool,displ,potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+
+! returns the updated pressure array: potential_dot_dot_acoustic
+
+ implicit none
+ include 'constants.h'
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and pressure
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+! global indexing
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! acoustic-elastic coupling surface
+ integer :: num_coupling_ac_el_faces
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ispec(num_coupling_ac_el_faces)
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n
+ real(kind=CUSTOM_REAL) :: nx,ny,nz,jacobianw
+
+ integer :: iface,igll,ispec,iglob
+ integer :: i,j,k
+
+! loops on all coupling faces
+ do iface = 1,num_coupling_ac_el_faces
+
+ ! gets corresponding elements
+ ! (note: can be either acoustic or elastic element, no need to specify since
+ ! no material properties are needed for this coupling term)
+ ispec = coupling_ac_el_ispec(iface)
+
+ if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
+
+ ! loops over common GLL points
+ do igll = 1, NGLLSQUARE
+ i = coupling_ac_el_ijk(1,igll,iface)
+ j = coupling_ac_el_ijk(2,igll,iface)
+ k = coupling_ac_el_ijk(3,igll,iface)
+
+ ! gets global index of this common GLL point
+ ! (note: should be the same as for corresponding i',j',k',ispec_elastic or ispec_acoustic)
+ iglob = ibool(i,j,k,ispec)
+
+ ! elastic displacement on global point
+ displ_x = displ(1,iglob)
+ displ_y = displ(2,iglob)
+ displ_z = displ(3,iglob)
+
+ ! gets associated normal on GLL point
+ ! (note convention: pointing outwards of acoustic element)
+ nx = coupling_ac_el_normal(1,igll,iface)
+ ny = coupling_ac_el_normal(2,igll,iface)
+ nz = coupling_ac_el_normal(3,igll,iface)
+
+ ! calculates displacement component along normal
+ ! (normal points outwards of acoustic element)
+ displ_n = displ_x*nx + displ_y*ny + displ_z*nz
+
+ ! gets associated, weighted jacobian
+ jacobianw = coupling_ac_el_jacobian2Dw(igll,iface)
+
+ ! continuity of pressure and normal displacement on global point
+ !
+ ! note: newark time scheme together with definition of scalar potential:
+ ! pressure = - chi_dot_dot
+ ! requires that this coupling term uses the updated displacement at time step [t+delta_t],
+ ! which is done at the very beginning of the time loop
+ ! (see e.g. Chaljub & Vilotte, Nissen-Meyer thesis...)
+ ! it also means you have to calculate and update this here first before
+ ! calculating the coupling on the elastic side for the acceleration...
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + jacobianw*displ_n
+
+ enddo ! igll
+
+ endif
+
+ enddo ! iface
+
+end subroutine compute_coupling_acoustic_el
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_coupling_elastic_ac.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_coupling_elastic_ac.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_coupling_elastic_ac.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,121 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! for elastic solver
+
+ subroutine compute_coupling_elastic_ac(NSPEC_AB,NGLOB_AB, &
+ ibool,accel,potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+
+! returns the updated acceleration array: accel
+
+ implicit none
+ include 'constants.h'
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and pressure
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+! global indexing
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! acoustic-elastic coupling surface
+ integer :: num_coupling_ac_el_faces
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ispec(num_coupling_ac_el_faces)
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: pressure
+ real(kind=CUSTOM_REAL) :: nx,ny,nz,jacobianw
+
+ integer :: iface,igll,ispec,iglob
+ integer :: i,j,k
+
+! loops on all coupling faces
+ do iface = 1,num_coupling_ac_el_faces
+
+ ! gets corresponding spectral element
+ ! (note: can be either acoustic or elastic element, no need to specify since
+ ! no material properties are needed for this coupling term)
+ ispec = coupling_ac_el_ispec(iface)
+
+ if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
+
+ ! loops over common GLL points
+ do igll = 1, NGLLSQUARE
+ i = coupling_ac_el_ijk(1,igll,iface)
+ j = coupling_ac_el_ijk(2,igll,iface)
+ k = coupling_ac_el_ijk(3,igll,iface)
+
+ ! gets global index of this common GLL point
+ ! (note: should be the same as for corresponding i',j',k',ispec_elastic or ispec_elastic )
+ iglob = ibool(i,j,k,ispec)
+
+ ! acoustic pressure on global point
+ pressure = - potential_dot_dot_acoustic(iglob)
+
+ ! gets associated normal on GLL point
+ ! (note convention: pointing outwards of acoustic element)
+ nx = coupling_ac_el_normal(1,igll,iface)
+ ny = coupling_ac_el_normal(2,igll,iface)
+ nz = coupling_ac_el_normal(3,igll,iface)
+
+ ! gets associated, weighted 2D jacobian
+ ! (note: should be the same for elastic and acoustic element)
+ jacobianw = coupling_ac_el_jacobian2Dw(igll,iface)
+
+ ! continuity of displacement and pressure on global point
+ !
+ ! note: newark time scheme together with definition of scalar potential:
+ ! pressure = - chi_dot_dot
+ ! requires that this coupling term uses the *UPDATED* pressure (chi_dot_dot), i.e.
+ ! pressure at time step [t + delta_t]
+ ! (see e.g. Chaljub & Vilotte, Nissen-Meyer thesis...)
+ ! it means you have to calculate and update the acoustic pressure first before
+ ! calculating this term...
+ accel(1,iglob) = accel(1,iglob) + jacobianw*nx*pressure
+ accel(2,iglob) = accel(2,iglob) + jacobianw*ny*pressure
+ accel(3,iglob) = accel(3,iglob) + jacobianw*nz*pressure
+
+ enddo ! igll
+
+ endif
+
+ enddo ! iface
+
+end subroutine compute_coupling_elastic_ac
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -63,33 +63,25 @@
integer:: iphase
logical:: phase_is_inner
- ! time marching potentials
- if(PML) call PML_acoustic_time_march(NSPEC_AB,NGLOB_AB,ibool,&
- potential_acoustic,potential_dot_acoustic,&
- deltat,deltatsqover2,deltatover2,&
- num_PML_ispec,PML_ispec,PML_damping_d,&
- chi1,chi2,chi2_t,chi3,chi4,&
- chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
- chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot,&
- iglob_is_PML_interface,PML_mask_ibool,&
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh,&
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh,NPROC,&
- ispec_is_acoustic)
! enforces free surface (zeroes potentials at free surface)
call acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
- ibool, &
- free_surface_ijk,free_surface_ispec, &
- num_free_surface_faces, &
- ispec_is_acoustic)
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic)
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call acoustic_enforce_free_surface(NSPEC_AB,NGLOB_ADJOINT, &
+ b_potential_acoustic,b_potential_dot_acoustic,b_potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic)
+
+
if(PML) call PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB, &
potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
ibool,free_surface_ijk,free_surface_ispec, &
- num_free_surface_faces, &
- ispec_is_acoustic, &
+ num_free_surface_faces,ispec_is_acoustic, &
num_PML_ispec,PML_ispec,&
chi1,chi2,chi2_t,chi3,chi4,&
chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
@@ -107,15 +99,28 @@
endif
! acoustic pressure term
- call acoustic_pressure( phase_is_inner, NSPEC_AB,NGLOB_AB, &
+ call compute_forces_acoustic_pot( iphase, NSPEC_AB,NGLOB_AB, &
potential_acoustic,potential_dot_dot_acoustic, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz, &
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
rhostore,jacobian,ibool, &
- ispec_is_inner,ispec_is_acoustic)
+ num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic,&
+ phase_ispec_inner_acoustic )
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call compute_forces_acoustic_pot( iphase, NSPEC_ADJOINT,NGLOB_ADJOINT, &
+ b_potential_acoustic,b_potential_dot_dot_acoustic, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ rhostore,jacobian,ibool, &
+ num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic,&
+ phase_ispec_inner_acoustic )
+
if(PML) then
call compute_forces_acoustic_PML(NSPEC_AB,NGLOB_AB, &
@@ -138,7 +143,7 @@
num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
- endif
+ endif ! PML
! absorbing boundaries
if(ABSORBING_CONDITIONS) then
@@ -154,40 +159,52 @@
chi1_dot,chi2_t,chi2_t_dot,chi3_dot,chi4_dot,&
chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
else
- call acoustic_absorbing_boundaries(NSPEC_AB,NGLOB_AB, &
+ call compute_stacey_acoustic(NSPEC_AB,NGLOB_AB, &
potential_dot_dot_acoustic,potential_dot_acoustic, &
ibool,ispec_is_inner,phase_is_inner, &
- abs_boundary_jacobian2Dw, &
- abs_boundary_ijk,abs_boundary_ispec, &
- num_abs_boundary_faces, &
- rhostore,kappastore, &
- ispec_is_acoustic)
-
+ abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces,rhostore,kappastore,ispec_is_acoustic, &
+ SIMULATION_TYPE,SAVE_FORWARD,NSTEP,it,myrank,NGLOB_ADJOINT, &
+ b_potential_dot_dot_acoustic,b_reclen_potential, &
+ b_absorb_potential,b_num_abs_boundary_faces)
endif
endif
! elastic coupling
- if(ELASTIC_SIMULATION ) &
- call acoustic_coupling_elastic(NSPEC_AB,NGLOB_AB, &
+ if(ELASTIC_SIMULATION ) then
+ call compute_coupling_acoustic_el(NSPEC_AB,NGLOB_AB, &
ibool,displ,potential_dot_dot_acoustic, &
num_coupling_ac_el_faces, &
coupling_ac_el_ispec,coupling_ac_el_ijk, &
coupling_ac_el_normal, &
coupling_ac_el_jacobian2Dw, &
ispec_is_inner,phase_is_inner)
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call compute_coupling_acoustic_el(NSPEC_ADJOINT,NGLOB_ADJOINT, &
+ ibool,b_displ,b_potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+ endif
-! poroelastic coupling
- if(POROELASTIC_SIMULATION ) &
- call acoustic_coupling_poroelastic()
+! poroelastic coupling
+! not implemented yet
+ !if(POROELASTIC_SIMULATION ) &
+ ! call compute_coupling_acoustic_poro()
! sources
- call acoustic_sources(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
+ call compute_add_sources_acoustic(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
ibool,ispec_is_inner,phase_is_inner, &
NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
xi_source,eta_source,gamma_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0, &
- sourcearrays,kappastore, &
- ispec_is_acoustic)
+ hdur,hdur_gaussian,t_cmt,dt,t0, &
+ sourcearrays,kappastore,ispec_is_acoustic,&
+ SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ nadj_rec_local,adj_sourcearrays,b_potential_dot_dot_acoustic )
! assemble all the contributions between slices using MPI
if( phase_is_inner .eqv. .false. ) then
@@ -198,6 +215,14 @@
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
my_neighbours_ext_mesh, &
request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call assemble_MPI_scalar_ext_mesh_s(NPROC,NGLOB_ADJOINT,b_potential_dot_dot_acoustic, &
+ b_buffer_send_scalar_ext_mesh,b_buffer_recv_scalar_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh, &
+ b_request_send_scalar_ext_mesh,b_request_recv_scalar_ext_mesh)
else
! waits for send/receive requests to be completed and assembles values
call assemble_MPI_scalar_ext_mesh_w(NPROC,NGLOB_AB,potential_dot_dot_acoustic, &
@@ -205,6 +230,14 @@
max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call assemble_MPI_scalar_ext_mesh_w(NPROC,NGLOB_ADJOINT,b_potential_dot_dot_acoustic, &
+ b_buffer_recv_scalar_ext_mesh,num_interfaces_ext_mesh,&
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ b_request_send_scalar_ext_mesh,b_request_recv_scalar_ext_mesh)
+
endif
@@ -213,6 +246,11 @@
! divides pressure with mass matrix
potential_dot_dot_acoustic(:) = potential_dot_dot_acoustic(:) * rmass_acoustic(:)
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) &
+ b_potential_dot_dot_acoustic(:) = b_potential_dot_dot_acoustic(:) * rmass_acoustic(:)
+
+
if(PML) then
! divides local contributions with mass term
call PML_acoustic_mass_update(NSPEC_AB,NGLOB_AB,&
@@ -246,6 +284,10 @@
! updates the chi_dot term which requires chi_dot_dot(t+delta)
potential_dot_acoustic(:) = potential_dot_acoustic(:) + deltatover2*potential_dot_dot_acoustic(:)
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) &
+ b_potential_dot_acoustic(:) = b_potential_dot_acoustic(:) + deltatover2*b_potential_dot_dot_acoustic(:)
+
! updates potential_dot_acoustic and potential_dot_dot_acoustic inside PML region for plotting seismograms/movies
if(PML) call PML_acoustic_update_potentials(NGLOB_AB,NSPEC_AB, &
ibool,ispec_is_acoustic, &
@@ -263,11 +305,17 @@
! enforces free surface (zeroes potentials at free surface)
call acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
- ibool, &
- free_surface_ijk,free_surface_ispec, &
- num_free_surface_faces, &
- ispec_is_acoustic)
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic)
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) &
+ call acoustic_enforce_free_surface(NSPEC_AB,NGLOB_ADJOINT, &
+ b_potential_acoustic,b_potential_dot_acoustic,b_potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic)
+
+
if(PML) call PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB, &
potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
ibool,free_surface_ijk,free_surface_ispec, &
@@ -287,513 +335,11 @@
!-------------------------------------------------------------------------------------------------
!
-subroutine acoustic_pressure( phase_is_inner, NSPEC_AB,NGLOB_AB, &
- potential_acoustic,potential_dot_dot_acoustic, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- rhostore,jacobian,ibool, &
- ispec_is_inner,ispec_is_acoustic )
-! compute forces for the acoustic elements
-!
-! note that pressure is defined as:
-! p = - Chi_dot_dot
-!
- use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,TINYVAL_SNGL
- use PML_par,only:PML,ispec_is_PML_inum
- implicit none
- !include "constants.h"
- integer :: NSPEC_AB,NGLOB_AB
-
-! acoustic potentials
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: &
- potential_acoustic,potential_dot_dot_acoustic
-
-! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
- rhostore,jacobian
-
-! array with derivatives of Lagrange polynomials and precalculated products
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
-! local variables
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: chi_elem
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1,temp2,temp3
- real(kind=CUSTOM_REAL) temp1l,temp2l,temp3l
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
- real(kind=CUSTOM_REAL) rho_invl
-
- integer :: ispec,iglob,i,j,k,l
-
-! loop over spectral elements
- do ispec = 1,NSPEC_AB
-
- if ( (ispec_is_inner(ispec) .eqv. phase_is_inner) ) then
-
- ! only elements outside PML, inside "regular" domain
- if( PML ) then
- if( ispec_is_PML_inum(ispec) > 0 ) then
- cycle
- endif
- endif
-
- if( ispec_is_acoustic(ispec) ) then
-
- ! gets values for element
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- chi_elem(i,j,k) = potential_acoustic(ibool(i,j,k,ispec))
- enddo
- enddo
- enddo
- ! would check if anything to do, but might lower accuracy of computation
- !if( maxval( abs( chi_elem ) ) < TINYVAL_SNGL ) cycle
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- ! density (reciproc)
- rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
-
- ! derivative along x, y, z
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the loops because NGLLX == NGLLY == NGLLZ
- temp1l = 0._CUSTOM_REAL
- temp2l = 0._CUSTOM_REAL
- temp3l = 0._CUSTOM_REAL
- do l = 1,NGLLX
- !temp1l = temp1l + potential_acoustic(ibool(l,j,k,ispec))*hprime_xx(i,l)
- !temp2l = temp2l + potential_acoustic(ibool(i,l,k,ispec))*hprime_yy(j,l)
- !temp3l = temp3l + potential_acoustic(ibool(i,j,l,ispec))*hprime_zz(k,l)
- temp1l = temp1l + chi_elem(l,j,k)*hprime_xx(i,l)
- temp2l = temp2l + chi_elem(i,l,k)*hprime_yy(j,l)
- temp3l = temp3l + chi_elem(i,j,l)*hprime_zz(k,l)
- enddo
-
- ! get derivatives of potential with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
- jacobianl = jacobian(i,j,k,ispec)
-
- ! derivatives of potential
- dpotentialdxl = xixl*temp1l + etaxl*temp2l + gammaxl*temp3l
- dpotentialdyl = xiyl*temp1l + etayl*temp2l + gammayl*temp3l
- dpotentialdzl = xizl*temp1l + etazl*temp2l + gammazl*temp3l
-
- ! for acoustic medium
- ! also add GLL integration weights
- temp1(i,j,k) = rho_invl * wgllwgll_yz(j,k) * jacobianl* &
- (xixl*dpotentialdxl + xiyl*dpotentialdyl + xizl*dpotentialdzl)
- temp2(i,j,k) = rho_invl * wgllwgll_xz(i,k) * jacobianl* &
- (etaxl*dpotentialdxl + etayl*dpotentialdyl + etazl*dpotentialdzl)
- temp3(i,j,k) = rho_invl * wgllwgll_xy(i,j) * jacobianl* &
- (gammaxl*dpotentialdxl + gammayl*dpotentialdyl + gammazl*dpotentialdzl)
- enddo
- enddo
- enddo
-
- ! second double-loop over GLL to compute all the terms
- do k = 1,NGLLZ
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- ! along x,y,z direction
- ! and assemble the contributions
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ
- temp1l = 0._CUSTOM_REAL
- temp2l = 0._CUSTOM_REAL
- temp3l = 0._CUSTOM_REAL
- do l=1,NGLLX
- temp1l = temp1l + temp1(l,j,k) * hprimewgll_xx(l,i)
- temp2l = temp2l + temp2(i,l,k) * hprimewgll_yy(l,j)
- temp3l = temp3l + temp3(i,j,l) * hprimewgll_zz(l,k)
- enddo
-
- ! sum contributions from each element to the global values
- iglob = ibool(i,j,k,ispec)
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
- - ( temp1l + temp2l + temp3l )
-
- enddo
- enddo
- enddo
-
- endif ! end of test if acoustic element
- endif ! ispec_is_inner
-
- enddo ! end of loop over all spectral elements
-
-end subroutine acoustic_pressure
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
-subroutine acoustic_absorbing_boundaries(NSPEC_AB,NGLOB_AB, &
- potential_dot_dot_acoustic,potential_dot_acoustic, &
- ibool,ispec_is_inner,phase_is_inner, &
- abs_boundary_jacobian2Dw, &
- abs_boundary_ijk,abs_boundary_ispec, &
- num_abs_boundary_faces, &
- rhostore,kappastore, &
- ispec_is_acoustic)
-
- implicit none
-
- include "constants.h"
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! potentials
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic,&
- potential_dot_acoustic
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rhostore,kappastore
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
-! absorbing boundary surface
- integer :: num_abs_boundary_faces
- real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
- integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
- integer :: abs_boundary_ispec(num_abs_boundary_faces)
-
-! local parameters
- real(kind=CUSTOM_REAL) :: rhol,cpl,jacobianw !weight,jacobianl
- integer :: ispec,iglob,i,j,k,iface,igll
-
-! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
- do iface=1,num_abs_boundary_faces
-
- ispec = abs_boundary_ispec(iface)
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- if( ispec_is_acoustic(ispec) ) then
-
- ! reference gll points on boundary face
- do igll = 1,NGLLSQUARE
-
- ! gets local indices for GLL point
- i = abs_boundary_ijk(1,igll,iface)
- j = abs_boundary_ijk(2,igll,iface)
- k = abs_boundary_ijk(3,igll,iface)
-
- ! gets global index
- iglob=ibool(i,j,k,ispec)
-
- ! determines bulk sound speed
- rhol = rhostore(i,j,k,ispec)
- cpl = sqrt( kappastore(i,j,k,ispec) / rhol )
-
- ! gets associated, weighted jacobian
- jacobianw = abs_boundary_jacobian2Dw(igll,iface)
-
- ! Sommerfeld condition
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob) * jacobianw / cpl / rhol
-
- enddo
-
- endif ! ispec_is_acoustic
- endif ! ispec_is_inner
- enddo ! num_abs_boundary_faces
-
-end subroutine acoustic_absorbing_boundaries
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine acoustic_coupling_elastic(NSPEC_AB,NGLOB_AB, &
- ibool,displ,potential_dot_dot_acoustic, &
- num_coupling_ac_el_faces, &
- coupling_ac_el_ispec,coupling_ac_el_ijk, &
- coupling_ac_el_normal, &
- coupling_ac_el_jacobian2Dw, &
- ispec_is_inner,phase_is_inner)
-
-! returns the updated pressure array: potential_dot_dot_acoustic
-
- implicit none
- include 'constants.h'
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! displacement and pressure
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
-
-! global indexing
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
-! acoustic-elastic coupling surface
- integer :: num_coupling_ac_el_faces
- real(kind=CUSTOM_REAL) :: coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)
- real(kind=CUSTOM_REAL) :: coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)
- integer :: coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)
- integer :: coupling_ac_el_ispec(num_coupling_ac_el_faces)
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
-! local parameters
- real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n
- real(kind=CUSTOM_REAL) :: nx,ny,nz,jacobianw
-
- integer :: iface,igll,ispec,iglob
- integer :: i,j,k
-
-! loops on all coupling faces
- do iface = 1,num_coupling_ac_el_faces
-
- ! gets corresponding elements
- ! (note: can be either acoustic or elastic element, no need to specify since
- ! no material properties are needed for this coupling term)
- ispec = coupling_ac_el_ispec(iface)
-
- if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
-
- ! loops over common GLL points
- do igll = 1, NGLLSQUARE
- i = coupling_ac_el_ijk(1,igll,iface)
- j = coupling_ac_el_ijk(2,igll,iface)
- k = coupling_ac_el_ijk(3,igll,iface)
-
- ! gets global index of this common GLL point
- ! (note: should be the same as for corresponding i',j',k',ispec_elastic or ispec_acoustic)
- iglob = ibool(i,j,k,ispec)
-
- ! elastic displacement on global point
- displ_x = displ(1,iglob)
- displ_y = displ(2,iglob)
- displ_z = displ(3,iglob)
-
- ! gets associated normal on GLL point
- ! (note convention: pointing outwards of acoustic element)
- nx = coupling_ac_el_normal(1,igll,iface)
- ny = coupling_ac_el_normal(2,igll,iface)
- nz = coupling_ac_el_normal(3,igll,iface)
-
- ! calculates displacement component along normal
- ! (normal points outwards of acoustic element)
- displ_n = displ_x*nx + displ_y*ny + displ_z*nz
-
- ! gets associated, weighted jacobian
- jacobianw = coupling_ac_el_jacobian2Dw(igll,iface)
-
- ! continuity of pressure and normal displacement on global point
- !
- ! note: newark time scheme together with definition of scalar potential:
- ! pressure = - chi_dot_dot
- ! requires that this coupling term uses the updated displacement at time step [t+delta_t],
- ! which is done at the very beginning of the time loop
- ! (see e.g. Chaljub & Vilotte, Nissen-Meyer thesis...)
- ! it also means you have to calculate and update this here first before
- ! calculating the coupling on the elastic side for the acceleration...
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + jacobianw*displ_n
-
- enddo ! igll
-
- endif
-
- enddo ! iface
-
-end subroutine acoustic_coupling_elastic
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine acoustic_coupling_poroelastic()
- implicit none
-
- stop 'not yet implemented'
-
-end subroutine acoustic_coupling_poroelastic
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine acoustic_sources(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
- ibool,ispec_is_inner,phase_is_inner, &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
- xi_source,eta_source,gamma_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0, &
- sourcearrays,kappastore, &
- ispec_is_acoustic)
-
- implicit none
-
- include "constants.h"
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
-
-! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: kappastore
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
-! source
- integer :: NSOURCES,myrank,it
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision, dimension(NSOURCES) :: hdur,hdur_gaussian,t_cmt
- double precision :: dt
-
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
-
- double precision, external :: comp_source_time_function
-
- logical, dimension(NSPEC_AB) :: ispec_is_acoustic
-
-! local parameters
- double precision :: t0,f0
- double precision :: stf
- real(kind=CUSTOM_REAL) stf_used
- integer :: isource,iglob,ispec,i,j,k
-
-! adds acoustic sources
- do isource = 1,NSOURCES
-
- ! add the source (only if this proc carries the source)
- if(myrank == islice_selected_source(isource)) then
-
- ispec = ispec_selected_source(isource)
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- if( ispec_is_acoustic(ispec) ) then
-
- if(USE_FORCE_POINT_SOURCE) then
-
- ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
- iglob = ibool(nint(xi_source(isource)), &
- nint(eta_source(isource)), &
- nint(gamma_source(isource)), &
- ispec)
-
- f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
- t0 = 1.2d0/f0
-
- if (it == 1 .and. myrank == 0) then
- print *,'using a source of dominant frequency ',f0
- print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
- print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
- endif
-
- ! gaussian source time function
- !stf_used = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
-
- ! we use nu_source(:,3) here because we want a source normal to the surface.
- ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
- stf_used = 1.d10 * ( 1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0) ) * &
- exp( -PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0) )
-
- ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
- ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
- ! to add minus the source to Chi_dot_dot to get plus the source in pressure:
-
- ! acoustic source for pressure gets divided by kappa
- stf_used = stf_used / kappastore(nint(xi_source(isource)), &
- nint(eta_source(isource)), &
- nint(gamma_source(isource)),ispec)
-
- ! source contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) - stf_used
-
- else
-
- ! gaussian source time
- stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
-
- ! distinguishes between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- stf_used = sngl(stf)
- else
- stf_used = stf
- endif
-
- ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
- ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
- ! to add minus the source to Chi_dot_dot to get plus the source in pressure
-
- ! add source array
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- ! adds source contribution
- ! note: acoustic source for pressure gets divided by kappa
- iglob = ibool(i,j,k,ispec)
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
- - sourcearrays(isource,1,i,j,k) * stf_used / kappastore(i,j,k,ispec)
- enddo
- enddo
- enddo
-
- endif ! USE_FORCE_POINT_SOURCE
- endif ! ispec_is_elastic
- endif ! ispec_is_inner
- endif ! myrank
-
- enddo ! NSOURCES
-
-end subroutine acoustic_sources
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
subroutine acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
- ibool, &
- free_surface_ijk,free_surface_ispec, &
- num_free_surface_faces, &
- ispec_is_acoustic)
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic)
implicit none
include 'constants.h'
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic_pot.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic_pot.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic_pot.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,203 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! for acoustic solver
+
+ subroutine compute_forces_acoustic_pot( iphase, NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_dot_acoustic, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ rhostore,jacobian,ibool, &
+ num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic,&
+ phase_ispec_inner_acoustic )
+
+! computes forces for acoustic elements
+!
+! note that pressure is defined as:
+! p = - Chi_dot_dot
+!
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,TINYVAL_SNGL
+ use PML_par,only:PML,ispec_is_PML_inum
+ implicit none
+ !include "constants.h"
+ integer :: NSPEC_AB,NGLOB_AB
+
+! acoustic potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: &
+ potential_acoustic,potential_dot_dot_acoustic
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ rhostore,jacobian
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+! communication overlap
+! logical, dimension(NSPEC_AB) :: ispec_is_inner
+! logical :: phase_is_inner
+
+! logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ integer :: iphase
+ integer :: num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic
+ integer, dimension(num_phase_ispec_acoustic,2) :: phase_ispec_inner_acoustic
+
+! local variables
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: chi_elem
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1,temp2,temp3
+ real(kind=CUSTOM_REAL) temp1l,temp2l,temp3l
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) rho_invl
+
+ integer :: ispec,iglob,i,j,k,l,ispec_p,num_elements
+
+ if( iphase == 1 ) then
+ num_elements = nspec_outer_acoustic
+ else
+ num_elements = nspec_inner_acoustic
+ endif
+
+! loop over spectral elements
+ do ispec_p = 1,num_elements
+
+ !if ( (ispec_is_inner(ispec) .eqv. phase_is_inner) ) then
+
+ ispec = phase_ispec_inner_acoustic(ispec_p,iphase)
+
+ ! only elements outside PML, inside "regular" domain
+ if( PML ) then
+ if( ispec_is_PML_inum(ispec) > 0 ) then
+ cycle
+ endif
+ endif
+
+! if( ispec_is_acoustic(ispec) ) then
+
+ ! gets values for element
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ chi_elem(i,j,k) = potential_acoustic(ibool(i,j,k,ispec))
+ enddo
+ enddo
+ enddo
+ ! would check if anything to do, but might lower accuracy of computation
+ !if( maxval( abs( chi_elem ) ) < TINYVAL_SNGL ) cycle
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! density (reciproc)
+ rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
+
+ ! derivative along x, y, z
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the loops because NGLLX == NGLLY == NGLLZ
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l = 1,NGLLX
+ temp1l = temp1l + chi_elem(l,j,k)*hprime_xx(i,l)
+ temp2l = temp2l + chi_elem(i,l,k)*hprime_yy(j,l)
+ temp3l = temp3l + chi_elem(i,j,l)*hprime_zz(k,l)
+ enddo
+
+ ! get derivatives of potential with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ jacobianl = jacobian(i,j,k,ispec)
+
+ ! derivatives of potential
+ dpotentialdxl = xixl*temp1l + etaxl*temp2l + gammaxl*temp3l
+ dpotentialdyl = xiyl*temp1l + etayl*temp2l + gammayl*temp3l
+ dpotentialdzl = xizl*temp1l + etazl*temp2l + gammazl*temp3l
+
+ ! for acoustic medium
+ ! also add GLL integration weights
+ temp1(i,j,k) = rho_invl * wgllwgll_yz(j,k) * jacobianl* &
+ (xixl*dpotentialdxl + xiyl*dpotentialdyl + xizl*dpotentialdzl)
+ temp2(i,j,k) = rho_invl * wgllwgll_xz(i,k) * jacobianl* &
+ (etaxl*dpotentialdxl + etayl*dpotentialdyl + etazl*dpotentialdzl)
+ temp3(i,j,k) = rho_invl * wgllwgll_xy(i,j) * jacobianl* &
+ (gammaxl*dpotentialdxl + gammayl*dpotentialdyl + gammazl*dpotentialdzl)
+ enddo
+ enddo
+ enddo
+
+ ! second double-loop over GLL to compute all the terms
+ do k = 1,NGLLZ
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! along x,y,z direction
+ ! and assemble the contributions
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l=1,NGLLX
+ temp1l = temp1l + temp1(l,j,k) * hprimewgll_xx(l,i)
+ temp2l = temp2l + temp2(i,l,k) * hprimewgll_yy(l,j)
+ temp3l = temp3l + temp3(i,j,l) * hprimewgll_zz(l,k)
+ enddo
+
+ ! sum contributions from each element to the global values
+ iglob = ibool(i,j,k,ispec)
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - ( temp1l + temp2l + temp3l )
+
+ enddo
+ enddo
+ enddo
+
+! endif ! end of test if acoustic element
+! endif ! ispec_is_inner
+
+ enddo ! end of loop over all spectral elements
+
+ end subroutine compute_forces_acoustic_pot
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -49,11 +49,11 @@
! elastic term
if(USE_DEVILLE_PRODUCTS) then
- call compute_forces_with_Deville(phase_is_inner, NSPEC_AB,NGLOB_AB,displ,accel, &
+ call compute_forces_elastic_Dev(iphase, NSPEC_AB,NGLOB_AB,displ,accel, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner, &
+ kappastore,mustore,jacobian,ibool, &
ATTENUATION,USE_OLSEN_ATTENUATION, &
one_minus_sum_beta,factor_common,alphaval,betaval,gammaval, &
NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
@@ -64,14 +64,25 @@
c22store,c23store,c24store,c25store,c26store,c33store,&
c34store,c35store,c36store,c44store,c45store,c46store,&
c55store,c56store,c66store, &
- ispec_is_elastic )
+ SIMULATION_TYPE,NGLOB_ADJOINT,NSPEC_ADJOINT, &
+ b_displ,b_accel,kappa_kl,mu_kl,deltat, &
+ NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL,&
+ is_moho_top,is_moho_bot, &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot, &
+ ispec2D_moho_top,ispec2D_moho_bot, &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz, &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy, &
+ b_epsilondev_xz,b_epsilondev_yz, &
+ b_alphaval,b_betaval,b_gammaval,&
+ num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic,&
+ phase_ispec_inner_elastic )
else
- call compute_forces_no_Deville( phase_is_inner, NSPEC_AB,NGLOB_AB,displ,accel, &
+ call compute_forces_elastic_noDev( iphase, NSPEC_AB,NGLOB_AB,displ,accel, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz, &
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,&
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner, &
+ kappastore,mustore,jacobian,ibool, &
ATTENUATION,USE_OLSEN_ATTENUATION,&
one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,&
NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
@@ -82,22 +93,35 @@
c22store,c23store,c24store,c25store,c26store,c33store,&
c34store,c35store,c36store,c44store,c45store,c46store,&
c55store,c56store,c66store, &
- ispec_is_elastic )
+ SIMULATION_TYPE,NGLOB_ADJOINT,NSPEC_ADJOINT, &
+ b_displ,b_accel,kappa_kl,mu_kl,deltat, &
+ NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL,&
+ is_moho_top,is_moho_bot, &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot, &
+ ispec2D_moho_top,ispec2D_moho_bot, &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz, &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy, &
+ b_epsilondev_xz,b_epsilondev_yz, &
+ b_alphaval,b_betaval,b_gammaval,&
+ num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic,&
+ phase_ispec_inner_elastic )
endif
! adds elastic absorbing boundary term to acceleration (Stacey conditions)
if(ABSORBING_CONDITIONS) &
- call elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
+ call compute_stacey_elastic(NSPEC_AB,NGLOB_AB,accel, &
ibool,ispec_is_inner,phase_is_inner, &
abs_boundary_normal,abs_boundary_jacobian2Dw, &
abs_boundary_ijk,abs_boundary_ispec, &
num_abs_boundary_faces, &
veloc,rho_vp,rho_vs, &
- ispec_is_elastic )
+ ispec_is_elastic,SIMULATION_TYPE,myrank,SAVE_FORWARD, &
+ NSTEP,it,NGLOB_ADJOINT,b_accel, &
+ b_num_abs_boundary_faces,b_reclen_field,b_absorb_field )
! acoustic coupling
- if( ACOUSTIC_SIMULATION ) &
- call elastic_coupling_acoustic(NSPEC_AB,NGLOB_AB, &
+ if( ACOUSTIC_SIMULATION ) then
+ call compute_coupling_elastic_ac(NSPEC_AB,NGLOB_AB, &
ibool,accel,potential_dot_dot_acoustic, &
num_coupling_ac_el_faces, &
coupling_ac_el_ispec,coupling_ac_el_ijk, &
@@ -105,17 +129,32 @@
coupling_ac_el_jacobian2Dw, &
ispec_is_inner,phase_is_inner)
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call compute_coupling_elastic_ac(NSPEC_ADJOINT,NGLOB_ADJOINT, &
+ ibool,b_accel,b_potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+ endif
+
+
! poroelastic coupling
- if( POROELASTIC_SIMULATION ) &
- call elastic_coupling_poroelastic()
+! not implemented yet
+! if( POROELASTIC_SIMULATION ) &
+! call compute_coupling_elastic_poro()
! adds source term (single-force/moment-tensor solution)
- call elastic_sources( NSPEC_AB,NGLOB_AB,accel, &
+ call compute_add_sources_elastic( NSPEC_AB,NGLOB_AB,accel, &
ibool,ispec_is_inner,phase_is_inner, &
NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
- ispec_is_elastic )
+ hdur,hdur_gaussian,t_cmt,dt,t0,sourcearrays, &
+ ispec_is_elastic,SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ nadj_rec_local,adj_sourcearrays,b_accel )
! assemble all the contributions between slices using MPI
if( phase_is_inner .eqv. .false. ) then
@@ -126,6 +165,17 @@
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
my_neighbours_ext_mesh, &
request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ call assemble_MPI_vector_ext_mesh_s(NPROC,NGLOB_ADJOINT,b_accel, &
+ b_buffer_send_vector_ext_mesh,b_buffer_recv_vector_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh, &
+ b_request_send_vector_ext_mesh,b_request_recv_vector_ext_mesh)
+ endif !adjoint
+
else
! waits for send/receive requests to be completed and assembles values
call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,accel, &
@@ -133,6 +183,16 @@
max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_ADJOINT,b_accel, &
+ b_buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,&
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ b_request_send_vector_ext_mesh,b_request_recv_vector_ext_mesh)
+ endif !adjoint
+
endif
!! DK DK May 2009: removed this because now each slice of a CUBIT + SCOTCH mesh
@@ -147,21 +207,22 @@
accel(1,:) = accel(1,:)*rmass(:)
accel(2,:) = accel(2,:)*rmass(:)
accel(3,:) = accel(3,:)*rmass(:)
-
- !! DK DK array not created yet for CUBIT
- ! if (SIMULATION_TYPE == 3) then
- ! b_accel(1,:) = b_accel(1,:)*rmass(:)
- ! b_accel(2,:) = b_accel(2,:)*rmass(:)
- ! b_accel(3,:) = b_accel(3,:)*rmass(:)
- ! endif
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_accel(1,:) = b_accel(1,:)*rmass(:)
+ b_accel(2,:) = b_accel(2,:)*rmass(:)
+ b_accel(3,:) = b_accel(3,:)*rmass(:)
+ endif !adjoint
+
! updates acceleration with ocean load term
if(OCEANS) then
call elastic_ocean_load(NSPEC_AB,NGLOB_AB, &
ibool,rmass,rmass_ocean_load,accel, &
free_surface_normal,free_surface_ijk,free_surface_ispec, &
- num_free_surface_faces)
+ num_free_surface_faces,SIMULATION_TYPE, &
+ NGLOB_ADJOINT,b_accel)
endif
! updates velocities
@@ -182,8 +243,8 @@
! updates the velocity term which requires a(t+delta)
veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
- !! DK DK array not created yet for CUBIT
- ! if (SIMULATION_TYPE == 3) b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
end subroutine compute_forces_elastic
@@ -193,331 +254,11 @@
!-------------------------------------------------------------------------------------------------
!
-! absorbing boundary term for elastic media (Stacey conditions)
-
-subroutine elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
- ibool,ispec_is_inner,phase_is_inner, &
- abs_boundary_normal,abs_boundary_jacobian2Dw, &
- abs_boundary_ijk,abs_boundary_ispec, &
- num_abs_boundary_faces, &
- veloc,rho_vp,rho_vs, &
- ispec_is_elastic)
-
- implicit none
-
- include "constants.h"
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
-! Stacey conditions
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
-
- logical, dimension(NSPEC_AB) :: ispec_is_elastic
-
-! absorbing boundary surface
- integer :: num_abs_boundary_faces
- real(kind=CUSTOM_REAL) :: abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces)
- real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
- integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
- integer :: abs_boundary_ispec(num_abs_boundary_faces)
-
-
-! local parameters
- real(kind=CUSTOM_REAL) vx,vy,vz,nx,ny,nz,tx,ty,tz,vn,jacobianw !weight,jacobianl
- integer :: ispec,iglob,i,j,k,iface,igll
- !integer :: num_gll !,igll_i,igll_j,ispec2D
-
-
-! absorbs absorbing-boundary surface using Stacey condition (Clayton & Enquist)
- do iface=1,num_abs_boundary_faces
-
- ispec = abs_boundary_ispec(iface)
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- if( ispec_is_elastic(ispec) ) then
-
- ! reference gll points on boundary face
- do igll = 1,NGLLSQUARE
-
- ! gets local indices for GLL point
- i = abs_boundary_ijk(1,igll,iface)
- j = abs_boundary_ijk(2,igll,iface)
- k = abs_boundary_ijk(3,igll,iface)
-
- ! gets velocity
- iglob=ibool(i,j,k,ispec)
- vx=veloc(1,iglob)
- vy=veloc(2,iglob)
- vz=veloc(3,iglob)
-
- ! gets associated normal
- nx = abs_boundary_normal(1,igll,iface)
- ny = abs_boundary_normal(2,igll,iface)
- nz = abs_boundary_normal(3,igll,iface)
-
- ! velocity component in normal direction (normal points out of element)
- vn = vx*nx + vy*ny + vz*nz
-
- ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
- tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
- ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
- tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
-
- ! gets associated, weighted jacobian
- jacobianw = abs_boundary_jacobian2Dw(igll,iface)
-
- ! adds stacey term (weak form)
- accel(1,iglob) = accel(1,iglob) - tx*jacobianw
- accel(2,iglob) = accel(2,iglob) - ty*jacobianw
- accel(3,iglob) = accel(3,iglob) - tz*jacobianw
-
- enddo
- endif ! ispec_is_elastic
- endif ! ispec_is_inner
- enddo
-
-end subroutine elastic_absorbing_boundaries
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine elastic_coupling_acoustic(NSPEC_AB,NGLOB_AB, &
- ibool,accel,potential_dot_dot_acoustic, &
- num_coupling_ac_el_faces, &
- coupling_ac_el_ispec,coupling_ac_el_ijk, &
- coupling_ac_el_normal, &
- coupling_ac_el_jacobian2Dw, &
- ispec_is_inner,phase_is_inner)
-
-! returns the updated acceleration array: accel
-
- implicit none
- include 'constants.h'
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! displacement and pressure
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
-
-! global indexing
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
-! acoustic-elastic coupling surface
- integer :: num_coupling_ac_el_faces
- real(kind=CUSTOM_REAL) :: coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)
- real(kind=CUSTOM_REAL) :: coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)
- integer :: coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)
- integer :: coupling_ac_el_ispec(num_coupling_ac_el_faces)
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
-! local parameters
- real(kind=CUSTOM_REAL) :: pressure
- real(kind=CUSTOM_REAL) :: nx,ny,nz,jacobianw
-
- integer :: iface,igll,ispec,iglob
- integer :: i,j,k
-
-! loops on all coupling faces
- do iface = 1,num_coupling_ac_el_faces
-
- ! gets corresponding spectral element
- ! (note: can be either acoustic or elastic element, no need to specify since
- ! no material properties are needed for this coupling term)
- ispec = coupling_ac_el_ispec(iface)
-
- if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
-
- ! loops over common GLL points
- do igll = 1, NGLLSQUARE
- i = coupling_ac_el_ijk(1,igll,iface)
- j = coupling_ac_el_ijk(2,igll,iface)
- k = coupling_ac_el_ijk(3,igll,iface)
-
- ! gets global index of this common GLL point
- ! (note: should be the same as for corresponding i',j',k',ispec_elastic or ispec_elastic )
- iglob = ibool(i,j,k,ispec)
-
- ! acoustic pressure on global point
- pressure = - potential_dot_dot_acoustic(iglob)
-
- ! gets associated normal on GLL point
- ! (note convention: pointing outwards of acoustic element)
- nx = coupling_ac_el_normal(1,igll,iface)
- ny = coupling_ac_el_normal(2,igll,iface)
- nz = coupling_ac_el_normal(3,igll,iface)
-
- ! gets associated, weighted 2D jacobian
- ! (note: should be the same for elastic and acoustic element)
- jacobianw = coupling_ac_el_jacobian2Dw(igll,iface)
-
- ! continuity of displacement and pressure on global point
- !
- ! note: newark time scheme together with definition of scalar potential:
- ! pressure = - chi_dot_dot
- ! requires that this coupling term uses the *UPDATED* pressure (chi_dot_dot), i.e.
- ! pressure at time step [t + delta_t]
- ! (see e.g. Chaljub & Vilotte, Nissen-Meyer thesis...)
- ! it means you have to calculate and update the acoustic pressure first before
- ! calculating this term...
- accel(1,iglob) = accel(1,iglob) + jacobianw*nx*pressure
- accel(2,iglob) = accel(2,iglob) + jacobianw*ny*pressure
- accel(3,iglob) = accel(3,iglob) + jacobianw*nz*pressure
-
- enddo ! igll
-
- endif
-
- enddo ! iface
-
-end subroutine elastic_coupling_acoustic
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine elastic_coupling_poroelastic()
- implicit none
-
-end subroutine elastic_coupling_poroelastic
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine elastic_sources( NSPEC_AB,NGLOB_AB,accel, &
- ibool,ispec_is_inner,phase_is_inner, &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
- xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
- ispec_is_elastic )
-
- implicit none
-
- include "constants.h"
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
-
-! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
-! source
- integer :: NSOURCES,myrank,it
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision, dimension(3,3,NSOURCES) :: nu_source
- double precision, dimension(NSOURCES) :: hdur,hdur_gaussian,t_cmt
- double precision :: dt
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
-
- double precision, external :: comp_source_time_function
-
- logical, dimension(NSPEC_AB) :: ispec_is_elastic
-
-! local parameters
- double precision :: t0,f0
- double precision :: stf
- real(kind=CUSTOM_REAL) stf_used
- integer :: isource,iglob,i,j,k,ispec
-
- do isource = 1,NSOURCES
-
- ! add the source (only if this proc carries the source)
- if(myrank == islice_selected_source(isource)) then
-
- ispec = ispec_selected_source(isource)
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- if( ispec_is_elastic(ispec) ) then
-
- if(USE_FORCE_POINT_SOURCE) then
-
- ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
- iglob = ibool(nint(xi_source(isource)), &
- nint(eta_source(isource)), &
- nint(gamma_source(isource)), &
- ispec_selected_source(isource))
-
- f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
- t0 = 1.2d0/f0
-
- if (it == 1 .and. myrank == 0) then
- print *,'using a source of dominant frequency ',f0
- print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
- print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
- endif
-
- ! we use nu_source(:,3) here because we want a source normal to the surface.
- ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
- !accel(:,iglob) = accel(:,iglob) + &
- ! sngl(nu_source(:,3,isource) * 10000000.d0 * &
- ! (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
- ! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
- accel(:,iglob) = accel(:,iglob) + &
- sngl( nu_source(:,3,isource) * 1.d10 * &
- (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
- exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) )
-
- else
-
- stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- stf_used = sngl(stf)
- else
- stf_used = stf
- endif
-
- ! add source array
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- accel(:,iglob) = accel(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
- enddo
- enddo
- enddo
-
- endif ! USE_FORCE_POINT_SOURCE
- endif ! ispec_is_elastic
- endif ! ispec_is_inner
- endif ! myrank
-
- enddo ! NSOURCES
-
-end subroutine elastic_sources
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
subroutine elastic_ocean_load(NSPEC_AB,NGLOB_AB, &
ibool,rmass,rmass_ocean_load,accel, &
free_surface_normal,free_surface_ijk,free_surface_ispec, &
- num_free_surface_faces)
+ num_free_surface_faces,SIMULATION_TYPE, &
+ NGLOB_ADJOINT,b_accel)
! updates acceleration with ocean load term:
! approximates ocean-bottom continuity of pressure & displacement for longer period waves (> ~20s ),
@@ -534,33 +275,30 @@
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
-! free surface
+ ! free surface
integer :: num_free_surface_faces
real(kind=CUSTOM_REAL) :: free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces)
integer :: free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)
integer :: free_surface_ispec(num_free_surface_faces)
+ ! adjoint simulations
+ integer :: SIMULATION_TYPE,NGLOB_ADJOINT
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_ADJOINT):: b_accel
+
! local parameters
real(kind=CUSTOM_REAL) :: nx,ny,nz
real(kind=CUSTOM_REAL) :: additional_term,force_normal_comp
integer :: i,j,k,ispec,iglob
integer :: igll,iface
logical,dimension(NGLOB_AB) :: updated_dof_ocean_load
+ ! adjoint locals
+ real(kind=CUSTOM_REAL) :: b_additional_term,b_force_normal_comp
-! initialize the updates
+ ! initialize the updates
updated_dof_ocean_load(:) = .false.
-! for surface elements exactly at the top of the model (ocean bottom)
-! do ispec2D = 1,NSPEC2D_TOP
-
+ ! for surface elements exactly at the top of the model (ocean bottom)
do iface = 1,num_free_surface_faces
-
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
-
-! only for DOFs exactly at the top of the model (ocean bottom)
-! k = NGLLZ
-! do j = 1,NGLLY
-! do i = 1,NGLLX
ispec = free_surface_ispec(iface)
do igll = 1, NGLLSQUARE
@@ -568,26 +306,23 @@
j = free_surface_ijk(2,igll,iface)
k = free_surface_ijk(3,igll,iface)
-! get global point number
+ ! get global point number
iglob = ibool(i,j,k,ispec)
-! only update once
+ ! only update once
if(.not. updated_dof_ocean_load(iglob)) then
! get normal
- !! DK DK array not created yet for CUBIT nx = normal_top(1,i,j,ispec2D)
- !! DK DK array not created yet for CUBIT ny = normal_top(2,i,j,ispec2D)
- !! DK DK array not created yet for CUBIT nz = normal_top(3,i,j,ispec2D)
nx = free_surface_normal(1,igll,iface)
ny = free_surface_normal(2,igll,iface)
nz = free_surface_normal(3,igll,iface)
-! make updated component of right-hand side
-! we divide by rmass() which is 1 / M
-! we use the total force which includes the Coriolis term above
+ ! make updated component of right-hand side
+ ! we divide by rmass() which is 1 / M
+ ! we use the total force which includes the Coriolis term above
force_normal_comp = ( accel(1,iglob)*nx + &
- accel(2,iglob)*ny + &
- accel(3,iglob)*nz ) / rmass(iglob)
+ accel(2,iglob)*ny + &
+ accel(3,iglob)*nz ) / rmass(iglob)
additional_term = (rmass_ocean_load(iglob) - rmass(iglob)) * force_normal_comp
@@ -595,26 +330,23 @@
accel(2,iglob) = accel(2,iglob) + additional_term * ny
accel(3,iglob) = accel(3,iglob) + additional_term * nz
- !if (SIMULATION_TYPE == 3) then
- !! DK DK array not created yet for CUBIT
- ! b_force_normal_comp = (b_accel(1,iglob)*nx + &
- ! b_accel(2,iglob)*ny + b_accel(3,iglob)*nz) / rmass(iglob)
- ! b_additional_term = (rmass_ocean_load(iglob) - rmass(iglob)) * b_force_normal_comp
- !! DK DK array not created yet for CUBIT
- ! b_accel(1,iglob) = b_accel(1,iglob) + b_additional_term * nx
- ! b_accel(2,iglob) = b_accel(2,iglob) + b_additional_term * ny
- ! b_accel(3,iglob) = b_accel(3,iglob) + b_additional_term * nz
- !endif
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_force_normal_comp = ( b_accel(1,iglob)*nx + &
+ b_accel(2,iglob)*ny + &
+ b_accel(3,iglob)*nz) / rmass(iglob)
+ b_additional_term = (rmass_ocean_load(iglob) - rmass(iglob)) * b_force_normal_comp
+
+ b_accel(1,iglob) = b_accel(1,iglob) + b_additional_term * nx
+ b_accel(2,iglob) = b_accel(2,iglob) + b_additional_term * ny
+ b_accel(3,iglob) = b_accel(3,iglob) + b_additional_term * nz
+ endif !adjoint
! done with this point
updated_dof_ocean_load(iglob) = .true.
endif
-! enddo ! NGLLX
-! enddo ! NGLLY
-! enddo ! NSPEC2D_TOP
-
enddo ! igll
enddo ! iface
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic_Dev.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic_Dev.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic_Dev.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,1134 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+subroutine compute_forces_elastic_Dev( iphase ,NSPEC_AB,NGLOB_AB, &
+ displ,accel, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool, &
+ ATTENUATION,USE_OLSEN_ATTENUATION, &
+ one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,&
+ NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
+ epsilondev_xz,epsilondev_yz,iflag_attenuation_store, &
+ rho_vs, &
+ ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store, &
+ SIMULATION_TYPE,NGLOB_ADJOINT,NSPEC_ADJOINT, &
+ b_displ,b_accel,kappa_kl,mu_kl,deltat, &
+ NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL, &
+ is_moho_top,is_moho_bot, &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot, &
+ ispec2D_moho_top,ispec2D_moho_bot, &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz, &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy, &
+ b_epsilondev_xz,b_epsilondev_yz, &
+ b_alphaval,b_betaval,b_gammaval, &
+ num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic,&
+ phase_ispec_inner_elastic)
+
+
+! computes elastic tensor term
+
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,NDIM, &
+ NUM_REGIONS_ATTENUATION,N_SLS,SAVE_MOHO_MESH, &
+ ONE_THIRD,FOUR_THIRDS,m1,m2
+ implicit none
+
+ !include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ,accel
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ kappastore,mustore,jacobian
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+! communication overlap
+ !logical, dimension(NSPEC_AB) :: ispec_is_inner
+ !logical :: phase_is_inner
+
+! memory variables and standard linear solids for attenuation
+ logical :: ATTENUATION,USE_OLSEN_ATTENUATION
+ integer :: NSPEC_ATTENUATION_AB
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
+ R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vs
+
+! anisotropy
+ logical :: ANISOTROPY
+ integer :: NSPEC_ANISO
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, &
+ c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store
+
+ !logical,dimension(NSPEC_AB) :: ispec_is_elastic
+ integer :: iphase
+ integer :: num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic
+ integer, dimension(num_phase_ispec_elastic,2) :: phase_ispec_inner_elastic
+
+! adjoint simulations
+ integer :: SIMULATION_TYPE
+ integer :: NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL
+ integer :: NGLOB_ADJOINT,NSPEC_ADJOINT
+
+ ! moho kernel
+ real(kind=CUSTOM_REAL),dimension(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO):: &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot
+ logical,dimension(NSPEC_BOUN) :: is_moho_top,is_moho_bot
+ integer :: ispec2D_moho_top, ispec2D_moho_bot
+
+ ! adjoint memory variables
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS) :: &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL) :: &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy,b_epsilondev_xz,b_epsilondev_yz
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: b_alphaval,b_betaval,b_gammaval
+
+ ! adjoint wavefields
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_ADJOINT):: b_displ,b_accel
+ ! adjoint kernels
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT) :: &
+ mu_kl, kappa_kl
+ real(kind=CUSTOM_REAL) :: deltat
+
+!adjoint
+
+! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
+ newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ ! manually inline the calls to the Deville et al. (2002) routines
+ real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: E1_m1_m2_5points,E2_m1_m2_5points,E3_m1_m2_5points
+
+ equivalence(dummyx_loc,B1_m1_m2_5points)
+ equivalence(dummyy_loc,B2_m1_m2_5points)
+ equivalence(dummyz_loc,B3_m1_m2_5points)
+ equivalence(tempx1,C1_m1_m2_5points)
+ equivalence(tempy1,C2_m1_m2_5points)
+ equivalence(tempz1,C3_m1_m2_5points)
+ equivalence(newtempx1,E1_m1_m2_5points)
+ equivalence(newtempy1,E2_m1_m2_5points)
+ equivalence(newtempz1,E3_m1_m2_5points)
+
+ real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: &
+ A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ E1_mxm_m2_m1_5points,E2_mxm_m2_m1_5points,E3_mxm_m2_m1_5points
+
+ equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
+ equivalence(dummyy_loc,A2_mxm_m2_m1_5points)
+ equivalence(dummyz_loc,A3_mxm_m2_m1_5points)
+ equivalence(tempx3,C1_mxm_m2_m1_5points)
+ equivalence(tempy3,C2_mxm_m2_m1_5points)
+ equivalence(tempz3,C3_mxm_m2_m1_5points)
+ equivalence(newtempx3,E1_mxm_m2_m1_5points)
+ equivalence(newtempy3,E2_mxm_m2_m1_5points)
+ equivalence(newtempz3,E3_mxm_m2_m1_5points)
+
+ ! local attenuation parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xx_loc, &
+ epsilondev_yy_loc, epsilondev_xy_loc, epsilondev_xz_loc, epsilondev_yz_loc
+ real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
+ real(kind=CUSTOM_REAL) factor_loc,alphaval_loc,betaval_loc,gammaval_loc,Sn,Snp1
+ real(kind=CUSTOM_REAL) epsilon_trace_over_3
+ real(kind=CUSTOM_REAL) vs_val
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+
+ real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+
+ real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+
+ real(kind=CUSTOM_REAL) fac1,fac2,fac3
+
+ real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) kappal
+
+ ! local anisotropy parameters
+ real(kind=CUSTOM_REAL) c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
+
+ integer i_SLS,iselected
+
+ integer ispec,iglob,ispec_p,num_elements
+ integer i,j,k
+
+ ! adjoint backward arrays
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: b_dummyx_loc,b_dummyy_loc,b_dummyz_loc, &
+ b_newtempx1,b_newtempx2,b_newtempx3,b_newtempy1,b_newtempy2,b_newtempy3,b_newtempz1,b_newtempz2,b_newtempz3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ b_tempx1,b_tempx2,b_tempx3,b_tempy1,b_tempy2,b_tempy3,b_tempz1,b_tempz2,b_tempz3
+ ! backward arrays: manually inline the calls to the Deville et al. (2002) routines
+ real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: b_B1_m1_m2_5points,b_B2_m1_m2_5points,b_B3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: b_C1_m1_m2_5points,b_C2_m1_m2_5points,b_C3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: b_E1_m1_m2_5points,b_E2_m1_m2_5points,b_E3_m1_m2_5points
+ equivalence(b_dummyx_loc,b_B1_m1_m2_5points)
+ equivalence(b_dummyy_loc,b_B2_m1_m2_5points)
+ equivalence(b_dummyz_loc,b_B3_m1_m2_5points)
+ equivalence(b_tempx1,b_C1_m1_m2_5points)
+ equivalence(b_tempy1,b_C2_m1_m2_5points)
+ equivalence(b_tempz1,b_C3_m1_m2_5points)
+ equivalence(b_newtempx1,b_E1_m1_m2_5points)
+ equivalence(b_newtempy1,b_E2_m1_m2_5points)
+ equivalence(b_newtempz1,b_E3_m1_m2_5points)
+ real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: &
+ b_A1_mxm_m2_m1_5points,b_A2_mxm_m2_m1_5points,b_A3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ b_C1_mxm_m2_m1_5points,b_C2_mxm_m2_m1_5points,b_C3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ b_E1_mxm_m2_m1_5points,b_E2_mxm_m2_m1_5points,b_E3_mxm_m2_m1_5points
+ equivalence(b_dummyx_loc,b_A1_mxm_m2_m1_5points)
+ equivalence(b_dummyy_loc,b_A2_mxm_m2_m1_5points)
+ equivalence(b_dummyz_loc,b_A3_mxm_m2_m1_5points)
+ equivalence(b_tempx3,b_C1_mxm_m2_m1_5points)
+ equivalence(b_tempy3,b_C2_mxm_m2_m1_5points)
+ equivalence(b_tempz3,b_C3_mxm_m2_m1_5points)
+ equivalence(b_newtempx3,b_E1_mxm_m2_m1_5points)
+ equivalence(b_newtempy3,b_E2_mxm_m2_m1_5points)
+ equivalence(b_newtempz3,b_E3_mxm_m2_m1_5points)
+ real(kind=CUSTOM_REAL):: dsxx,dsxy,dsxz,dsyy,dsyz,dszz
+ real(kind=CUSTOM_REAL):: b_duxdxl,b_duxdyl,b_duxdzl,b_duydxl,b_duydyl,b_duydzl,b_duzdxl,b_duzdyl,b_duzdzl
+ real(kind=CUSTOM_REAL):: b_duxdxl_plus_duydyl,b_duxdxl_plus_duzdzl,b_duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL):: b_duxdyl_plus_duydxl,b_duzdxl_plus_duxdzl,b_duzdyl_plus_duydzl
+ real(kind=CUSTOM_REAL):: b_dsxx,b_dsxy,b_dsxz,b_dsyy,b_dsyz,b_dszz
+ real(kind=CUSTOM_REAL):: b_sigma_xx,b_sigma_yy,b_sigma_zz,b_sigma_xy,b_sigma_xz,b_sigma_yz
+ real(kind=CUSTOM_REAL):: kappa_k, mu_k
+ ! local adjoint attenuation
+ real(kind=CUSTOM_REAL) b_alphaval_loc,b_betaval_loc,b_gammaval_loc,b_Sn,b_Snp1
+ real(kind=CUSTOM_REAL) b_epsilon_trace_over_3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: b_epsilondev_xx_loc, &
+ b_epsilondev_yy_loc, b_epsilondev_xy_loc, b_epsilondev_xz_loc, b_epsilondev_yz_loc
+ real(kind=CUSTOM_REAL) b_R_xx_val,b_R_yy_val
+ ! adjoint
+
+ if( iphase == 1 ) then
+ num_elements = nspec_outer_elastic
+ else
+ num_elements = nspec_inner_elastic
+ endif
+
+! loops over all elements
+! do ispec = 1,NSPEC_AB
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+! if( ispec_is_elastic(ispec) ) then
+
+ do ispec_p = 1,num_elements
+
+ ispec = phase_ispec_inner_elastic(ispec_p,iphase)
+
+ ! adjoint simulations: moho kernel
+ if( SIMULATION_TYPE == 3 .and. SAVE_MOHO_MESH ) then
+ if (is_moho_top(ispec)) then
+ ispec2D_moho_top = ispec2D_moho_top + 1
+ else if (is_moho_bot(ispec)) then
+ ispec2D_moho_bot = ispec2D_moho_bot + 1
+ endif
+ endif ! adjoint
+
+ ! stores displacment values in local array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_dummyx_loc(i,j,k) = b_displ(1,iglob)
+ b_dummyy_loc(i,j,k) = b_displ(2,iglob)
+ b_dummyz_loc(i,j,k) = b_displ(3,iglob)
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! for incompressible fluid flow, Cambridge University Press (2002),
+ ! pages 386 and 389 and Figure 8.3.1
+ ! call mxm_m1_m2_5points(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
+ do j=1,m2
+ do i=1,m1
+ C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B1_m1_m2_5points(5,j)
+ C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B2_m1_m2_5points(5,j)
+ C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B3_m1_m2_5points(5,j)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_C1_m1_m2_5points(i,j) = hprime_xx(i,1)*b_B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*b_B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*b_B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*b_B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*b_B1_m1_m2_5points(5,j)
+ b_C2_m1_m2_5points(i,j) = hprime_xx(i,1)*b_B2_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*b_B2_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*b_B2_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*b_B2_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*b_B2_m1_m2_5points(5,j)
+ b_C3_m1_m2_5points(i,j) = hprime_xx(i,1)*b_B3_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*b_B3_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*b_B3_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*b_B3_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*b_B3_m1_m2_5points(5,j)
+ endif ! adjoint
+
+ enddo
+ enddo
+
+ ! call mxm_m1_m1_5points(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k), &
+ ! hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
+ do j=1,m1
+ do i=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyx_loc(i,5,k)*hprime_xxT(5,j)
+ tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyy_loc(i,5,k)*hprime_xxT(5,j)
+ tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyz_loc(i,5,k)*hprime_xxT(5,j)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_tempx2(i,j,k) = b_dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ b_dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ b_dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ b_dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ b_dummyx_loc(i,5,k)*hprime_xxT(5,j)
+ b_tempy2(i,j,k) = b_dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ b_dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
+ b_dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
+ b_dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
+ b_dummyy_loc(i,5,k)*hprime_xxT(5,j)
+ b_tempz2(i,j,k) = b_dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ b_dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
+ b_dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
+ b_dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
+ b_dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ endif ! adjoint
+ enddo
+ enddo
+ enddo
+
+ ! call mxm_m2_m1_5points(dummyx_loc,dummyy_loc,dummyz_loc,tempx3,tempy3,tempz3)
+ do j=1,m1
+ do i=1,m2
+ C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_C1_mxm_m2_m1_5points(i,j) = b_A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ b_A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ b_A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ b_A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ b_A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ b_C2_mxm_m2_m1_5points(i,j) = b_A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ b_A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ b_A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ b_A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ b_A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ b_C3_mxm_m2_m1_5points(i,j) = b_A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ b_A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ b_A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ b_A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ b_A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ endif ! adjoint
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ jacobianl = jacobian(i,j,k,ispec)
+
+ duxdxl = xixl*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
+ duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
+ duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
+
+ duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
+ duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
+ duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
+
+ duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
+ duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
+ duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
+
+ ! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
+
+ kappal = kappastore(i,j,k,ispec)
+ mul = mustore(i,j,k,ispec)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ ! save strain on the Moho boundary
+ if (SAVE_MOHO_MESH ) then
+ if (is_moho_top(ispec)) then
+ dsdx_top(1,1,i,j,k,ispec2D_moho_top) = duxdxl
+ dsdx_top(1,2,i,j,k,ispec2D_moho_top) = duxdyl
+ dsdx_top(1,3,i,j,k,ispec2D_moho_top) = duxdzl
+ dsdx_top(2,1,i,j,k,ispec2D_moho_top) = duydxl
+ dsdx_top(2,2,i,j,k,ispec2D_moho_top) = duydyl
+ dsdx_top(2,3,i,j,k,ispec2D_moho_top) = duydzl
+ dsdx_top(3,1,i,j,k,ispec2D_moho_top) = duzdxl
+ dsdx_top(3,2,i,j,k,ispec2D_moho_top) = duzdyl
+ dsdx_top(3,3,i,j,k,ispec2D_moho_top) = duzdzl
+ else if (is_moho_bot(ispec)) then
+ dsdx_bot(1,1,i,j,k,ispec2D_moho_bot) = duxdxl
+ dsdx_bot(1,2,i,j,k,ispec2D_moho_bot) = duxdyl
+ dsdx_bot(1,3,i,j,k,ispec2D_moho_bot) = duxdzl
+ dsdx_bot(2,1,i,j,k,ispec2D_moho_bot) = duydxl
+ dsdx_bot(2,2,i,j,k,ispec2D_moho_bot) = duydyl
+ dsdx_bot(2,3,i,j,k,ispec2D_moho_bot) = duydzl
+ dsdx_bot(3,1,i,j,k,ispec2D_moho_bot) = duzdxl
+ dsdx_bot(3,2,i,j,k,ispec2D_moho_bot) = duzdyl
+ dsdx_bot(3,3,i,j,k,ispec2D_moho_bot) = duzdzl
+ endif
+ endif
+
+ dsxx = duxdxl
+ dsxy = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
+ dsxz = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
+ dsyy = duydyl
+ dsyz = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
+ dszz = duzdzl
+
+ b_duxdxl = xixl*b_tempx1(i,j,k) + etaxl*b_tempx2(i,j,k) + gammaxl*b_tempx3(i,j,k)
+ b_duxdyl = xiyl*b_tempx1(i,j,k) + etayl*b_tempx2(i,j,k) + gammayl*b_tempx3(i,j,k)
+ b_duxdzl = xizl*b_tempx1(i,j,k) + etazl*b_tempx2(i,j,k) + gammazl*b_tempx3(i,j,k)
+ b_duydxl = xixl*b_tempy1(i,j,k) + etaxl*b_tempy2(i,j,k) + gammaxl*b_tempy3(i,j,k)
+ b_duydyl = xiyl*b_tempy1(i,j,k) + etayl*b_tempy2(i,j,k) + gammayl*b_tempy3(i,j,k)
+ b_duydzl = xizl*b_tempy1(i,j,k) + etazl*b_tempy2(i,j,k) + gammazl*b_tempy3(i,j,k)
+ b_duzdxl = xixl*b_tempz1(i,j,k) + etaxl*b_tempz2(i,j,k) + gammaxl*b_tempz3(i,j,k)
+ b_duzdyl = xiyl*b_tempz1(i,j,k) + etayl*b_tempz2(i,j,k) + gammayl*b_tempz3(i,j,k)
+ b_duzdzl = xizl*b_tempz1(i,j,k) + etazl*b_tempz2(i,j,k) + gammazl*b_tempz3(i,j,k)
+
+ b_duxdxl_plus_duydyl = b_duxdxl + b_duydyl
+ b_duxdxl_plus_duzdzl = b_duxdxl + b_duzdzl
+ b_duydyl_plus_duzdzl = b_duydyl + b_duzdzl
+ b_duxdyl_plus_duydxl = b_duxdyl + b_duydxl
+ b_duzdxl_plus_duxdzl = b_duzdxl + b_duxdzl
+ b_duzdyl_plus_duydzl = b_duzdyl + b_duydzl
+
+ b_dsxx = b_duxdxl
+ b_dsxy = 0.5_CUSTOM_REAL * b_duxdyl_plus_duydxl
+ b_dsxz = 0.5_CUSTOM_REAL * b_duzdxl_plus_duxdzl
+ b_dsyy = b_duydyl
+ b_dsyz = 0.5_CUSTOM_REAL * b_duzdyl_plus_duydzl
+ b_dszz = b_duzdzl
+
+ ! isotropic adjoint kernels: bulk (kappa) and shear (mu) kernels
+ kappa_k = (duxdxl + duydyl + duzdzl) * (b_duxdxl + b_duydyl + b_duzdzl)
+ mu_k = dsxx * b_dsxx + dsyy * b_dsyy + dszz * b_dszz + &
+ 2._CUSTOM_REAL * (dsxy * b_dsxy + dsxz * b_dsxz + dsyz * b_dsyz) &
+ - ONE_THIRD * kappa_k
+
+ kappa_kl(i,j,k,ispec) = kappa_kl(i,j,k,ispec) + deltat * kappa_k
+ mu_kl(i,j,k,ispec) = mu_kl(i,j,k,ispec) + 2._CUSTOM_REAL * deltat * mu_k
+
+ if (SAVE_MOHO_MESH) then
+ if (is_moho_top(ispec)) then
+ b_dsdx_top(1,1,i,j,k,ispec2D_moho_top) = b_duxdxl
+ b_dsdx_top(1,2,i,j,k,ispec2D_moho_top) = b_duxdyl
+ b_dsdx_top(1,3,i,j,k,ispec2D_moho_top) = b_duxdzl
+ b_dsdx_top(2,1,i,j,k,ispec2D_moho_top) = b_duydxl
+ b_dsdx_top(2,2,i,j,k,ispec2D_moho_top) = b_duydyl
+ b_dsdx_top(2,3,i,j,k,ispec2D_moho_top) = b_duydzl
+ b_dsdx_top(3,1,i,j,k,ispec2D_moho_top) = b_duzdxl
+ b_dsdx_top(3,2,i,j,k,ispec2D_moho_top) = b_duzdyl
+ b_dsdx_top(3,3,i,j,k,ispec2D_moho_top) = b_duzdzl
+ else if (is_moho_bot(ispec)) then
+ b_dsdx_bot(1,1,i,j,k,ispec2D_moho_bot) = b_duxdxl
+ b_dsdx_bot(1,2,i,j,k,ispec2D_moho_bot) = b_duxdyl
+ b_dsdx_bot(1,3,i,j,k,ispec2D_moho_bot) = b_duxdzl
+ b_dsdx_bot(2,1,i,j,k,ispec2D_moho_bot) = b_duydxl
+ b_dsdx_bot(2,2,i,j,k,ispec2D_moho_bot) = b_duydyl
+ b_dsdx_bot(2,3,i,j,k,ispec2D_moho_bot) = b_duydzl
+ b_dsdx_bot(3,1,i,j,k,ispec2D_moho_bot) = b_duzdxl
+ b_dsdx_bot(3,2,i,j,k,ispec2D_moho_bot) = b_duzdyl
+ b_dsdx_bot(3,3,i,j,k,ispec2D_moho_bot) = b_duzdzl
+ endif
+ endif
+ endif ! adjoint
+
+
+ ! attenuation
+ if(ATTENUATION) then
+ ! compute deviatoric strain
+ epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_xx_loc(i,j,k) = duxdxl - epsilon_trace_over_3
+ epsilondev_yy_loc(i,j,k) = duydyl - epsilon_trace_over_3
+ epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_epsilon_trace_over_3 = ONE_THIRD * (b_duxdxl + b_duydyl + b_duzdzl)
+ b_epsilondev_xx_loc(i,j,k) = b_duxdxl - b_epsilon_trace_over_3
+ b_epsilondev_yy_loc(i,j,k) = b_duydyl - b_epsilon_trace_over_3
+ b_epsilondev_xy_loc(i,j,k) = 0.5 * b_duxdyl_plus_duydxl
+ b_epsilondev_xz_loc(i,j,k) = 0.5 * b_duzdxl_plus_duxdzl
+ b_epsilondev_yz_loc(i,j,k) = 0.5 * b_duzdyl_plus_duydzl
+ endif ! adjoint
+
+ ! uses scaling rule similar to Olsen et al. (2003) or mesh flag
+ if(USE_OLSEN_ATTENUATION) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_olsen( vs_val, iselected )
+ else
+ ! iflag from (CUBIT) mesh
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ ! use unrelaxed parameters if attenuation
+ mul = mul * one_minus_sum_beta(iselected)
+
+ endif
+
+ ! full anisotropic case, stress calculations
+ if(ANISOTROPY) then
+ c11 = c11store(i,j,k,ispec)
+ c12 = c12store(i,j,k,ispec)
+ c13 = c13store(i,j,k,ispec)
+ c14 = c14store(i,j,k,ispec)
+ c15 = c15store(i,j,k,ispec)
+ c16 = c16store(i,j,k,ispec)
+ c22 = c22store(i,j,k,ispec)
+ c23 = c23store(i,j,k,ispec)
+ c24 = c24store(i,j,k,ispec)
+ c25 = c25store(i,j,k,ispec)
+ c26 = c26store(i,j,k,ispec)
+ c33 = c33store(i,j,k,ispec)
+ c34 = c34store(i,j,k,ispec)
+ c35 = c35store(i,j,k,ispec)
+ c36 = c36store(i,j,k,ispec)
+ c44 = c44store(i,j,k,ispec)
+ c45 = c45store(i,j,k,ispec)
+ c46 = c46store(i,j,k,ispec)
+ c55 = c55store(i,j,k,ispec)
+ c56 = c56store(i,j,k,ispec)
+ c66 = c66store(i,j,k,ispec)
+ !if(ATTENUATION .and. not_fully_in_bedrock(ispec)) then
+ ! mul = c44
+ ! c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
+ ! c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
+ ! c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
+ ! c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c44 = c44 + minus_sum_beta * mul
+ ! c55 = c55 + minus_sum_beta * mul
+ ! c66 = c66 + minus_sum_beta * mul
+ !endif
+
+ sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
+ c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
+ sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
+ c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
+ sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
+ c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
+ sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
+ c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
+ sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
+ c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
+ sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
+ c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_sigma_xx = c11*b_duxdxl + c16*b_duxdyl_plus_duydxl + c12*b_duydyl + &
+ c15*b_duzdxl_plus_duxdzl + c14*b_duzdyl_plus_duydzl + c13*b_duzdzl
+ b_sigma_yy = c12*b_duxdxl + c26*b_duxdyl_plus_duydxl + c22*b_duydyl + &
+ c25*b_duzdxl_plus_duxdzl + c24*b_duzdyl_plus_duydzl + c23*b_duzdzl
+ b_sigma_zz = c13*b_duxdxl + c36*b_duxdyl_plus_duydxl + c23*b_duydyl + &
+ c35*b_duzdxl_plus_duxdzl + c34*b_duzdyl_plus_duydzl + c33*b_duzdzl
+ b_sigma_xy = c16*b_duxdxl + c66*b_duxdyl_plus_duydxl + c26*b_duydyl + &
+ c56*b_duzdxl_plus_duxdzl + c46*b_duzdyl_plus_duydzl + c36*b_duzdzl
+ b_sigma_xz = c15*b_duxdxl + c56*b_duxdyl_plus_duydxl + c25*b_duydyl + &
+ c55*b_duzdxl_plus_duxdzl + c45*b_duzdyl_plus_duydzl + c35*b_duzdzl
+ b_sigma_yz = c14*b_duxdxl + c46*b_duxdyl_plus_duydxl + c24*b_duydyl + &
+ c45*b_duzdxl_plus_duxdzl + c44*b_duzdyl_plus_duydzl + c34*b_duzdzl
+ endif ! adjoint
+ else
+
+ ! isotropic case
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
+
+ ! compute stress sigma
+ sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
+ b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
+ b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
+ b_sigma_xy = mul*b_duxdyl_plus_duydxl
+ b_sigma_xz = mul*b_duzdxl_plus_duxdzl
+ b_sigma_yz = mul*b_duzdyl_plus_duydzl
+ endif !adjoint
+
+ endif ! ANISOTROPY
+
+ ! subtract memory variables if attenuation
+ if(ATTENUATION) then
+ do i_sls = 1,N_SLS
+ R_xx_val = R_xx(i,j,k,ispec,i_sls)
+ R_yy_val = R_yy(i,j,k,ispec,i_sls)
+ sigma_xx = sigma_xx - R_xx_val
+ sigma_yy = sigma_yy - R_yy_val
+ sigma_zz = sigma_zz + R_xx_val + R_yy_val
+ sigma_xy = sigma_xy - R_xy(i,j,k,ispec,i_sls)
+ sigma_xz = sigma_xz - R_xz(i,j,k,ispec,i_sls)
+ sigma_yz = sigma_yz - R_yz(i,j,k,ispec,i_sls)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_R_xx_val = b_R_xx(i,j,k,ispec,i_sls)
+ b_R_yy_val = b_R_yy(i,j,k,ispec,i_sls)
+ b_sigma_xx = b_sigma_xx - b_R_xx_val
+ b_sigma_yy = b_sigma_yy - b_R_yy_val
+ b_sigma_zz = b_sigma_zz + b_R_xx_val + b_R_yy_val
+ b_sigma_xy = b_sigma_xy - b_R_xy(i,j,k,ispec,i_sls)
+ b_sigma_xz = b_sigma_xz - b_R_xz(i,j,k,ispec,i_sls)
+ b_sigma_yz = b_sigma_yz - b_R_yz(i,j,k,ispec,i_sls)
+ endif !adjoint
+ enddo
+ endif
+
+ ! form dot product with test vector, symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1(i,j,k) = jacobianl * (b_sigma_xx*xixl + b_sigma_xy*xiyl + b_sigma_xz*xizl)
+ b_tempy1(i,j,k) = jacobianl * (b_sigma_xy*xixl + b_sigma_yy*xiyl + b_sigma_yz*xizl)
+ b_tempz1(i,j,k) = jacobianl * (b_sigma_xz*xixl + b_sigma_yz*xiyl + b_sigma_zz*xizl)
+ b_tempx2(i,j,k) = jacobianl * (b_sigma_xx*etaxl + b_sigma_xy*etayl + b_sigma_xz*etazl)
+ b_tempy2(i,j,k) = jacobianl * (b_sigma_xy*etaxl + b_sigma_yy*etayl + b_sigma_yz*etazl)
+ b_tempz2(i,j,k) = jacobianl * (b_sigma_xz*etaxl + b_sigma_yz*etayl + b_sigma_zz*etazl)
+ b_tempx3(i,j,k) = jacobianl * (b_sigma_xx*gammaxl + b_sigma_xy*gammayl + b_sigma_xz*gammazl)
+ b_tempy3(i,j,k) = jacobianl * (b_sigma_xy*gammaxl + b_sigma_yy*gammayl + b_sigma_yz*gammazl)
+ b_tempz3(i,j,k) = jacobianl * (b_sigma_xz*gammaxl + b_sigma_yz*gammayl + b_sigma_zz*gammazl)
+ endif !adjoint
+
+ enddo
+ enddo
+ enddo
+
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! for incompressible fluid flow, Cambridge University Press (2002),
+ ! pages 386 and 389 and Figure 8.3.1
+ ! call mxm_m1_m2_5points(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
+ do j=1,m2
+ do i=1,m1
+ E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
+ E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
+ E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*b_C1_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*b_C1_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*b_C1_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*b_C1_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*b_C1_m1_m2_5points(5,j)
+ b_E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*b_C2_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*b_C2_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*b_C2_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*b_C2_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*b_C2_m1_m2_5points(5,j)
+ b_E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*b_C3_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*b_C3_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*b_C3_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*b_C3_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*b_C3_m1_m2_5points(5,j)
+ endif !adjoint
+ enddo
+ enddo
+
+ ! call mxm_m1_m1_5points(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k), &
+ ! hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
+ do i=1,m1
+ do j=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempx2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempx2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempx2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempx2(i,5,k)*hprimewgll_xx(5,j)
+ newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempy2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempy2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempy2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempy2(i,5,k)*hprimewgll_xx(5,j)
+ newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempz2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempz2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempz2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempz2(i,5,k)*hprimewgll_xx(5,j)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_newtempx2(i,j,k) = b_tempx2(i,1,k)*hprimewgll_xx(1,j) + &
+ b_tempx2(i,2,k)*hprimewgll_xx(2,j) + &
+ b_tempx2(i,3,k)*hprimewgll_xx(3,j) + &
+ b_tempx2(i,4,k)*hprimewgll_xx(4,j) + &
+ b_tempx2(i,5,k)*hprimewgll_xx(5,j)
+ b_newtempy2(i,j,k) = b_tempy2(i,1,k)*hprimewgll_xx(1,j) + &
+ b_tempy2(i,2,k)*hprimewgll_xx(2,j) + &
+ b_tempy2(i,3,k)*hprimewgll_xx(3,j) + &
+ b_tempy2(i,4,k)*hprimewgll_xx(4,j) + &
+ b_tempy2(i,5,k)*hprimewgll_xx(5,j)
+ b_newtempz2(i,j,k) = b_tempz2(i,1,k)*hprimewgll_xx(1,j) + &
+ b_tempz2(i,2,k)*hprimewgll_xx(2,j) + &
+ b_tempz2(i,3,k)*hprimewgll_xx(3,j) + &
+ b_tempz2(i,4,k)*hprimewgll_xx(4,j) + &
+ b_tempz2(i,5,k)*hprimewgll_xx(5,j)
+ endif !adjoint
+ enddo
+ enddo
+ enddo
+
+ ! call mxm_m2_m1_5points(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
+ do j=1,m1
+ do i=1,m2
+ E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_E1_mxm_m2_m1_5points(i,j) = b_C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ b_C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ b_C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ b_C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ b_C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ b_E2_mxm_m2_m1_5points(i,j) = b_C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ b_C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ b_C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ b_C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ b_C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ b_E3_mxm_m2_m1_5points(i,j) = b_C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ b_C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ b_C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ b_C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ b_C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ endif !adjoint
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+
+ ! sum contributions from each element to the global mesh using indirect addressing
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) - fac1*newtempx1(i,j,k) - &
+ fac2*newtempx2(i,j,k) - fac3*newtempx3(i,j,k)
+ accel(2,iglob) = accel(2,iglob) - fac1*newtempy1(i,j,k) - &
+ fac2*newtempy2(i,j,k) - fac3*newtempy3(i,j,k)
+ accel(3,iglob) = accel(3,iglob) - fac1*newtempz1(i,j,k) - &
+ fac2*newtempz2(i,j,k) - fac3*newtempz3(i,j,k)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_accel(1,iglob) = b_accel(1,iglob) - fac1*b_newtempx1(i,j,k) - &
+ fac2*b_newtempx2(i,j,k) - fac3*b_newtempx3(i,j,k)
+ b_accel(2,iglob) = b_accel(2,iglob) - fac1*b_newtempy1(i,j,k) - &
+ fac2*b_newtempy2(i,j,k) - fac3*b_newtempy3(i,j,k)
+ b_accel(3,iglob) = b_accel(3,iglob) - fac1*b_newtempz1(i,j,k) - &
+ fac2*b_newtempz2(i,j,k) - fac3*b_newtempz3(i,j,k)
+ endif !adjoint
+
+ ! update memory variables based upon the Runge-Kutta scheme
+ if(ATTENUATION) then
+
+ ! use Runge-Kutta scheme to march in time
+ do i_sls = 1,N_SLS
+
+ ! get coefficients for that standard linear solid
+ if( USE_OLSEN_ATTENUATION ) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_olsen( vs_val, iselected )
+ else
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ factor_loc = mustore(i,j,k,ispec) * factor_common(iselected,i_sls)
+
+ alphaval_loc = alphaval(iselected,i_sls)
+ betaval_loc = betaval(iselected,i_sls)
+ gammaval_loc = gammaval(iselected,i_sls)
+
+ ! term in xx
+ Sn = factor_loc * epsilondev_xx(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xx_loc(i,j,k)
+ R_xx(i,j,k,ispec,i_sls) = alphaval_loc * R_xx(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+ ! term in yy
+ Sn = factor_loc * epsilondev_yy(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_yy_loc(i,j,k)
+ R_yy(i,j,k,ispec,i_sls) = alphaval_loc * R_yy(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+ ! term in zz not computed since zero trace
+ ! term in xy
+ Sn = factor_loc * epsilondev_xy(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xy_loc(i,j,k)
+ R_xy(i,j,k,ispec,i_sls) = alphaval_loc * R_xy(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+ ! term in xz
+ Sn = factor_loc * epsilondev_xz(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xz_loc(i,j,k)
+ R_xz(i,j,k,ispec,i_sls) = alphaval_loc * R_xz(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+ ! term in yz
+ Sn = factor_loc * epsilondev_yz(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_yz_loc(i,j,k)
+ R_yz(i,j,k,ispec,i_sls) = alphaval_loc * R_yz(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+
+ !adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_alphaval_loc = b_alphaval(iselected,i_sls)
+ b_betaval_loc = b_betaval(iselected,i_sls)
+ b_gammaval_loc = b_gammaval(iselected,i_sls)
+ ! term in xx
+ b_Sn = factor_loc * b_epsilondev_xx(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xx_loc(i,j,k)
+ b_R_xx(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xx(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in yy
+ b_Sn = factor_loc * b_epsilondev_yy(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_yy_loc(i,j,k)
+ b_R_yy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yy(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in zz not computed since zero trace
+ ! term in xy
+ b_Sn = factor_loc * b_epsilondev_xy(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xy_loc(i,j,k)
+ b_R_xy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xy(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in xz
+ b_Sn = factor_loc * b_epsilondev_xz(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xz_loc(i,j,k)
+ b_R_xz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xz(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in yz
+ b_Sn = factor_loc * b_epsilondev_yz(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_yz_loc(i,j,k)
+ b_R_yz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yz(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ endif !adjoint
+
+ enddo ! end of loop on memory variables
+
+ endif ! end attenuation
+
+ enddo
+ enddo
+ enddo
+
+ ! save deviatoric strain for Runge-Kutta scheme
+ if(ATTENUATION) then
+ epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:)
+ epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:)
+ epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:)
+ epsilondev_xz(:,:,:,ispec) = epsilondev_xz_loc(:,:,:)
+ epsilondev_yz(:,:,:,ispec) = epsilondev_yz_loc(:,:,:)
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_epsilondev_xx(:,:,:,ispec) = b_epsilondev_xx_loc(:,:,:)
+ b_epsilondev_yy(:,:,:,ispec) = b_epsilondev_yy_loc(:,:,:)
+ b_epsilondev_xy(:,:,:,ispec) = b_epsilondev_xy_loc(:,:,:)
+ b_epsilondev_xz(:,:,:,ispec) = b_epsilondev_xz_loc(:,:,:)
+ b_epsilondev_yz(:,:,:,ispec) = b_epsilondev_yz_loc(:,:,:)
+ endif !adjoint
+ endif
+
+! endif ! ispec_is_elastic
+
+! endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
+
+ enddo ! spectral element loop
+
+end subroutine compute_forces_elastic_Dev
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+!
+!! subroutines adapted from Deville, Fischer and Mund, High-order methods
+!! for incompressible fluid flow, Cambridge University Press (2002),
+!! pages 386 and 389 and Figure 8.3.1
+!
+! subroutine old_mxm_m1_m2_5points(A,B1,B2,B3,C1,C2,C3)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! real(kind=4), dimension(m1,NGLLX) :: A
+! real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
+! real(kind=4), dimension(m1,m2) :: C1,C2,C3
+!
+! integer :: i,j
+!
+! do j=1,m2
+! do i=1,m1
+!
+! C1(i,j) = A(i,1)*B1(1,j) + &
+! A(i,2)*B1(2,j) + &
+! A(i,3)*B1(3,j) + &
+! A(i,4)*B1(4,j) + &
+! A(i,5)*B1(5,j)
+!
+! C2(i,j) = A(i,1)*B2(1,j) + &
+! A(i,2)*B2(2,j) + &
+! A(i,3)*B2(3,j) + &
+! A(i,4)*B2(4,j) + &
+! A(i,5)*B2(5,j)
+!
+! C3(i,j) = A(i,1)*B3(1,j) + &
+! A(i,2)*B3(2,j) + &
+! A(i,3)*B3(3,j) + &
+! A(i,4)*B3(4,j) + &
+! A(i,5)*B3(5,j)
+!
+! enddo
+! enddo
+!
+! end subroutine old_mxm_m1_m2_5points
+!
+!!---------
+!
+! subroutine old_mxm_m1_m1_5points(A1,A2,A3,B,C1,C2,C3)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
+! real(kind=4), dimension(NGLLX,m1) :: B
+! real(kind=4), dimension(m1,m1) :: C1,C2,C3
+!
+! integer :: i,j
+!
+! do j=1,m1
+! do i=1,m1
+!
+! C1(i,j) = A1(i,1)*B(1,j) + &
+! A1(i,2)*B(2,j) + &
+! A1(i,3)*B(3,j) + &
+! A1(i,4)*B(4,j) + &
+! A1(i,5)*B(5,j)
+!
+! C2(i,j) = A2(i,1)*B(1,j) + &
+! A2(i,2)*B(2,j) + &
+! A2(i,3)*B(3,j) + &
+! A2(i,4)*B(4,j) + &
+! A2(i,5)*B(5,j)
+!
+! C3(i,j) = A3(i,1)*B(1,j) + &
+! A3(i,2)*B(2,j) + &
+! A3(i,3)*B(3,j) + &
+! A3(i,4)*B(4,j) + &
+! A3(i,5)*B(5,j)
+!
+! enddo
+! enddo
+!
+! end subroutine old_mxm_m1_m1_5points
+!
+!!---------
+!
+! subroutine old_mxm_m2_m1_5points(A1,A2,A3,B,C1,C2,C3)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
+! real(kind=4), dimension(NGLLX,m1) :: B
+! real(kind=4), dimension(m2,m1) :: C1,C2,C3
+!
+! integer :: i,j
+!
+! do j=1,m1
+! do i=1,m2
+!
+! C1(i,j) = A1(i,1)*B(1,j) + &
+! A1(i,2)*B(2,j) + &
+! A1(i,3)*B(3,j) + &
+! A1(i,4)*B(4,j) + &
+! A1(i,5)*B(5,j)
+!
+! C2(i,j) = A2(i,1)*B(1,j) + &
+! A2(i,2)*B(2,j) + &
+! A2(i,3)*B(3,j) + &
+! A2(i,4)*B(4,j) + &
+! A2(i,5)*B(5,j)
+!
+! C3(i,j) = A3(i,1)*B(1,j) + &
+! A3(i,2)*B(2,j) + &
+! A3(i,3)*B(3,j) + &
+! A3(i,4)*B(4,j) + &
+! A3(i,5)*B(5,j)
+!
+! enddo
+! enddo
+!
+! end subroutine old_mxm_m2_m1_5points
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic_noDev.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic_noDev.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic_noDev.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,854 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine compute_forces_elastic_noDev( iphase, &
+ NSPEC_AB,NGLOB_AB,displ,accel,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz,&
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,&
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool,&
+ ATTENUATION,USE_OLSEN_ATTENUATION,&
+ one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,&
+ NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,&
+ epsilondev_xz,epsilondev_yz,iflag_attenuation_store,&
+ rho_vs,&
+ ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store, &
+ SIMULATION_TYPE,NGLOB_ADJOINT,NSPEC_ADJOINT, &
+ b_displ,b_accel,kappa_kl,mu_kl,deltat, &
+ NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL,&
+ is_moho_top,is_moho_bot, &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot, &
+ ispec2D_moho_top,ispec2D_moho_bot, &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz, &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy, &
+ b_epsilondev_xz,b_epsilondev_yz, &
+ b_alphaval,b_betaval,b_gammaval,&
+ num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic,&
+ phase_ispec_inner_elastic )
+
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,NDIM, &
+ NUM_REGIONS_ATTENUATION,N_SLS,SAVE_MOHO_MESH, &
+ ONE_THIRD,FOUR_THIRDS
+
+ implicit none
+
+ !include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ,accel
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ kappastore,mustore,jacobian
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+! communication overlap
+! logical, dimension(NSPEC_AB) :: ispec_is_inner
+! logical :: phase_is_inner
+
+! memory variables and standard linear solids for attenuation
+ logical :: ATTENUATION,USE_OLSEN_ATTENUATION
+ integer :: NSPEC_ATTENUATION_AB
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
+ R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vs
+
+! anisotropy
+ logical :: ANISOTROPY
+ integer :: NSPEC_ANISO
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, &
+ c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store
+
+! logical,dimension(NSPEC_AB) :: ispec_is_elastic
+ integer :: iphase
+ integer :: num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic
+ integer, dimension(num_phase_ispec_elastic,2) :: phase_ispec_inner_elastic
+
+
+! adjoint simulations
+ integer :: SIMULATION_TYPE
+ integer :: NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL
+ integer :: NGLOB_ADJOINT,NSPEC_ADJOINT
+
+ ! moho kernel
+ real(kind=CUSTOM_REAL),dimension(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO):: &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot
+ logical,dimension(NSPEC_BOUN) :: is_moho_top,is_moho_bot
+ integer :: ispec2D_moho_top, ispec2D_moho_bot
+
+ ! adjoint memory variables
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS) :: &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL) :: &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy,b_epsilondev_xz,b_epsilondev_yz
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: b_alphaval,b_betaval,b_gammaval
+
+ ! adjoint wavefields
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_ADJOINT):: b_displ,b_accel
+ ! adjoint kernels
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT) :: &
+ mu_kl, kappa_kl
+ real(kind=CUSTOM_REAL) :: deltat
+
+!adjoint
+
+! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ integer ispec,iglob,ispec_p,num_elements
+ integer i,j,k,l
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+
+ real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+
+ real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+
+ real(kind=CUSTOM_REAL) hp1,hp2,hp3
+ real(kind=CUSTOM_REAL) fac1,fac2,fac3
+
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+
+ real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) kappal
+
+ ! local anisotropy parameters
+ real(kind=CUSTOM_REAL) c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
+
+ ! local attenuation parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xx_loc, &
+ epsilondev_yy_loc, epsilondev_xy_loc, epsilondev_xz_loc, epsilondev_yz_loc
+ real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
+ real(kind=CUSTOM_REAL) factor_loc,alphaval_loc,betaval_loc,gammaval_loc,Sn,Snp1
+ real(kind=CUSTOM_REAL) epsilon_trace_over_3
+ real(kind=CUSTOM_REAL) vs_val
+
+ integer i_SLS,iselected
+
+ ! adjoint backward arrays
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ b_tempx1,b_tempx2,b_tempx3,b_tempy1,b_tempy2,b_tempy3,b_tempz1,b_tempz2,b_tempz3
+ real(kind=CUSTOM_REAL):: dsxx,dsxy,dsxz,dsyy,dsyz,dszz
+ real(kind=CUSTOM_REAL):: b_duxdxl,b_duxdyl,b_duxdzl,b_duydxl,b_duydyl,b_duydzl,b_duzdxl,b_duzdyl,b_duzdzl
+ real(kind=CUSTOM_REAL):: b_duxdxl_plus_duydyl,b_duxdxl_plus_duzdzl,b_duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL):: b_duxdyl_plus_duydxl,b_duzdxl_plus_duxdzl,b_duzdyl_plus_duydzl
+ real(kind=CUSTOM_REAL):: b_dsxx,b_dsxy,b_dsxz,b_dsyy,b_dsyz,b_dszz
+ real(kind=CUSTOM_REAL):: b_sigma_xx,b_sigma_yy,b_sigma_zz,b_sigma_xy,b_sigma_xz,b_sigma_yz
+ real(kind=CUSTOM_REAL):: kappa_k, mu_k
+ real(kind=CUSTOM_REAL) b_tempx1l,b_tempx2l,b_tempx3l
+ real(kind=CUSTOM_REAL) b_tempy1l,b_tempy2l,b_tempy3l
+ real(kind=CUSTOM_REAL) b_tempz1l,b_tempz2l,b_tempz3l
+ ! local adjoint attenuation
+ real(kind=CUSTOM_REAL) b_alphaval_loc,b_betaval_loc,b_gammaval_loc,b_Sn,b_Snp1
+ real(kind=CUSTOM_REAL) b_epsilon_trace_over_3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: b_epsilondev_xx_loc, &
+ b_epsilondev_yy_loc, b_epsilondev_xy_loc, b_epsilondev_xz_loc, b_epsilondev_yz_loc
+ real(kind=CUSTOM_REAL) b_R_xx_val,b_R_yy_val
+ ! adjoint
+
+ if( iphase == 1 ) then
+ num_elements = nspec_outer_elastic
+ else
+ num_elements = nspec_inner_elastic
+ endif
+
+ do ispec_p = 1,num_elements
+
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+! if( ispec_is_elastic(ispec) ) then
+
+ ispec = phase_ispec_inner_elastic(ispec_p,iphase)
+
+
+ ! adjoint simulations: moho kernel
+ if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+ if (is_moho_top(ispec)) then
+ ispec2D_moho_top = ispec2D_moho_top + 1
+ else if (is_moho_bot(ispec)) then
+ ispec2D_moho_bot = ispec2D_moho_bot + 1
+ endif
+ endif
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempx2l = 0.
+ tempx3l = 0.
+
+ tempy1l = 0.
+ tempy2l = 0.
+ tempy3l = 0.
+
+ tempz1l = 0.
+ tempz2l = 0.
+ tempz3l = 0.
+
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1l = 0.
+ b_tempx2l = 0.
+ b_tempx3l = 0.
+
+ b_tempy1l = 0.
+ b_tempy2l = 0.
+ b_tempy3l = 0.
+
+ b_tempz1l = 0.
+ b_tempz2l = 0.
+ b_tempz3l = 0.
+ endif
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + displ(1,iglob)*hp1
+ tempy1l = tempy1l + displ(2,iglob)*hp1
+ tempz1l = tempz1l + displ(3,iglob)*hp1
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1l = b_tempx1l + b_displ(1,iglob)*hp1
+ b_tempy1l = b_tempy1l + b_displ(2,iglob)*hp1
+ b_tempz1l = b_tempz1l + b_displ(3,iglob)*hp1
+ endif ! adjoint
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(j,l)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + displ(1,iglob)*hp2
+ tempy2l = tempy2l + displ(2,iglob)*hp2
+ tempz2l = tempz2l + displ(3,iglob)*hp2
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx2l = b_tempx2l + b_displ(1,iglob)*hp2
+ b_tempy2l = b_tempy2l + b_displ(2,iglob)*hp2
+ b_tempz2l = b_tempz2l + b_displ(3,iglob)*hp2
+ endif ! adjoint
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(k,l)
+ iglob = ibool(i,j,l,ispec)
+ tempx3l = tempx3l + displ(1,iglob)*hp3
+ tempy3l = tempy3l + displ(2,iglob)*hp3
+ tempz3l = tempz3l + displ(3,iglob)*hp3
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx3l = b_tempx3l + b_displ(1,iglob)*hp3
+ b_tempy3l = b_tempy3l + b_displ(2,iglob)*hp3
+ b_tempz3l = b_tempz3l + b_displ(3,iglob)*hp3
+ endif ! adjoint
+
+
+ enddo
+
+ ! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ jacobianl = jacobian(i,j,k,ispec)
+
+ duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+
+ duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+
+ ! adjoint simulations: save strain on the Moho boundary
+ if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+ if (is_moho_top(ispec)) then
+ dsdx_top(1,1,i,j,k,ispec2D_moho_top) = duxdxl
+ dsdx_top(1,2,i,j,k,ispec2D_moho_top) = duxdyl
+ dsdx_top(1,3,i,j,k,ispec2D_moho_top) = duxdzl
+ dsdx_top(2,1,i,j,k,ispec2D_moho_top) = duydxl
+ dsdx_top(2,2,i,j,k,ispec2D_moho_top) = duydyl
+ dsdx_top(2,3,i,j,k,ispec2D_moho_top) = duydzl
+ dsdx_top(3,1,i,j,k,ispec2D_moho_top) = duzdxl
+ dsdx_top(3,2,i,j,k,ispec2D_moho_top) = duzdyl
+ dsdx_top(3,3,i,j,k,ispec2D_moho_top) = duzdzl
+ else if (is_moho_bot(ispec)) then
+ dsdx_bot(1,1,i,j,k,ispec2D_moho_bot) = duxdxl
+ dsdx_bot(1,2,i,j,k,ispec2D_moho_bot) = duxdyl
+ dsdx_bot(1,3,i,j,k,ispec2D_moho_bot) = duxdzl
+ dsdx_bot(2,1,i,j,k,ispec2D_moho_bot) = duydxl
+ dsdx_bot(2,2,i,j,k,ispec2D_moho_bot) = duydyl
+ dsdx_bot(2,3,i,j,k,ispec2D_moho_bot) = duydzl
+ dsdx_bot(3,1,i,j,k,ispec2D_moho_bot) = duzdxl
+ dsdx_bot(3,2,i,j,k,ispec2D_moho_bot) = duzdyl
+ dsdx_bot(3,3,i,j,k,ispec2D_moho_bot) = duzdzl
+ endif
+ endif
+
+ ! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
+
+ kappal = kappastore(i,j,k,ispec)
+ mul = mustore(i,j,k,ispec)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ dsxx = duxdxl
+ dsxy = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
+ dsxz = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
+ dsyy = duydyl
+ dsyz = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
+ dszz = duzdzl
+
+ b_duxdxl = xixl*b_tempx1l + etaxl*b_tempx2l + gammaxl*b_tempx3l
+ b_duxdyl = xiyl*b_tempx1l + etayl*b_tempx2l + gammayl*b_tempx3l
+ b_duxdzl = xizl*b_tempx1l + etazl*b_tempx2l + gammazl*b_tempx3l
+
+ b_duydxl = xixl*b_tempy1l + etaxl*b_tempy2l + gammaxl*b_tempy3l
+ b_duydyl = xiyl*b_tempy1l + etayl*b_tempy2l + gammayl*b_tempy3l
+ b_duydzl = xizl*b_tempy1l + etazl*b_tempy2l + gammazl*b_tempy3l
+
+ b_duzdxl = xixl*b_tempz1l + etaxl*b_tempz2l + gammaxl*b_tempz3l
+ b_duzdyl = xiyl*b_tempz1l + etayl*b_tempz2l + gammayl*b_tempz3l
+ b_duzdzl = xizl*b_tempz1l + etazl*b_tempz2l + gammazl*b_tempz3l
+
+ b_duxdxl_plus_duydyl = b_duxdxl + b_duydyl
+ b_duxdxl_plus_duzdzl = b_duxdxl + b_duzdzl
+ b_duydyl_plus_duzdzl = b_duydyl + b_duzdzl
+ b_duxdyl_plus_duydxl = b_duxdyl + b_duydxl
+ b_duzdxl_plus_duxdzl = b_duzdxl + b_duxdzl
+ b_duzdyl_plus_duydzl = b_duzdyl + b_duydzl
+
+ b_dsxx = b_duxdxl
+ b_dsxy = 0.5_CUSTOM_REAL * b_duxdyl_plus_duydxl
+ b_dsxz = 0.5_CUSTOM_REAL * b_duzdxl_plus_duxdzl
+ b_dsyy = b_duydyl
+ b_dsyz = 0.5_CUSTOM_REAL * b_duzdyl_plus_duydzl
+ b_dszz = b_duzdzl
+
+ ! isotropic adjoint kernels: bulk (kappa) and shear (mu) kernels
+ kappa_k = (duxdxl + duydyl + duzdzl) * (b_duxdxl + b_duydyl + b_duzdzl)
+ mu_k = dsxx * b_dsxx + dsyy * b_dsyy + dszz * b_dszz + &
+ 2._CUSTOM_REAL * (dsxy * b_dsxy + dsxz * b_dsxz + dsyz * b_dsyz) &
+ - ONE_THIRD * kappa_k
+
+ kappa_kl(i,j,k,ispec) = kappa_kl(i,j,k,ispec) + deltat * kappa_k
+ mu_kl(i,j,k,ispec) = mu_kl(i,j,k,ispec) + 2._CUSTOM_REAL * deltat * mu_k
+
+ if (SAVE_MOHO_MESH) then
+ if (is_moho_top(ispec)) then
+ b_dsdx_top(1,1,i,j,k,ispec2D_moho_top) = b_duxdxl
+ b_dsdx_top(1,2,i,j,k,ispec2D_moho_top) = b_duxdyl
+ b_dsdx_top(1,3,i,j,k,ispec2D_moho_top) = b_duxdzl
+ b_dsdx_top(2,1,i,j,k,ispec2D_moho_top) = b_duydxl
+ b_dsdx_top(2,2,i,j,k,ispec2D_moho_top) = b_duydyl
+ b_dsdx_top(2,3,i,j,k,ispec2D_moho_top) = b_duydzl
+ b_dsdx_top(3,1,i,j,k,ispec2D_moho_top) = b_duzdxl
+ b_dsdx_top(3,2,i,j,k,ispec2D_moho_top) = b_duzdyl
+ b_dsdx_top(3,3,i,j,k,ispec2D_moho_top) = b_duzdzl
+ else if (is_moho_bot(ispec)) then
+ b_dsdx_bot(1,1,i,j,k,ispec2D_moho_bot) = b_duxdxl
+ b_dsdx_bot(1,2,i,j,k,ispec2D_moho_bot) = b_duxdyl
+ b_dsdx_bot(1,3,i,j,k,ispec2D_moho_bot) = b_duxdzl
+ b_dsdx_bot(2,1,i,j,k,ispec2D_moho_bot) = b_duydxl
+ b_dsdx_bot(2,2,i,j,k,ispec2D_moho_bot) = b_duydyl
+ b_dsdx_bot(2,3,i,j,k,ispec2D_moho_bot) = b_duydzl
+ b_dsdx_bot(3,1,i,j,k,ispec2D_moho_bot) = b_duzdxl
+ b_dsdx_bot(3,2,i,j,k,ispec2D_moho_bot) = b_duzdyl
+ b_dsdx_bot(3,3,i,j,k,ispec2D_moho_bot) = b_duzdzl
+ endif
+ endif
+ endif ! adjoint
+
+ if(ATTENUATION) then
+ ! compute deviatoric strain
+ epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_xx_loc(i,j,k) = duxdxl - epsilon_trace_over_3
+ epsilondev_yy_loc(i,j,k) = duydyl - epsilon_trace_over_3
+ epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_epsilon_trace_over_3 = ONE_THIRD * (b_duxdxl + b_duydyl + b_duzdzl)
+ b_epsilondev_xx_loc(i,j,k) = b_duxdxl - b_epsilon_trace_over_3
+ b_epsilondev_yy_loc(i,j,k) = b_duydyl - b_epsilon_trace_over_3
+ b_epsilondev_xy_loc(i,j,k) = 0.5 * b_duxdyl_plus_duydxl
+ b_epsilondev_xz_loc(i,j,k) = 0.5 * b_duzdxl_plus_duxdzl
+ b_epsilondev_yz_loc(i,j,k) = 0.5 * b_duzdyl_plus_duydzl
+ endif ! adjoint
+
+ ! uses scaling rule similar to Olsen et al. (2003) or mesh flag
+ if(USE_OLSEN_ATTENUATION) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_olsen( vs_val, iselected )
+ else
+ ! iflag from (CUBIT) mesh
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ ! use unrelaxed parameters if attenuation
+ mul = mul * one_minus_sum_beta(iselected)
+
+ endif
+
+ ! full anisotropic case, stress calculations
+ if(ANISOTROPY) then
+ c11 = c11store(i,j,k,ispec)
+ c12 = c12store(i,j,k,ispec)
+ c13 = c13store(i,j,k,ispec)
+ c14 = c14store(i,j,k,ispec)
+ c15 = c15store(i,j,k,ispec)
+ c16 = c16store(i,j,k,ispec)
+ c22 = c22store(i,j,k,ispec)
+ c23 = c23store(i,j,k,ispec)
+ c24 = c24store(i,j,k,ispec)
+ c25 = c25store(i,j,k,ispec)
+ c26 = c26store(i,j,k,ispec)
+ c33 = c33store(i,j,k,ispec)
+ c34 = c34store(i,j,k,ispec)
+ c35 = c35store(i,j,k,ispec)
+ c36 = c36store(i,j,k,ispec)
+ c44 = c44store(i,j,k,ispec)
+ c45 = c45store(i,j,k,ispec)
+ c46 = c46store(i,j,k,ispec)
+ c55 = c55store(i,j,k,ispec)
+ c56 = c56store(i,j,k,ispec)
+ c66 = c66store(i,j,k,ispec)
+ !if(ATTENUATION .and. not_fully_in_bedrock(ispec)) then
+ ! mul = c44
+ ! c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
+ ! c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
+ ! c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
+ ! c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c44 = c44 + minus_sum_beta * mul
+ ! c55 = c55 + minus_sum_beta * mul
+ ! c66 = c66 + minus_sum_beta * mul
+ !endif
+
+ sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
+ c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
+ sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
+ c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
+ sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
+ c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
+ sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
+ c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
+ sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
+ c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
+ sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
+ c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_sigma_xx = c11*b_duxdxl + c16*b_duxdyl_plus_duydxl + c12*b_duydyl + &
+ c15*b_duzdxl_plus_duxdzl + c14*b_duzdyl_plus_duydzl + c13*b_duzdzl
+ b_sigma_yy = c12*b_duxdxl + c26*b_duxdyl_plus_duydxl + c22*b_duydyl + &
+ c25*b_duzdxl_plus_duxdzl + c24*b_duzdyl_plus_duydzl + c23*b_duzdzl
+ b_sigma_zz = c13*b_duxdxl + c36*b_duxdyl_plus_duydxl + c23*b_duydyl + &
+ c35*b_duzdxl_plus_duxdzl + c34*b_duzdyl_plus_duydzl + c33*b_duzdzl
+ b_sigma_xy = c16*b_duxdxl + c66*b_duxdyl_plus_duydxl + c26*b_duydyl + &
+ c56*b_duzdxl_plus_duxdzl + c46*b_duzdyl_plus_duydzl + c36*b_duzdzl
+ b_sigma_xz = c15*b_duxdxl + c56*b_duxdyl_plus_duydxl + c25*b_duydyl + &
+ c55*b_duzdxl_plus_duxdzl + c45*b_duzdyl_plus_duydzl + c35*b_duzdzl
+ b_sigma_yz = c14*b_duxdxl + c46*b_duxdyl_plus_duydxl + c24*b_duydyl + &
+ c45*b_duzdxl_plus_duxdzl + c44*b_duzdyl_plus_duydzl + c34*b_duzdzl
+ endif ! adjoint
+ else
+
+ ! isotropic case
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
+
+ ! compute stress sigma
+ sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
+ b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
+ b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
+ b_sigma_xy = mul*b_duxdyl_plus_duydxl
+ b_sigma_xz = mul*b_duzdxl_plus_duxdzl
+ b_sigma_yz = mul*b_duzdyl_plus_duydzl
+ endif !adjoint
+
+ endif ! ANISOTROPY
+
+ ! subtract memory variables if attenuation
+ if(ATTENUATION) then
+ do i_sls = 1,N_SLS
+ R_xx_val = R_xx(i,j,k,ispec,i_sls)
+ R_yy_val = R_yy(i,j,k,ispec,i_sls)
+ sigma_xx = sigma_xx - R_xx_val
+ sigma_yy = sigma_yy - R_yy_val
+ sigma_zz = sigma_zz + R_xx_val + R_yy_val
+ sigma_xy = sigma_xy - R_xy(i,j,k,ispec,i_sls)
+ sigma_xz = sigma_xz - R_xz(i,j,k,ispec,i_sls)
+ sigma_yz = sigma_yz - R_yz(i,j,k,ispec,i_sls)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_R_xx_val = b_R_xx(i,j,k,ispec,i_sls)
+ b_R_yy_val = b_R_yy(i,j,k,ispec,i_sls)
+ b_sigma_xx = b_sigma_xx - b_R_xx_val
+ b_sigma_yy = b_sigma_yy - b_R_yy_val
+ b_sigma_zz = b_sigma_zz + b_R_xx_val + b_R_yy_val
+ b_sigma_xy = b_sigma_xy - b_R_xy(i,j,k,ispec,i_sls)
+ b_sigma_xz = b_sigma_xz - b_R_xz(i,j,k,ispec,i_sls)
+ b_sigma_yz = b_sigma_yz - b_R_yz(i,j,k,ispec,i_sls)
+ endif !adjoint
+ enddo
+ endif
+
+ ! form dot product with test vector, symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1(i,j,k) = jacobianl * (b_sigma_xx*xixl + b_sigma_xy*xiyl + b_sigma_xz*xizl)
+ b_tempy1(i,j,k) = jacobianl * (b_sigma_xy*xixl + b_sigma_yy*xiyl + b_sigma_yz*xizl)
+ b_tempz1(i,j,k) = jacobianl * (b_sigma_xz*xixl + b_sigma_yz*xiyl + b_sigma_zz*xizl)
+ b_tempx2(i,j,k) = jacobianl * (b_sigma_xx*etaxl + b_sigma_xy*etayl + b_sigma_xz*etazl)
+ b_tempy2(i,j,k) = jacobianl * (b_sigma_xy*etaxl + b_sigma_yy*etayl + b_sigma_yz*etazl)
+ b_tempz2(i,j,k) = jacobianl * (b_sigma_xz*etaxl + b_sigma_yz*etayl + b_sigma_zz*etazl)
+ b_tempx3(i,j,k) = jacobianl * (b_sigma_xx*gammaxl + b_sigma_xy*gammayl + b_sigma_xz*gammazl)
+ b_tempy3(i,j,k) = jacobianl * (b_sigma_xy*gammaxl + b_sigma_yy*gammayl + b_sigma_yz*gammazl)
+ b_tempz3(i,j,k) = jacobianl * (b_sigma_xz*gammaxl + b_sigma_yz*gammayl + b_sigma_zz*gammazl)
+ endif !adjoint
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempy1l = 0.
+ tempz1l = 0.
+
+ tempx2l = 0.
+ tempy2l = 0.
+ tempz2l = 0.
+
+ tempx3l = 0.
+ tempy3l = 0.
+ tempz3l = 0.
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1l = 0.
+ b_tempy1l = 0.
+ b_tempz1l = 0.
+ b_tempx2l = 0.
+ b_tempy2l = 0.
+ b_tempz2l = 0.
+ b_tempx3l = 0.
+ b_tempy3l = 0.
+ b_tempz3l = 0.
+ endif !adjoint
+
+ do l=1,NGLLX
+ fac1 = hprimewgll_xx(l,i)
+ tempx1l = tempx1l + tempx1(l,j,k)*fac1
+ tempy1l = tempy1l + tempy1(l,j,k)*fac1
+ tempz1l = tempz1l + tempz1(l,j,k)*fac1
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1l = b_tempx1l + b_tempx1(l,j,k)*fac1
+ b_tempy1l = b_tempy1l + b_tempy1(l,j,k)*fac1
+ b_tempz1l = b_tempz1l + b_tempz1(l,j,k)*fac1
+ endif
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ fac2 = hprimewgll_yy(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx2l = b_tempx2l + b_tempx2(i,l,k)*fac2
+ b_tempy2l = b_tempy2l + b_tempy2(i,l,k)*fac2
+ b_tempz2l = b_tempz2l + b_tempz2(i,l,k)*fac2
+ endif
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ fac3 = hprimewgll_zz(l,k)
+ tempx3l = tempx3l + tempx3(i,j,l)*fac3
+ tempy3l = tempy3l + tempy3(i,j,l)*fac3
+ tempz3l = tempz3l + tempz3(i,j,l)*fac3
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx3l = b_tempx3l + b_tempx3(i,j,l)*fac3
+ b_tempy3l = b_tempy3l + b_tempy3(i,j,l)*fac3
+ b_tempz3l = b_tempz3l + b_tempz3(i,j,l)*fac3
+ endif
+ enddo
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+
+ ! sum contributions from each element to the global mesh
+
+ iglob = ibool(i,j,k,ispec)
+
+ accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_accel(1,iglob) = b_accel(1,iglob) - (fac1*b_tempx1l + fac2*b_tempx2l + fac3*b_tempx3l)
+ b_accel(2,iglob) = b_accel(2,iglob) - (fac1*b_tempy1l + fac2*b_tempy2l + fac3*b_tempy3l)
+ b_accel(3,iglob) = b_accel(3,iglob) - (fac1*b_tempz1l + fac2*b_tempz2l + fac3*b_tempz3l)
+ endif !adjoint
+
+ ! update memory variables based upon the Runge-Kutta scheme
+ if(ATTENUATION) then
+
+ ! use Runge-Kutta scheme to march in time
+ do i_sls = 1,N_SLS
+
+ ! get coefficients for that standard linear solid
+ if( USE_OLSEN_ATTENUATION ) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_olsen( vs_val, iselected )
+ else
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ factor_loc = mustore(i,j,k,ispec) * factor_common(iselected,i_sls)
+
+ alphaval_loc = alphaval(iselected,i_sls)
+ betaval_loc = betaval(iselected,i_sls)
+ gammaval_loc = gammaval(iselected,i_sls)
+
+ ! term in xx
+ Sn = factor_loc * epsilondev_xx(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xx_loc(i,j,k)
+ R_xx(i,j,k,ispec,i_sls) = alphaval_loc * R_xx(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+
+ ! term in yy
+ Sn = factor_loc * epsilondev_yy(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_yy_loc(i,j,k)
+ R_yy(i,j,k,ispec,i_sls) = alphaval_loc * R_yy(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+
+ ! term in zz not computed since zero trace
+
+ ! term in xy
+ Sn = factor_loc * epsilondev_xy(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xy_loc(i,j,k)
+ R_xy(i,j,k,ispec,i_sls) = alphaval_loc * R_xy(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+
+ ! term in xz
+ Sn = factor_loc * epsilondev_xz(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xz_loc(i,j,k)
+ R_xz(i,j,k,ispec,i_sls) = alphaval_loc * R_xz(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+
+ ! term in yz
+ Sn = factor_loc * epsilondev_yz(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_yz_loc(i,j,k)
+ R_yz(i,j,k,ispec,i_sls) = alphaval_loc * R_yz(i,j,k,ispec,i_sls) + &
+ betaval_loc * Sn + gammaval_loc * Snp1
+
+ !adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_alphaval_loc = b_alphaval(iselected,i_sls)
+ b_betaval_loc = b_betaval(iselected,i_sls)
+ b_gammaval_loc = b_gammaval(iselected,i_sls)
+ ! term in xx
+ b_Sn = factor_loc * b_epsilondev_xx(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xx_loc(i,j,k)
+ b_R_xx(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xx(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in yy
+ b_Sn = factor_loc * b_epsilondev_yy(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_yy_loc(i,j,k)
+ b_R_yy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yy(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in zz not computed since zero trace
+ ! term in xy
+ b_Sn = factor_loc * b_epsilondev_xy(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xy_loc(i,j,k)
+ b_R_xy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xy(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in xz
+ b_Sn = factor_loc * b_epsilondev_xz(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xz_loc(i,j,k)
+ b_R_xz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xz(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in yz
+ b_Sn = factor_loc * b_epsilondev_yz(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_yz_loc(i,j,k)
+ b_R_yz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yz(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ endif !adjoint
+
+ enddo ! end of loop on memory variables
+
+ endif ! end attenuation
+
+
+ enddo
+ enddo
+ enddo
+
+ ! save deviatoric strain for Runge-Kutta scheme
+ if(ATTENUATION) then
+ epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:)
+ epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:)
+ epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:)
+ epsilondev_xz(:,:,:,ispec) = epsilondev_xz_loc(:,:,:)
+ epsilondev_yz(:,:,:,ispec) = epsilondev_yz_loc(:,:,:)
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_epsilondev_xx(:,:,:,ispec) = b_epsilondev_xx_loc(:,:,:)
+ b_epsilondev_yy(:,:,:,ispec) = b_epsilondev_yy_loc(:,:,:)
+ b_epsilondev_xy(:,:,:,ispec) = b_epsilondev_xy_loc(:,:,:)
+ b_epsilondev_xz(:,:,:,ispec) = b_epsilondev_xz_loc(:,:,:)
+ b_epsilondev_yz(:,:,:,ispec) = b_epsilondev_yz_loc(:,:,:)
+ endif !adjoint
+ endif
+! endif ! ispec_is_elastic
+! endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
+
+ enddo ! spectral element loop
+
+! forces in elastic media calculated in compute_forces_elastic...
+!! adding source
+! do isource = 1,NSOURCES
+!
+! if (ispec_is_inner(ispec_selected_source(isource)) .eqv. phase_is_inner) then
+!
+! if(USE_FORCE_POINT_SOURCE) then
+!
+!! add the source (only if this proc carries the source)
+! if(myrank == islice_selected_source(isource)) then
+!
+! iglob = ibool(nint(xi_source(isource)), &
+! nint(eta_source(isource)), &
+! nint(gamma_source(isource)), &
+! ispec_selected_source(isource))
+! f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+! t0 = 1.2d0/f0
+!
+! if (it == 1 .and. myrank == 0) then
+! print *,'using a source of dominant frequency ',f0
+! print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+! print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+! endif
+!
+! ! we use nu_source(:,3) here because we want a source normal to the surface.
+! ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+! !accel(:,iglob) = accel(:,iglob) + &
+! ! sngl(nu_source(:,3,isource) * 10000000.d0 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
+! ! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
+! accel(:,iglob) = accel(:,iglob) + &
+! sngl(nu_source(:,3,isource) * 1.d10 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
+! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
+!
+! endif
+! endif
+!
+! endif
+!
+! enddo
+
+end subroutine compute_forces_elastic_noDev
+
Deleted: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_no_Deville.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,589 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D V e r s i o n 1 . 4
-! ---------------------------------------
-!
-! Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory - California Institute of Technology
-! (c) California Institute of Technology September 2006
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-subroutine compute_forces_no_Deville( phase_is_inner, &
- NSPEC_AB,NGLOB_AB,displ,accel,&
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_yy,hprime_zz,&
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,&
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,&
- ispec_is_inner,&
- ATTENUATION,USE_OLSEN_ATTENUATION,&
- one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,&
- NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,&
- epsilondev_xz,epsilondev_yz,iflag_attenuation_store,&
- rho_vs,&
- ANISOTROPY,NSPEC_ANISO, &
- c11store,c12store,c13store,c14store,c15store,c16store,&
- c22store,c23store,c24store,c25store,c26store,c33store,&
- c34store,c35store,c36store,c44store,c45store,c46store,&
- c55store,c56store,c66store, &
- ispec_is_elastic )
-
-! NSOURCES,myrank,islice_selected_source,&
-! ispec_selected_source,xi_source,eta_source,&
-! gamma_source,nu_source,hdur,dt)
-
- implicit none
-
- include "constants.h"
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ,accel
-
-! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
- kappastore,mustore,jacobian
-
-! array with derivatives of Lagrange polynomials and precalculated products
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
-! memory variables and standard linear solids for attenuation
- logical :: ATTENUATION,USE_OLSEN_ATTENUATION
- integer :: NSPEC_ATTENUATION_AB
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
- R_xx,R_yy,R_xy,R_xz,R_yz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vs
-
-! anisotropy
- logical :: ANISOTROPY
- integer :: NSPEC_ANISO
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO) :: &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store, &
- c34store,c35store,c36store,c44store,c45store,c46store, &
- c55store,c56store,c66store
-
- logical,dimension(NSPEC_AB) :: ispec_is_elastic
-
-! source
-! integer :: NSOURCES,myrank,it
-! integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
-! double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
-! double precision, dimension(3,3,NSOURCES) :: nu_source
-! double precision, dimension(NSOURCES) :: hdur
-! double precision :: dt
-! integer :: isource
-! double precision :: t0,f0
-
-! local parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
-
- integer ispec,iglob
- integer i,j,k,l
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
-
- real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
-
- real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
-
- real(kind=CUSTOM_REAL) hp1,hp2,hp3
- real(kind=CUSTOM_REAL) fac1,fac2,fac3
-
- real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
- real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
- real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
-
- real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
- real(kind=CUSTOM_REAL) kappal
-
-! local anisotropy parameters
- real(kind=CUSTOM_REAL) c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
- c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
-
-! local attenuation parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xx_loc, &
- epsilondev_yy_loc, epsilondev_xy_loc, epsilondev_xz_loc, epsilondev_yz_loc
- real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
- real(kind=CUSTOM_REAL) factor_loc,alphaval_loc,betaval_loc,gammaval_loc,Sn,Snp1
- real(kind=CUSTOM_REAL) epsilon_trace_over_3
- real(kind=CUSTOM_REAL) vs_val
-
- integer i_SLS,iselected
-
-
- do ispec = 1,NSPEC_AB
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- if( ispec_is_elastic(ispec) ) then
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0.
- tempx2l = 0.
- tempx3l = 0.
-
- tempy1l = 0.
- tempy2l = 0.
- tempy3l = 0.
-
- tempz1l = 0.
- tempz2l = 0.
- tempz3l = 0.
-
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l = tempx1l + displ(1,iglob)*hp1
- tempy1l = tempy1l + displ(2,iglob)*hp1
- tempz1l = tempz1l + displ(3,iglob)*hp1
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l = tempx2l + displ(1,iglob)*hp2
- tempy2l = tempy2l + displ(2,iglob)*hp2
- tempz2l = tempz2l + displ(3,iglob)*hp2
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l = tempx3l + displ(1,iglob)*hp3
- tempy3l = tempy3l + displ(2,iglob)*hp3
- tempz3l = tempz3l + displ(3,iglob)*hp3
- enddo
-
- ! get derivatives of ux, uy and uz with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
- jacobianl = jacobian(i,j,k,ispec)
-
- duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
- duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
- duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
- duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
-
- duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
- duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
- duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
-
- ! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
-
- kappal = kappastore(i,j,k,ispec)
- mul = mustore(i,j,k,ispec)
-
- if(ATTENUATION) then
- ! compute deviatoric strain
- epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_xx_loc(i,j,k) = duxdxl - epsilon_trace_over_3
- epsilondev_yy_loc(i,j,k) = duydyl - epsilon_trace_over_3
- epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl
-
- !if (SIMULATION_TYPE == 3) then
- ! b_epsilon_trace_over_3 = ONE_THIRD * (b_duxdxl + b_duydyl + b_duzdzl)
- ! b_epsilondev_xx_loc(i,j,k) = b_duxdxl - b_epsilon_trace_over_3
- ! b_epsilondev_yy_loc(i,j,k) = b_duydyl - b_epsilon_trace_over_3
- ! b_epsilondev_xy_loc(i,j,k) = 0.5 * b_duxdyl_plus_duydxl
- ! b_epsilondev_xz_loc(i,j,k) = 0.5 * b_duzdxl_plus_duxdzl
- ! b_epsilondev_yz_loc(i,j,k) = 0.5 * b_duzdyl_plus_duydzl
- !endif
-
- ! uses scaling rule similar to Olsen et al. (2003) or mesh flag
- if(USE_OLSEN_ATTENUATION) then
- vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
- call get_attenuation_model_olsen( vs_val, iselected )
- else
- ! iflag from (CUBIT) mesh
- iselected = iflag_attenuation_store(i,j,k,ispec)
- endif
-
- ! use unrelaxed parameters if attenuation
- mul = mul * one_minus_sum_beta(iselected)
-
- endif
-
- ! full anisotropic case, stress calculations
- if(ANISOTROPY) then
- c11 = c11store(i,j,k,ispec)
- c12 = c12store(i,j,k,ispec)
- c13 = c13store(i,j,k,ispec)
- c14 = c14store(i,j,k,ispec)
- c15 = c15store(i,j,k,ispec)
- c16 = c16store(i,j,k,ispec)
- c22 = c22store(i,j,k,ispec)
- c23 = c23store(i,j,k,ispec)
- c24 = c24store(i,j,k,ispec)
- c25 = c25store(i,j,k,ispec)
- c26 = c26store(i,j,k,ispec)
- c33 = c33store(i,j,k,ispec)
- c34 = c34store(i,j,k,ispec)
- c35 = c35store(i,j,k,ispec)
- c36 = c36store(i,j,k,ispec)
- c44 = c44store(i,j,k,ispec)
- c45 = c45store(i,j,k,ispec)
- c46 = c46store(i,j,k,ispec)
- c55 = c55store(i,j,k,ispec)
- c56 = c56store(i,j,k,ispec)
- c66 = c66store(i,j,k,ispec)
- !if(ATTENUATION .and. not_fully_in_bedrock(ispec)) then
- ! mul = c44
- ! c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
- ! c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
- ! c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
- ! c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
- ! c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
- ! c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
- ! c44 = c44 + minus_sum_beta * mul
- ! c55 = c55 + minus_sum_beta * mul
- ! c66 = c66 + minus_sum_beta * mul
- !endif
-
- sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
- c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
- sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
- c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
- sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
- c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
- sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
- c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
- sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
- c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
- sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
- c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
-
- !if (SIMULATION_TYPE == 3) then
- ! b_sigma_xx = c11*b_duxdxl + c16*b_duxdyl_plus_duydxl + c12*b_duydyl + &
- ! c15*b_duzdxl_plus_duxdzl + c14*b_duzdyl_plus_duydzl + c13*b_duzdzl
- ! b_sigma_yy = c12*b_duxdxl + c26*b_duxdyl_plus_duydxl + c22*b_duydyl + &
- ! c25*b_duzdxl_plus_duxdzl + c24*b_duzdyl_plus_duydzl + c23*b_duzdzl
- ! b_sigma_zz = c13*b_duxdxl + c36*b_duxdyl_plus_duydxl + c23*b_duydyl + &
- ! c35*b_duzdxl_plus_duxdzl + c34*b_duzdyl_plus_duydzl + c33*b_duzdzl
- ! b_sigma_xy = c16*b_duxdxl + c66*b_duxdyl_plus_duydxl + c26*b_duydyl + &
- ! c56*b_duzdxl_plus_duxdzl + c46*b_duzdyl_plus_duydzl + c36*b_duzdzl
- ! b_sigma_xz = c15*b_duxdxl + c56*b_duxdyl_plus_duydxl + c25*b_duydyl + &
- ! c55*b_duzdxl_plus_duxdzl + c45*b_duzdyl_plus_duydzl + c35*b_duzdzl
- ! b_sigma_yz = c14*b_duxdxl + c46*b_duxdyl_plus_duydxl + c24*b_duydyl + &
- ! c45*b_duzdxl_plus_duxdzl + c44*b_duzdyl_plus_duydzl + c34*b_duzdzl
- !endif
- else
-
- ! isotropic case
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
-
- ! compute stress sigma
- sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
-
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
-
- !if (SIMULATION_TYPE == 3) then
- ! b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
- ! b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
- ! b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
- !
- ! b_sigma_xy = mul*b_duxdyl_plus_duydxl
- ! b_sigma_xz = mul*b_duzdxl_plus_duxdzl
- ! b_sigma_yz = mul*b_duzdyl_plus_duydzl
- !endif
-
- endif ! ANISOTROPY
-
- ! subtract memory variables if attenuation
- if(ATTENUATION) then
- do i_sls = 1,N_SLS
- R_xx_val = R_xx(i,j,k,ispec,i_sls)
- R_yy_val = R_yy(i,j,k,ispec,i_sls)
- sigma_xx = sigma_xx - R_xx_val
- sigma_yy = sigma_yy - R_yy_val
- sigma_zz = sigma_zz + R_xx_val + R_yy_val
- sigma_xy = sigma_xy - R_xy(i,j,k,ispec,i_sls)
- sigma_xz = sigma_xz - R_xz(i,j,k,ispec,i_sls)
- sigma_yz = sigma_yz - R_yz(i,j,k,ispec,i_sls)
- enddo
- endif
-
- ! form dot product with test vector, symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
-
- enddo
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0.
- tempy1l = 0.
- tempz1l = 0.
-
- tempx2l = 0.
- tempy2l = 0.
- tempz2l = 0.
-
- tempx3l = 0.
- tempy3l = 0.
- tempz3l = 0.
-
- do l=1,NGLLX
- fac1 = hprimewgll_xx(l,i)
- tempx1l = tempx1l + tempx1(l,j,k)*fac1
- tempy1l = tempy1l + tempy1(l,j,k)*fac1
- tempz1l = tempz1l + tempz1(l,j,k)*fac1
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- fac2 = hprimewgll_yy(l,j)
- tempx2l = tempx2l + tempx2(i,l,k)*fac2
- tempy2l = tempy2l + tempy2(i,l,k)*fac2
- tempz2l = tempz2l + tempz2(i,l,k)*fac2
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- fac3 = hprimewgll_zz(l,k)
- tempx3l = tempx3l + tempx3(i,j,l)*fac3
- tempy3l = tempy3l + tempy3(i,j,l)*fac3
- tempz3l = tempz3l + tempz3(i,j,l)*fac3
- enddo
-
- fac1 = wgllwgll_yz(j,k)
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
-
- ! sum contributions from each element to the global mesh
-
- iglob = ibool(i,j,k,ispec)
-
- accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
- accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
- accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
-
- ! update memory variables based upon the Runge-Kutta scheme
- if(ATTENUATION) then
-
- ! use Runge-Kutta scheme to march in time
- do i_sls = 1,N_SLS
-
- ! get coefficients for that standard linear solid
- if( USE_OLSEN_ATTENUATION ) then
- vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
- call get_attenuation_model_olsen( vs_val, iselected )
- else
- iselected = iflag_attenuation_store(i,j,k,ispec)
- endif
-
- factor_loc = mustore(i,j,k,ispec) * factor_common(iselected,i_sls)
- alphaval_loc = alphaval(iselected,i_sls)
- betaval_loc = betaval(iselected,i_sls)
- gammaval_loc = gammaval(iselected,i_sls)
-
- ! term in xx
- Sn = factor_loc * epsilondev_xx(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_xx_loc(i,j,k)
- R_xx(i,j,k,ispec,i_sls) = alphaval_loc * R_xx(i,j,k,ispec,i_sls) + &
- betaval_loc * Sn + gammaval_loc * Snp1
-
- ! term in yy
- Sn = factor_loc * epsilondev_yy(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_yy_loc(i,j,k)
- R_yy(i,j,k,ispec,i_sls) = alphaval_loc * R_yy(i,j,k,ispec,i_sls) + &
- betaval_loc * Sn + gammaval_loc * Snp1
-
- ! term in zz not computed since zero trace
-
- ! term in xy
- Sn = factor_loc * epsilondev_xy(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_xy_loc(i,j,k)
- R_xy(i,j,k,ispec,i_sls) = alphaval_loc * R_xy(i,j,k,ispec,i_sls) + &
- betaval_loc * Sn + gammaval_loc * Snp1
-
- ! term in xz
- Sn = factor_loc * epsilondev_xz(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_xz_loc(i,j,k)
- R_xz(i,j,k,ispec,i_sls) = alphaval_loc * R_xz(i,j,k,ispec,i_sls) + &
- betaval_loc * Sn + gammaval_loc * Snp1
-
- ! term in yz
- Sn = factor_loc * epsilondev_yz(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_yz_loc(i,j,k)
- R_yz(i,j,k,ispec,i_sls) = alphaval_loc * R_yz(i,j,k,ispec,i_sls) + &
- betaval_loc * Sn + gammaval_loc * Snp1
-
- !if (SIMULATION_TYPE == 3) then
- ! b_alphaval_loc = b_alphaval(iselected,i_sls)
- ! b_betaval_loc = b_betaval(iselected,i_sls)
- ! b_gammaval_loc = b_gammaval(iselected,i_sls)
- ! ! term in xx
- ! b_Sn = factor_loc * b_epsilondev_xx(i,j,k,ispec)
- ! b_Snp1 = factor_loc * b_epsilondev_xx_loc(i,j,k)
- ! b_R_xx(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xx(i,j,k,ispec,i_sls) + &
- ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
- ! ! term in yy
- ! b_Sn = factor_loc * b_epsilondev_yy(i,j,k,ispec)
- ! b_Snp1 = factor_loc * b_epsilondev_yy_loc(i,j,k)
- ! b_R_yy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yy(i,j,k,ispec,i_sls) + &
- ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
- ! ! term in zz not computed since zero trace
- ! ! term in xy
- ! b_Sn = factor_loc * b_epsilondev_xy(i,j,k,ispec)
- ! b_Snp1 = factor_loc * b_epsilondev_xy_loc(i,j,k)
- ! b_R_xy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xy(i,j,k,ispec,i_sls) + &
- ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
- ! ! term in xz
- ! b_Sn = factor_loc * b_epsilondev_xz(i,j,k,ispec)
- ! b_Snp1 = factor_loc * b_epsilondev_xz_loc(i,j,k)
- ! b_R_xz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xz(i,j,k,ispec,i_sls) + &
- ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
- ! ! term in yz
- ! b_Sn = factor_loc * b_epsilondev_yz(i,j,k,ispec)
- ! b_Snp1 = factor_loc * b_epsilondev_yz_loc(i,j,k)
- ! b_R_yz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yz(i,j,k,ispec,i_sls) + &
- ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
- !endif
-
- enddo ! end of loop on memory variables
-
- endif ! end attenuation
-
-
- enddo
- enddo
- enddo
-
- ! save deviatoric strain for Runge-Kutta scheme
- if(ATTENUATION) then
- epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:)
- epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:)
- epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:)
- epsilondev_xz(:,:,:,ispec) = epsilondev_xz_loc(:,:,:)
- epsilondev_yz(:,:,:,ispec) = epsilondev_yz_loc(:,:,:)
- !if (SIMULATION_TYPE == 3) then
- ! b_epsilondev_xx(:,:,:,ispec) = b_epsilondev_xx_loc(:,:,:)
- ! b_epsilondev_yy(:,:,:,ispec) = b_epsilondev_yy_loc(:,:,:)
- ! b_epsilondev_xy(:,:,:,ispec) = b_epsilondev_xy_loc(:,:,:)
- ! b_epsilondev_xz(:,:,:,ispec) = b_epsilondev_xz_loc(:,:,:)
- ! b_epsilondev_yz(:,:,:,ispec) = b_epsilondev_yz_loc(:,:,:)
- !endif
- endif
- endif ! ispec_is_elastic
- endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
-
- enddo ! spectral element loop
-
-! forces in elastic media calculated in compute_forces_elastic...
-!! adding source
-! do isource = 1,NSOURCES
-!
-! if (ispec_is_inner(ispec_selected_source(isource)) .eqv. phase_is_inner) then
-!
-! if(USE_FORCE_POINT_SOURCE) then
-!
-!! add the source (only if this proc carries the source)
-! if(myrank == islice_selected_source(isource)) then
-!
-! iglob = ibool(nint(xi_source(isource)), &
-! nint(eta_source(isource)), &
-! nint(gamma_source(isource)), &
-! ispec_selected_source(isource))
-! f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
-! t0 = 1.2d0/f0
-!
-! if (it == 1 .and. myrank == 0) then
-! print *,'using a source of dominant frequency ',f0
-! print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
-! print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
-! endif
-!
-! ! we use nu_source(:,3) here because we want a source normal to the surface.
-! ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
-! !accel(:,iglob) = accel(:,iglob) + &
-! ! sngl(nu_source(:,3,isource) * 10000000.d0 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
-! ! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
-! accel(:,iglob) = accel(:,iglob) + &
-! sngl(nu_source(:,3,isource) * 1.d10 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
-! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
-!
-! endif
-! endif
-!
-! endif
-!
-! enddo
-
-end subroutine compute_forces_no_Deville
-
Deleted: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,1491 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D V e r s i o n 1 . 4
-! ---------------------------------------
-!
-! Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory - California Institute of Technology
-! (c) California Institute of Technology September 2006
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
-subroutine compute_forces_with_Deville( phase_is_inner ,NSPEC_AB,NGLOB_AB, &
- displ,accel, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool, &
- ispec_is_inner, &
- ATTENUATION,USE_OLSEN_ATTENUATION, &
- one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,&
- NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy, &
- epsilondev_xz,epsilondev_yz,iflag_attenuation_store, &
- rho_vs, &
- ANISOTROPY,NSPEC_ANISO, &
- c11store,c12store,c13store,c14store,c15store,c16store,&
- c22store,c23store,c24store,c25store,c26store,c33store,&
- c34store,c35store,c36store,c44store,c45store,c46store,&
- c55store,c56store,c66store, &
- ispec_is_elastic )
-
-! computes elastic tensor term
-
- implicit none
-
- include "constants.h"
-
- integer :: NSPEC_AB,NGLOB_AB
-
-! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ,accel
-
-! arrays with mesh parameters per slice
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
- kappastore,mustore,jacobian
-
-! array with derivatives of Lagrange polynomials and precalculated products
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
-! communication overlap
- logical, dimension(NSPEC_AB) :: ispec_is_inner
- logical :: phase_is_inner
-
-! memory variables and standard linear solids for attenuation
- logical :: ATTENUATION,USE_OLSEN_ATTENUATION
- integer :: NSPEC_ATTENUATION_AB
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
- R_xx,R_yy,R_xy,R_xz,R_yz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vs
-
-! anisotropy
- logical :: ANISOTROPY
- integer :: NSPEC_ANISO
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO) :: &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store, &
- c34store,c35store,c36store,c44store,c45store,c46store, &
- c55store,c56store,c66store
-
- logical,dimension(NSPEC_AB) :: ispec_is_elastic
-
-! local parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
- newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
-
-! manually inline the calls to the Deville et al. (2002) routines
- real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
- real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
- real(kind=CUSTOM_REAL), dimension(m1,m2) :: E1_m1_m2_5points,E2_m1_m2_5points,E3_m1_m2_5points
-
- equivalence(dummyx_loc,B1_m1_m2_5points)
- equivalence(dummyy_loc,B2_m1_m2_5points)
- equivalence(dummyz_loc,B3_m1_m2_5points)
- equivalence(tempx1,C1_m1_m2_5points)
- equivalence(tempy1,C2_m1_m2_5points)
- equivalence(tempz1,C3_m1_m2_5points)
- equivalence(newtempx1,E1_m1_m2_5points)
- equivalence(newtempy1,E2_m1_m2_5points)
- equivalence(newtempz1,E3_m1_m2_5points)
-
- real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
- real(kind=CUSTOM_REAL), dimension(m2,m1) :: C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
- real(kind=CUSTOM_REAL), dimension(m2,m1) :: E1_mxm_m2_m1_5points,E2_mxm_m2_m1_5points,E3_mxm_m2_m1_5points
-
- equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
- equivalence(dummyy_loc,A2_mxm_m2_m1_5points)
- equivalence(dummyz_loc,A3_mxm_m2_m1_5points)
- equivalence(tempx3,C1_mxm_m2_m1_5points)
- equivalence(tempy3,C2_mxm_m2_m1_5points)
- equivalence(tempz3,C3_mxm_m2_m1_5points)
- equivalence(newtempx3,E1_mxm_m2_m1_5points)
- equivalence(newtempy3,E2_mxm_m2_m1_5points)
- equivalence(newtempz3,E3_mxm_m2_m1_5points)
-
-! local attenuation parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xx_loc, &
- epsilondev_yy_loc, epsilondev_xy_loc, epsilondev_xz_loc, epsilondev_yz_loc
- real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
- real(kind=CUSTOM_REAL) factor_loc,alphaval_loc,betaval_loc,gammaval_loc,Sn,Snp1
- real(kind=CUSTOM_REAL) epsilon_trace_over_3
- real(kind=CUSTOM_REAL) vs_val
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
-
- real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
-
- real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
-
- real(kind=CUSTOM_REAL) fac1,fac2,fac3
-
- real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
- real(kind=CUSTOM_REAL) kappal
-
-! local anisotropy parameters
- real(kind=CUSTOM_REAL) c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
- c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
-
- integer i_SLS,iselected
-
- integer ispec,iglob
- integer i,j,k
-
-! loops over all elements
- do ispec = 1,NSPEC_AB
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- if( ispec_is_elastic(ispec) ) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- dummyx_loc(i,j,k) = displ(1,iglob)
- dummyy_loc(i,j,k) = displ(2,iglob)
- dummyz_loc(i,j,k) = displ(3,iglob)
- enddo
- enddo
- enddo
-
- ! subroutines adapted from Deville, Fischer and Mund, High-order methods
- ! for incompressible fluid flow, Cambridge University Press (2002),
- ! pages 386 and 389 and Figure 8.3.1
- ! call mxm_m1_m2_5points(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
- do j=1,m2
- do i=1,m1
- C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B1_m1_m2_5points(5,j)
-
- C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B2_m1_m2_5points(5,j)
-
- C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B3_m1_m2_5points(5,j)
- enddo
- enddo
-
- ! call mxm_m1_m1_5points(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k), &
- ! hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
- do j=1,m1
- do i=1,m1
- ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyx_loc(i,5,k)*hprime_xxT(5,j)
-
- tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyy_loc(i,5,k)*hprime_xxT(5,j)
-
- tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyz_loc(i,5,k)*hprime_xxT(5,j)
- enddo
- enddo
- enddo
-
- ! call mxm_m2_m1_5points(dummyx_loc,dummyy_loc,dummyz_loc,tempx3,tempy3,tempz3)
- do j=1,m1
- do i=1,m2
- C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
-
- C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
-
- C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- ! get derivatives of ux, uy and uz with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
- jacobianl = jacobian(i,j,k,ispec)
-
- duxdxl = xixl*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
- duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
- duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
-
- duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
- duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
- duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
-
- duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
- duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
- duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
-
- ! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
-
- kappal = kappastore(i,j,k,ispec)
- mul = mustore(i,j,k,ispec)
-
- ! attenuation
- if(ATTENUATION) then
- ! compute deviatoric strain
- epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_xx_loc(i,j,k) = duxdxl - epsilon_trace_over_3
- epsilondev_yy_loc(i,j,k) = duydyl - epsilon_trace_over_3
- epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl
-
- !if (SIMULATION_TYPE == 3) then
- ! b_epsilon_trace_over_3 = ONE_THIRD * (b_duxdxl + b_duydyl + b_duzdzl)
- ! b_epsilondev_xx_loc(i,j,k) = b_duxdxl - b_epsilon_trace_over_3
- ! b_epsilondev_yy_loc(i,j,k) = b_duydyl - b_epsilon_trace_over_3
- ! b_epsilondev_xy_loc(i,j,k) = 0.5 * b_duxdyl_plus_duydxl
- ! b_epsilondev_xz_loc(i,j,k) = 0.5 * b_duzdxl_plus_duxdzl
- ! b_epsilondev_yz_loc(i,j,k) = 0.5 * b_duzdyl_plus_duydzl
- !endif
-
- ! uses scaling rule similar to Olsen et al. (2003) or mesh flag
- if(USE_OLSEN_ATTENUATION) then
- vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
- call get_attenuation_model_olsen( vs_val, iselected )
- else
- ! iflag from (CUBIT) mesh
- iselected = iflag_attenuation_store(i,j,k,ispec)
- endif
-
- ! use unrelaxed parameters if attenuation
- mul = mul * one_minus_sum_beta(iselected)
-
- endif
-
- ! full anisotropic case, stress calculations
- if(ANISOTROPY) then
- c11 = c11store(i,j,k,ispec)
- c12 = c12store(i,j,k,ispec)
- c13 = c13store(i,j,k,ispec)
- c14 = c14store(i,j,k,ispec)
- c15 = c15store(i,j,k,ispec)
- c16 = c16store(i,j,k,ispec)
- c22 = c22store(i,j,k,ispec)
- c23 = c23store(i,j,k,ispec)
- c24 = c24store(i,j,k,ispec)
- c25 = c25store(i,j,k,ispec)
- c26 = c26store(i,j,k,ispec)
- c33 = c33store(i,j,k,ispec)
- c34 = c34store(i,j,k,ispec)
- c35 = c35store(i,j,k,ispec)
- c36 = c36store(i,j,k,ispec)
- c44 = c44store(i,j,k,ispec)
- c45 = c45store(i,j,k,ispec)
- c46 = c46store(i,j,k,ispec)
- c55 = c55store(i,j,k,ispec)
- c56 = c56store(i,j,k,ispec)
- c66 = c66store(i,j,k,ispec)
- !if(ATTENUATION .and. not_fully_in_bedrock(ispec)) then
- ! mul = c44
- ! c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
- ! c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
- ! c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
- ! c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
- ! c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
- ! c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
- ! c44 = c44 + minus_sum_beta * mul
- ! c55 = c55 + minus_sum_beta * mul
- ! c66 = c66 + minus_sum_beta * mul
- !endif
-
- sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
- c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
- sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
- c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
- sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
- c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
- sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
- c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
- sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
- c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
- sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
- c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
-
- !if (SIMULATION_TYPE == 3) then
- ! b_sigma_xx = c11*b_duxdxl + c16*b_duxdyl_plus_duydxl + c12*b_duydyl + &
- ! c15*b_duzdxl_plus_duxdzl + c14*b_duzdyl_plus_duydzl + c13*b_duzdzl
- ! b_sigma_yy = c12*b_duxdxl + c26*b_duxdyl_plus_duydxl + c22*b_duydyl + &
- ! c25*b_duzdxl_plus_duxdzl + c24*b_duzdyl_plus_duydzl + c23*b_duzdzl
- ! b_sigma_zz = c13*b_duxdxl + c36*b_duxdyl_plus_duydxl + c23*b_duydyl + &
- ! c35*b_duzdxl_plus_duxdzl + c34*b_duzdyl_plus_duydzl + c33*b_duzdzl
- ! b_sigma_xy = c16*b_duxdxl + c66*b_duxdyl_plus_duydxl + c26*b_duydyl + &
- ! c56*b_duzdxl_plus_duxdzl + c46*b_duzdyl_plus_duydzl + c36*b_duzdzl
- ! b_sigma_xz = c15*b_duxdxl + c56*b_duxdyl_plus_duydxl + c25*b_duydyl + &
- ! c55*b_duzdxl_plus_duxdzl + c45*b_duzdyl_plus_duydzl + c35*b_duzdzl
- ! b_sigma_yz = c14*b_duxdxl + c46*b_duxdyl_plus_duydxl + c24*b_duydyl + &
- ! c45*b_duzdxl_plus_duxdzl + c44*b_duzdyl_plus_duydzl + c34*b_duzdzl
- !endif
- else
-
- ! isotropic case
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
-
- ! compute stress sigma
- sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
-
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
-
- !if (SIMULATION_TYPE == 3) then
- ! b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
- ! b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
- ! b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
- !
- ! b_sigma_xy = mul*b_duxdyl_plus_duydxl
- ! b_sigma_xz = mul*b_duzdxl_plus_duxdzl
- ! b_sigma_yz = mul*b_duzdyl_plus_duydzl
- !endif
-
- endif ! ANISOTROPY
-
- ! subtract memory variables if attenuation
- if(ATTENUATION) then
- do i_sls = 1,N_SLS
- R_xx_val = R_xx(i,j,k,ispec,i_sls)
- R_yy_val = R_yy(i,j,k,ispec,i_sls)
- sigma_xx = sigma_xx - R_xx_val
- sigma_yy = sigma_yy - R_yy_val
- sigma_zz = sigma_zz + R_xx_val + R_yy_val
- sigma_xy = sigma_xy - R_xy(i,j,k,ispec,i_sls)
- sigma_xz = sigma_xz - R_xz(i,j,k,ispec,i_sls)
- sigma_yz = sigma_yz - R_yz(i,j,k,ispec,i_sls)
- enddo
-
- !if (SIMULATION_TYPE == 3) then
- ! b_R_xx_val = b_R_xx(i,j,k,ispec,i_sls)
- ! b_R_yy_val = b_R_yy(i,j,k,ispec,i_sls)
- ! b_sigma_xx = b_sigma_xx - b_R_xx_val
- ! b_sigma_yy = b_sigma_yy - b_R_yy_val
- ! b_sigma_zz = b_sigma_zz + b_R_xx_val + b_R_yy_val
- ! b_sigma_xy = b_sigma_xy - b_R_xy(i,j,k,ispec,i_sls)
- ! b_sigma_xz = b_sigma_xz - b_R_xz(i,j,k,ispec,i_sls)
- ! b_sigma_yz = b_sigma_yz - b_R_yz(i,j,k,ispec,i_sls)
- !endif
- endif
-
- ! form dot product with test vector, symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
-
- enddo
- enddo
- enddo
-
- ! subroutines adapted from Deville, Fischer and Mund, High-order methods
- ! for incompressible fluid flow, Cambridge University Press (2002),
- ! pages 386 and 389 and Figure 8.3.1
- ! call mxm_m1_m2_5points(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
- do j=1,m2
- do i=1,m1
- E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
-
- E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
-
- E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
- enddo
- enddo
-
- ! call mxm_m1_m1_5points(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k), &
- ! hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
- do i=1,m1
- do j=1,m1
- ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
- tempx2(i,2,k)*hprimewgll_xx(2,j) + &
- tempx2(i,3,k)*hprimewgll_xx(3,j) + &
- tempx2(i,4,k)*hprimewgll_xx(4,j) + &
- tempx2(i,5,k)*hprimewgll_xx(5,j)
-
- newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
- tempy2(i,2,k)*hprimewgll_xx(2,j) + &
- tempy2(i,3,k)*hprimewgll_xx(3,j) + &
- tempy2(i,4,k)*hprimewgll_xx(4,j) + &
- tempy2(i,5,k)*hprimewgll_xx(5,j)
-
- newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
- tempz2(i,2,k)*hprimewgll_xx(2,j) + &
- tempz2(i,3,k)*hprimewgll_xx(3,j) + &
- tempz2(i,4,k)*hprimewgll_xx(4,j) + &
- tempz2(i,5,k)*hprimewgll_xx(5,j)
- enddo
- enddo
- enddo
-
- ! call mxm_m2_m1_5points(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
- do j=1,m1
- do i=1,m2
- E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
-
- E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
-
- E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- fac1 = wgllwgll_yz(j,k)
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
-
- ! sum contributions from each element to the global mesh using indirect addressing
- iglob = ibool(i,j,k,ispec)
- accel(1,iglob) = accel(1,iglob) - fac1*newtempx1(i,j,k) - &
- fac2*newtempx2(i,j,k) - fac3*newtempx3(i,j,k)
- accel(2,iglob) = accel(2,iglob) - fac1*newtempy1(i,j,k) - &
- fac2*newtempy2(i,j,k) - fac3*newtempy3(i,j,k)
- accel(3,iglob) = accel(3,iglob) - fac1*newtempz1(i,j,k) - &
- fac2*newtempz2(i,j,k) - fac3*newtempz3(i,j,k)
-
- ! update memory variables based upon the Runge-Kutta scheme
- if(ATTENUATION) then
-
- ! use Runge-Kutta scheme to march in time
- do i_sls = 1,N_SLS
-
- ! get coefficients for that standard linear solid
- if( USE_OLSEN_ATTENUATION ) then
- vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
- call get_attenuation_model_olsen( vs_val, iselected )
- else
- iselected = iflag_attenuation_store(i,j,k,ispec)
- endif
-
- factor_loc = mustore(i,j,k,ispec) * factor_common(iselected,i_sls)
- alphaval_loc = alphaval(iselected,i_sls)
- betaval_loc = betaval(iselected,i_sls)
- gammaval_loc = gammaval(iselected,i_sls)
-
- ! term in xx
- Sn = factor_loc * epsilondev_xx(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_xx_loc(i,j,k)
- R_xx(i,j,k,ispec,i_sls) = alphaval_loc * R_xx(i,j,k,ispec,i_sls) + &
- betaval_loc * Sn + gammaval_loc * Snp1
-
- ! term in yy
- Sn = factor_loc * epsilondev_yy(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_yy_loc(i,j,k)
- R_yy(i,j,k,ispec,i_sls) = alphaval_loc * R_yy(i,j,k,ispec,i_sls) + &
- betaval_loc * Sn + gammaval_loc * Snp1
-
- ! term in zz not computed since zero trace
-
- ! term in xy
- Sn = factor_loc * epsilondev_xy(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_xy_loc(i,j,k)
- R_xy(i,j,k,ispec,i_sls) = alphaval_loc * R_xy(i,j,k,ispec,i_sls) + &
- betaval_loc * Sn + gammaval_loc * Snp1
-
- ! term in xz
- Sn = factor_loc * epsilondev_xz(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_xz_loc(i,j,k)
- R_xz(i,j,k,ispec,i_sls) = alphaval_loc * R_xz(i,j,k,ispec,i_sls) + &
- betaval_loc * Sn + gammaval_loc * Snp1
-
- ! term in yz
- Sn = factor_loc * epsilondev_yz(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_yz_loc(i,j,k)
- R_yz(i,j,k,ispec,i_sls) = alphaval_loc * R_yz(i,j,k,ispec,i_sls) + &
- betaval_loc * Sn + gammaval_loc * Snp1
-
- !if (SIMULATION_TYPE == 3) then
- ! b_alphaval_loc = b_alphaval(iselected,i_sls)
- ! b_betaval_loc = b_betaval(iselected,i_sls)
- ! b_gammaval_loc = b_gammaval(iselected,i_sls)
- ! ! term in xx
- ! b_Sn = factor_loc * b_epsilondev_xx(i,j,k,ispec)
- ! b_Snp1 = factor_loc * b_epsilondev_xx_loc(i,j,k)
- ! b_R_xx(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xx(i,j,k,ispec,i_sls) + &
- ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
- ! ! term in yy
- ! b_Sn = factor_loc * b_epsilondev_yy(i,j,k,ispec)
- ! b_Snp1 = factor_loc * b_epsilondev_yy_loc(i,j,k)
- ! b_R_yy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yy(i,j,k,ispec,i_sls) + &
- ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
- ! ! term in zz not computed since zero trace
- ! ! term in xy
- ! b_Sn = factor_loc * b_epsilondev_xy(i,j,k,ispec)
- ! b_Snp1 = factor_loc * b_epsilondev_xy_loc(i,j,k)
- ! b_R_xy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xy(i,j,k,ispec,i_sls) + &
- ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
- ! ! term in xz
- ! b_Sn = factor_loc * b_epsilondev_xz(i,j,k,ispec)
- ! b_Snp1 = factor_loc * b_epsilondev_xz_loc(i,j,k)
- ! b_R_xz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xz(i,j,k,ispec,i_sls) + &
- ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
- ! ! term in yz
- ! b_Sn = factor_loc * b_epsilondev_yz(i,j,k,ispec)
- ! b_Snp1 = factor_loc * b_epsilondev_yz_loc(i,j,k)
- ! b_R_yz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yz(i,j,k,ispec,i_sls) + &
- ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
- !endif
-
- enddo ! end of loop on memory variables
-
- endif ! end attenuation
-
- enddo
- enddo
- enddo
-
- ! save deviatoric strain for Runge-Kutta scheme
- if(ATTENUATION) then
- epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:)
- epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:)
- epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:)
- epsilondev_xz(:,:,:,ispec) = epsilondev_xz_loc(:,:,:)
- epsilondev_yz(:,:,:,ispec) = epsilondev_yz_loc(:,:,:)
- !if (SIMULATION_TYPE == 3) then
- ! b_epsilondev_xx(:,:,:,ispec) = b_epsilondev_xx_loc(:,:,:)
- ! b_epsilondev_yy(:,:,:,ispec) = b_epsilondev_yy_loc(:,:,:)
- ! b_epsilondev_xy(:,:,:,ispec) = b_epsilondev_xy_loc(:,:,:)
- ! b_epsilondev_xz(:,:,:,ispec) = b_epsilondev_xz_loc(:,:,:)
- ! b_epsilondev_yz(:,:,:,ispec) = b_epsilondev_yz_loc(:,:,:)
- !endif
- endif
-
- endif ! ispec_is_elastic
-
- endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
-
- enddo ! spectral element loop
-
-end subroutine compute_forces_with_Deville
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-!subroutine compute_forces_with_Deville_noanisotropy( phase_is_inner ,NSPEC_AB,NGLOB_AB, &
-! displ,accel, &
-! xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
-! hprime_xx,hprime_xxT, &
-! hprimewgll_xx,hprimewgll_xxT, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
-! kappastore,mustore,jacobian,ibool, &
-! ispec_is_inner, &
-! ATTENUATION,USE_OLSEN_ATTENUATION, &
-! one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,&
-! NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
-! epsilondev_xx,epsilondev_yy,epsilondev_xy, &
-! epsilondev_xz,epsilondev_yz,iflag_attenuation_store, &
-! rho_vs )
-!
-!! computes elastic tensor term
-!
-! implicit none
-!
-! include "constants.h"
-!! include values created by the mesher
-!! include "OUTPUT_FILES/values_from_mesher.h"
-!
-! integer :: NSPEC_AB,NGLOB_AB
-!
-!! displacement and acceleration
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ,accel
-!
-!! arrays with mesh parameters per slice
-! integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
-! xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
-! kappastore,mustore,jacobian
-!
-!! array with derivatives of Lagrange polynomials and precalculated products
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
-! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-!
-!! communication overlap
-! logical, dimension(NSPEC_AB) :: ispec_is_inner
-! logical :: phase_is_inner
-!
-!! memory variables and standard linear solids for attenuation
-! logical :: ATTENUATION,USE_OLSEN_ATTENUATION
-! integer :: NSPEC_ATTENUATION_AB
-! integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
-! real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
-! real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
-! R_xx,R_yy,R_xy,R_xz,R_yz
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
-! epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
-!
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vs
-!
-!! local parameters
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
-! newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
-!
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
-! tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
-!
-!! manually inline the calls to the Deville et al. (2002) routines
-! real(kind=4), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
-! real(kind=4), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
-! real(kind=4), dimension(m1,m2) :: E1_m1_m2_5points,E2_m1_m2_5points,E3_m1_m2_5points
-!
-! equivalence(dummyx_loc,B1_m1_m2_5points)
-! equivalence(dummyy_loc,B2_m1_m2_5points)
-! equivalence(dummyz_loc,B3_m1_m2_5points)
-! equivalence(tempx1,C1_m1_m2_5points)
-! equivalence(tempy1,C2_m1_m2_5points)
-! equivalence(tempz1,C3_m1_m2_5points)
-! equivalence(newtempx1,E1_m1_m2_5points)
-! equivalence(newtempy1,E2_m1_m2_5points)
-! equivalence(newtempz1,E3_m1_m2_5points)
-!
-! real(kind=4), dimension(m2,NGLLX) :: A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
-! real(kind=4), dimension(m2,m1) :: C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
-! real(kind=4), dimension(m2,m1) :: E1_mxm_m2_m1_5points,E2_mxm_m2_m1_5points,E3_mxm_m2_m1_5points
-!
-! equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
-! equivalence(dummyy_loc,A2_mxm_m2_m1_5points)
-! equivalence(dummyz_loc,A3_mxm_m2_m1_5points)
-! equivalence(tempx3,C1_mxm_m2_m1_5points)
-! equivalence(tempy3,C2_mxm_m2_m1_5points)
-! equivalence(tempz3,C3_mxm_m2_m1_5points)
-! equivalence(newtempx3,E1_mxm_m2_m1_5points)
-! equivalence(newtempy3,E2_mxm_m2_m1_5points)
-! equivalence(newtempz3,E3_mxm_m2_m1_5points)
-!
-!! local attenuation parameters
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xx_loc, &
-! epsilondev_yy_loc, epsilondev_xy_loc, epsilondev_xz_loc, epsilondev_yz_loc
-! real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
-! real(kind=CUSTOM_REAL) factor_loc,alphaval_loc,betaval_loc,gammaval_loc,Sn,Snp1
-! real(kind=CUSTOM_REAL) epsilon_trace_over_3
-! real(kind=CUSTOM_REAL) vs_val
-!
-! real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
-! real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
-!
-! real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
-! real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
-!
-! real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
-!
-! real(kind=CUSTOM_REAL) fac1,fac2,fac3
-!
-! real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
-! real(kind=CUSTOM_REAL) kappal
-!
-! integer i_SLS,iselected
-!
-! integer ispec,iglob
-! integer i,j,k
-!
-!! loops over all elements
-! do ispec = 1,NSPEC_AB
-!
-! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-!
-! do k=1,NGLLZ
-! do j=1,NGLLY
-! do i=1,NGLLX
-! iglob = ibool(i,j,k,ispec)
-! dummyx_loc(i,j,k) = displ(1,iglob)
-! dummyy_loc(i,j,k) = displ(2,iglob)
-! dummyz_loc(i,j,k) = displ(3,iglob)
-! enddo
-! enddo
-! enddo
-!
-! ! subroutines adapted from Deville, Fischer and Mund, High-order methods
-! ! for incompressible fluid flow, Cambridge University Press (2002),
-! ! pages 386 and 389 and Figure 8.3.1
-! ! call mxm_m1_m2_5points(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
-! do j=1,m2
-! do i=1,m1
-! C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
-! hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
-! hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
-! hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
-! hprime_xx(i,5)*B1_m1_m2_5points(5,j)
-!
-! C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
-! hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
-! hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
-! hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
-! hprime_xx(i,5)*B2_m1_m2_5points(5,j)
-!
-! C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
-! hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
-! hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
-! hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
-! hprime_xx(i,5)*B3_m1_m2_5points(5,j)
-! enddo
-! enddo
-!
-! ! call mxm_m1_m1_5points(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k), &
-! ! hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
-! do j=1,m1
-! do i=1,m1
-! ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
-! do k = 1,NGLLX
-! tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
-! dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
-! dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
-! dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
-! dummyx_loc(i,5,k)*hprime_xxT(5,j)
-!
-! tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
-! dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
-! dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
-! dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
-! dummyy_loc(i,5,k)*hprime_xxT(5,j)
-!
-! tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
-! dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
-! dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
-! dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
-! dummyz_loc(i,5,k)*hprime_xxT(5,j)
-! enddo
-! enddo
-! enddo
-!
-! ! call mxm_m2_m1_5points(dummyx_loc,dummyy_loc,dummyz_loc,tempx3,tempy3,tempz3)
-! do j=1,m1
-! do i=1,m2
-! C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
-! A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
-! A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
-! A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
-! A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
-!
-! C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
-! A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
-! A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
-! A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
-! A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
-!
-! C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
-! A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
-! A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
-! A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
-! A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
-! enddo
-! enddo
-!
-! do k=1,NGLLZ
-! do j=1,NGLLY
-! do i=1,NGLLX
-!
-! ! get derivatives of ux, uy and uz with respect to x, y and z
-! xixl = xix(i,j,k,ispec)
-! xiyl = xiy(i,j,k,ispec)
-! xizl = xiz(i,j,k,ispec)
-! etaxl = etax(i,j,k,ispec)
-! etayl = etay(i,j,k,ispec)
-! etazl = etaz(i,j,k,ispec)
-! gammaxl = gammax(i,j,k,ispec)
-! gammayl = gammay(i,j,k,ispec)
-! gammazl = gammaz(i,j,k,ispec)
-! jacobianl = jacobian(i,j,k,ispec)
-!
-! duxdxl = xixl*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
-! duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
-! duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
-!
-! duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
-! duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
-! duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
-!
-! duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
-! duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
-! duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
-!
-!! precompute some sums to save CPU time
-! duxdxl_plus_duydyl = duxdxl + duydyl
-! duxdxl_plus_duzdzl = duxdxl + duzdzl
-! duydyl_plus_duzdzl = duydyl + duzdzl
-! duxdyl_plus_duydxl = duxdyl + duydxl
-! duzdxl_plus_duxdzl = duzdxl + duxdzl
-! duzdyl_plus_duydzl = duzdyl + duydzl
-!
-! kappal = kappastore(i,j,k,ispec)
-! mul = mustore(i,j,k,ispec)
-!
-!! attenuation
-! if(ATTENUATION) then
-! ! compute deviatoric strain
-! epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl)
-! epsilondev_xx_loc(i,j,k) = duxdxl - epsilon_trace_over_3
-! epsilondev_yy_loc(i,j,k) = duydyl - epsilon_trace_over_3
-! epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl
-! epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl
-! epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl
-!
-! !if (SIMULATION_TYPE == 3) then
-! ! b_epsilon_trace_over_3 = ONE_THIRD * (b_duxdxl + b_duydyl + b_duzdzl)
-! ! b_epsilondev_xx_loc(i,j,k) = b_duxdxl - b_epsilon_trace_over_3
-! ! b_epsilondev_yy_loc(i,j,k) = b_duydyl - b_epsilon_trace_over_3
-! ! b_epsilondev_xy_loc(i,j,k) = 0.5 * b_duxdyl_plus_duydxl
-! ! b_epsilondev_xz_loc(i,j,k) = 0.5 * b_duzdxl_plus_duxdzl
-! ! b_epsilondev_yz_loc(i,j,k) = 0.5 * b_duzdyl_plus_duydzl
-! !endif
-!
-! ! uses scaling rule similar to Olsen et al. (2003) or mesh flag
-! if(USE_OLSEN_ATTENUATION) then
-! vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
-! call get_attenuation_model_olsen( vs_val, iselected )
-! else
-! ! iflag from (CUBIT) mesh
-! iselected = iflag_attenuation_store(i,j,k,ispec)
-! endif
-!
-! ! use unrelaxed parameters if attenuation
-! mul = mul * one_minus_sum_beta(iselected)
-!
-! endif
-!
-!! isotropic case
-! lambdalplus2mul = kappal + FOUR_THIRDS * mul
-! lambdal = lambdalplus2mul - 2.*mul
-!
-! ! compute stress sigma
-! sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
-! sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
-! sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
-!
-! sigma_xy = mul*duxdyl_plus_duydxl
-! sigma_xz = mul*duzdxl_plus_duxdzl
-! sigma_yz = mul*duzdyl_plus_duydzl
-!
-! !if (SIMULATION_TYPE == 3) then
-! ! b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
-! ! b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
-! ! b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
-! !
-! ! b_sigma_xy = mul*b_duxdyl_plus_duydxl
-! ! b_sigma_xz = mul*b_duzdxl_plus_duxdzl
-! ! b_sigma_yz = mul*b_duzdyl_plus_duydzl
-! !endif
-!
-! ! subtract memory variables if attenuation
-! if(ATTENUATION) then
-! do i_sls = 1,N_SLS
-! R_xx_val = R_xx(i,j,k,ispec,i_sls)
-! R_yy_val = R_yy(i,j,k,ispec,i_sls)
-! sigma_xx = sigma_xx - R_xx_val
-! sigma_yy = sigma_yy - R_yy_val
-! sigma_zz = sigma_zz + R_xx_val + R_yy_val
-! sigma_xy = sigma_xy - R_xy(i,j,k,ispec,i_sls)
-! sigma_xz = sigma_xz - R_xz(i,j,k,ispec,i_sls)
-! sigma_yz = sigma_yz - R_yz(i,j,k,ispec,i_sls)
-! enddo
-!
-! !if (SIMULATION_TYPE == 3) then
-! ! b_R_xx_val = b_R_xx(i,j,k,ispec,i_sls)
-! ! b_R_yy_val = b_R_yy(i,j,k,ispec,i_sls)
-! ! b_sigma_xx = b_sigma_xx - b_R_xx_val
-! ! b_sigma_yy = b_sigma_yy - b_R_yy_val
-! ! b_sigma_zz = b_sigma_zz + b_R_xx_val + b_R_yy_val
-! ! b_sigma_xy = b_sigma_xy - b_R_xy(i,j,k,ispec,i_sls)
-! ! b_sigma_xz = b_sigma_xz - b_R_xz(i,j,k,ispec,i_sls)
-! ! b_sigma_yz = b_sigma_yz - b_R_yz(i,j,k,ispec,i_sls)
-! !endif
-! endif
-!
-! ! form dot product with test vector, symmetric form
-! tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
-! tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
-! tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-!
-! tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
-! tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
-! tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-!
-! tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
-! tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
-! tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
-!
-! enddo
-! enddo
-! enddo
-!
-! ! subroutines adapted from Deville, Fischer and Mund, High-order methods
-! ! for incompressible fluid flow, Cambridge University Press (2002),
-! ! pages 386 and 389 and Figure 8.3.1
-! ! call mxm_m1_m2_5points(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
-! do j=1,m2
-! do i=1,m1
-! E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
-! hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
-! hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
-! hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
-! hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
-!
-! E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
-! hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
-! hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
-! hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
-! hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
-!
-! E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
-! hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
-! hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
-! hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
-! hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
-! enddo
-! enddo
-!
-! ! call mxm_m1_m1_5points(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k), &
-! ! hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
-! do i=1,m1
-! do j=1,m1
-! ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
-! do k = 1,NGLLX
-! newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
-! tempx2(i,2,k)*hprimewgll_xx(2,j) + &
-! tempx2(i,3,k)*hprimewgll_xx(3,j) + &
-! tempx2(i,4,k)*hprimewgll_xx(4,j) + &
-! tempx2(i,5,k)*hprimewgll_xx(5,j)
-!
-! newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
-! tempy2(i,2,k)*hprimewgll_xx(2,j) + &
-! tempy2(i,3,k)*hprimewgll_xx(3,j) + &
-! tempy2(i,4,k)*hprimewgll_xx(4,j) + &
-! tempy2(i,5,k)*hprimewgll_xx(5,j)
-!
-! newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
-! tempz2(i,2,k)*hprimewgll_xx(2,j) + &
-! tempz2(i,3,k)*hprimewgll_xx(3,j) + &
-! tempz2(i,4,k)*hprimewgll_xx(4,j) + &
-! tempz2(i,5,k)*hprimewgll_xx(5,j)
-! enddo
-! enddo
-! enddo
-!
-! ! call mxm_m2_m1_5points(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
-! do j=1,m1
-! do i=1,m2
-! E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
-! C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
-! C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
-! C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
-! C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
-!
-! E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
-! C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
-! C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
-! C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
-! C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
-!
-! E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
-! C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
-! C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
-! C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
-! C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
-! enddo
-! enddo
-!
-! do k=1,NGLLZ
-! do j=1,NGLLY
-! do i=1,NGLLX
-!
-! fac1 = wgllwgll_yz(j,k)
-! fac2 = wgllwgll_xz(i,k)
-! fac3 = wgllwgll_xy(i,j)
-!
-! ! sum contributions from each element to the global mesh using indirect addressing
-! iglob = ibool(i,j,k,ispec)
-! accel(1,iglob) = accel(1,iglob) - fac1*newtempx1(i,j,k) - &
-! fac2*newtempx2(i,j,k) - fac3*newtempx3(i,j,k)
-! accel(2,iglob) = accel(2,iglob) - fac1*newtempy1(i,j,k) - &
-! fac2*newtempy2(i,j,k) - fac3*newtempy3(i,j,k)
-! accel(3,iglob) = accel(3,iglob) - fac1*newtempz1(i,j,k) - &
-! fac2*newtempz2(i,j,k) - fac3*newtempz3(i,j,k)
-!
-! ! update memory variables based upon the Runge-Kutta scheme
-! if(ATTENUATION) then
-!
-! ! use Runge-Kutta scheme to march in time
-! do i_sls = 1,N_SLS
-!
-! ! get coefficients for that standard linear solid
-! if( USE_OLSEN_ATTENUATION ) then
-! vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
-! call get_attenuation_model_olsen( vs_val, iselected )
-! else
-! iselected = iflag_attenuation_store(i,j,k,ispec)
-! endif
-!
-! factor_loc = mustore(i,j,k,ispec) * factor_common(iselected,i_sls)
-! alphaval_loc = alphaval(iselected,i_sls)
-! betaval_loc = betaval(iselected,i_sls)
-! gammaval_loc = gammaval(iselected,i_sls)
-!
-! ! term in xx
-! Sn = factor_loc * epsilondev_xx(i,j,k,ispec)
-! Snp1 = factor_loc * epsilondev_xx_loc(i,j,k)
-! R_xx(i,j,k,ispec,i_sls) = alphaval_loc * R_xx(i,j,k,ispec,i_sls) + &
-! betaval_loc * Sn + gammaval_loc * Snp1
-!
-! ! term in yy
-! Sn = factor_loc * epsilondev_yy(i,j,k,ispec)
-! Snp1 = factor_loc * epsilondev_yy_loc(i,j,k)
-! R_yy(i,j,k,ispec,i_sls) = alphaval_loc * R_yy(i,j,k,ispec,i_sls) + &
-! betaval_loc * Sn + gammaval_loc * Snp1
-!
-! ! term in zz not computed since zero trace
-!
-! ! term in xy
-! Sn = factor_loc * epsilondev_xy(i,j,k,ispec)
-! Snp1 = factor_loc * epsilondev_xy_loc(i,j,k)
-! R_xy(i,j,k,ispec,i_sls) = alphaval_loc * R_xy(i,j,k,ispec,i_sls) + &
-! betaval_loc * Sn + gammaval_loc * Snp1
-!
-! ! term in xz
-! Sn = factor_loc * epsilondev_xz(i,j,k,ispec)
-! Snp1 = factor_loc * epsilondev_xz_loc(i,j,k)
-! R_xz(i,j,k,ispec,i_sls) = alphaval_loc * R_xz(i,j,k,ispec,i_sls) + &
-! betaval_loc * Sn + gammaval_loc * Snp1
-!
-! ! term in yz
-! Sn = factor_loc * epsilondev_yz(i,j,k,ispec)
-! Snp1 = factor_loc * epsilondev_yz_loc(i,j,k)
-! R_yz(i,j,k,ispec,i_sls) = alphaval_loc * R_yz(i,j,k,ispec,i_sls) + &
-! betaval_loc * Sn + gammaval_loc * Snp1
-!
-! !if (SIMULATION_TYPE == 3) then
-! ! b_alphaval_loc = b_alphaval(iselected,i_sls)
-! ! b_betaval_loc = b_betaval(iselected,i_sls)
-! ! b_gammaval_loc = b_gammaval(iselected,i_sls)
-! ! ! term in xx
-! ! b_Sn = factor_loc * b_epsilondev_xx(i,j,k,ispec)
-! ! b_Snp1 = factor_loc * b_epsilondev_xx_loc(i,j,k)
-! ! b_R_xx(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xx(i,j,k,ispec,i_sls) + &
-! ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
-! ! ! term in yy
-! ! b_Sn = factor_loc * b_epsilondev_yy(i,j,k,ispec)
-! ! b_Snp1 = factor_loc * b_epsilondev_yy_loc(i,j,k)
-! ! b_R_yy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yy(i,j,k,ispec,i_sls) + &
-! ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
-! ! ! term in zz not computed since zero trace
-! ! ! term in xy
-! ! b_Sn = factor_loc * b_epsilondev_xy(i,j,k,ispec)
-! ! b_Snp1 = factor_loc * b_epsilondev_xy_loc(i,j,k)
-! ! b_R_xy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xy(i,j,k,ispec,i_sls) + &
-! ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
-! ! ! term in xz
-! ! b_Sn = factor_loc * b_epsilondev_xz(i,j,k,ispec)
-! ! b_Snp1 = factor_loc * b_epsilondev_xz_loc(i,j,k)
-! ! b_R_xz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xz(i,j,k,ispec,i_sls) + &
-! ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
-! ! ! term in yz
-! ! b_Sn = factor_loc * b_epsilondev_yz(i,j,k,ispec)
-! ! b_Snp1 = factor_loc * b_epsilondev_yz_loc(i,j,k)
-! ! b_R_yz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yz(i,j,k,ispec,i_sls) + &
-! ! b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
-! !endif
-!
-! enddo ! end of loop on memory variables
-!
-! endif ! end attenuation
-!
-! enddo
-! enddo
-! enddo
-!
-! ! save deviatoric strain for Runge-Kutta scheme
-! if(ATTENUATION) then
-! epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:)
-! epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:)
-! epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:)
-! epsilondev_xz(:,:,:,ispec) = epsilondev_xz_loc(:,:,:)
-! epsilondev_yz(:,:,:,ispec) = epsilondev_yz_loc(:,:,:)
-! !if (SIMULATION_TYPE == 3) then
-! ! b_epsilondev_xx(:,:,:,ispec) = b_epsilondev_xx_loc(:,:,:)
-! ! b_epsilondev_yy(:,:,:,ispec) = b_epsilondev_yy_loc(:,:,:)
-! ! b_epsilondev_xy(:,:,:,ispec) = b_epsilondev_xy_loc(:,:,:)
-! ! b_epsilondev_xz(:,:,:,ispec) = b_epsilondev_xz_loc(:,:,:)
-! ! b_epsilondev_yz(:,:,:,ispec) = b_epsilondev_yz_loc(:,:,:)
-! !endif
-! endif
-!
-! endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
-!
-! enddo ! spectral element loop
-!
-!end subroutine compute_forces_with_Deville_noanisotropy
-
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!! subroutines adapted from Deville, Fischer and Mund, High-order methods
-!! for incompressible fluid flow, Cambridge University Press (2002),
-!! pages 386 and 389 and Figure 8.3.1
-!
-! subroutine old_mxm_m1_m2_5points(A,B1,B2,B3,C1,C2,C3)
-!
-! implicit none
-!
-! include "constants.h"
-!
-! real(kind=4), dimension(m1,NGLLX) :: A
-! real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
-! real(kind=4), dimension(m1,m2) :: C1,C2,C3
-!
-! integer :: i,j
-!
-! do j=1,m2
-! do i=1,m1
-!
-! C1(i,j) = A(i,1)*B1(1,j) + &
-! A(i,2)*B1(2,j) + &
-! A(i,3)*B1(3,j) + &
-! A(i,4)*B1(4,j) + &
-! A(i,5)*B1(5,j)
-!
-! C2(i,j) = A(i,1)*B2(1,j) + &
-! A(i,2)*B2(2,j) + &
-! A(i,3)*B2(3,j) + &
-! A(i,4)*B2(4,j) + &
-! A(i,5)*B2(5,j)
-!
-! C3(i,j) = A(i,1)*B3(1,j) + &
-! A(i,2)*B3(2,j) + &
-! A(i,3)*B3(3,j) + &
-! A(i,4)*B3(4,j) + &
-! A(i,5)*B3(5,j)
-!
-! enddo
-! enddo
-!
-! end subroutine old_mxm_m1_m2_5points
-!
-!!---------
-!
-! subroutine old_mxm_m1_m1_5points(A1,A2,A3,B,C1,C2,C3)
-!
-! implicit none
-!
-! include "constants.h"
-!
-! real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
-! real(kind=4), dimension(NGLLX,m1) :: B
-! real(kind=4), dimension(m1,m1) :: C1,C2,C3
-!
-! integer :: i,j
-!
-! do j=1,m1
-! do i=1,m1
-!
-! C1(i,j) = A1(i,1)*B(1,j) + &
-! A1(i,2)*B(2,j) + &
-! A1(i,3)*B(3,j) + &
-! A1(i,4)*B(4,j) + &
-! A1(i,5)*B(5,j)
-!
-! C2(i,j) = A2(i,1)*B(1,j) + &
-! A2(i,2)*B(2,j) + &
-! A2(i,3)*B(3,j) + &
-! A2(i,4)*B(4,j) + &
-! A2(i,5)*B(5,j)
-!
-! C3(i,j) = A3(i,1)*B(1,j) + &
-! A3(i,2)*B(2,j) + &
-! A3(i,3)*B(3,j) + &
-! A3(i,4)*B(4,j) + &
-! A3(i,5)*B(5,j)
-!
-! enddo
-! enddo
-!
-! end subroutine old_mxm_m1_m1_5points
-!
-!!---------
-!
-! subroutine old_mxm_m2_m1_5points(A1,A2,A3,B,C1,C2,C3)
-!
-! implicit none
-!
-! include "constants.h"
-!
-! real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
-! real(kind=4), dimension(NGLLX,m1) :: B
-! real(kind=4), dimension(m2,m1) :: C1,C2,C3
-!
-! integer :: i,j
-!
-! do j=1,m1
-! do i=1,m2
-!
-! C1(i,j) = A1(i,1)*B(1,j) + &
-! A1(i,2)*B(2,j) + &
-! A1(i,3)*B(3,j) + &
-! A1(i,4)*B(4,j) + &
-! A1(i,5)*B(5,j)
-!
-! C2(i,j) = A2(i,1)*B(1,j) + &
-! A2(i,2)*B(2,j) + &
-! A2(i,3)*B(3,j) + &
-! A2(i,4)*B(4,j) + &
-! A2(i,5)*B(5,j)
-!
-! C3(i,j) = A3(i,1)*B(1,j) + &
-! A3(i,2)*B(2,j) + &
-! A3(i,3)*B(3,j) + &
-! A3(i,4)*B(4,j) + &
-! A3(i,5)*B(5,j)
-!
-! enddo
-! enddo
-!
-! end subroutine old_mxm_m2_m1_5points
-!
-
-
-!subroutine compute_forces_with_Deville(phase_is_inner,NSPEC_AB,NGLOB_AB,&
-! ATTENUATION,USE_OLSEN_ATTENUATION,displ,accel, &
-! xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
-! hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
-! kappastore,mustore,jacobian,ibool,ispec_is_inner, &
-! NSOURCES,myrank,it,islice_selected_source,ispec_selected_source, &
-! xi_source,eta_source,gamma_source,nu_source, &
-! hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
-! one_minus_sum_beta,factor_common,alphaval,betaval,gammaval, &
-! NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
-! epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store, &
-! ABSORBING_CONDITIONS, &
-! abs_boundary_normal,abs_boundary_jacobian2Dw, &
-! abs_boundary_ijk,abs_boundary_ispec, &
-! num_abs_boundary_faces, &
-! veloc,rho_vp,rho_vs)
-!
-! implicit none
-!
-! include "constants.h"
-!! include values created by the mesher
-!! include "OUTPUT_FILES/values_from_mesher.h"
-!
-! integer :: NSPEC_AB,NGLOB_AB
-!
-!! displacement and acceleration
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ,accel
-!
-!! arrays with mesh parameters per slice
-! integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
-! xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
-! kappastore,mustore,jacobian
-!
-!! array with derivatives of Lagrange polynomials and precalculated products
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
-! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-!
-!! communication overlap
-! logical, dimension(NSPEC_AB) :: ispec_is_inner
-! logical :: phase_is_inner
-!
-!! source
-! integer :: NSOURCES,myrank,it
-! integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
-! double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
-! double precision, dimension(3,3,NSOURCES) :: nu_source
-! double precision, dimension(NSOURCES) :: hdur,hdur_gaussian,t_cmt
-! double precision :: dt
-! real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
-!
-!! integer :: isource
-! double precision :: t0
-! double precision :: stf
-!
-!! memory variables and standard linear solids for attenuation
-! logical :: ATTENUATION,USE_OLSEN_ATTENUATION
-! integer :: NSPEC_ATTENUATION_AB
-! integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
-! real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
-! real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
-! R_xx,R_yy,R_xy,R_xz,R_yz
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
-! epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
-!
-!! Stacey conditions
-! logical :: ABSORBING_CONDITIONS
-!! integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,nspec2D_top
-!! integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
-!! integer, dimension(nspec2D_xmin) :: ibelm_xmin
-!! integer, dimension(nspec2D_xmax) :: ibelm_xmax
-!! integer, dimension(nspec2D_ymin) :: ibelm_ymin
-!! integer, dimension(nspec2D_ymax) :: ibelm_ymax
-!! integer, dimension(nspec2D_bottom) :: ibelm_bottom
-!! integer, dimension(nspec2D_top) :: ibelm_top
-!! integer :: ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin),ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax), &
-!! ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin),ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax), &
-!! ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom),ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top)
-!! integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_ext) :: nimin,nimax,nkmin_eta
-!! integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_ext) :: njmin,njmax,nkmin_xi
-!
-!
-!
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
-!
-!! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmin) :: jacobian2D_xmin
-!! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmax) :: jacobian2D_xmax
-!! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymin) :: jacobian2D_ymin
-!! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymax) :: jacobian2D_ymax
-!! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
-!! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_top) :: jacobian2D_top
-!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmin) :: normal_xmin
-!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmax) :: normal_xmax
-!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymin) :: normal_ymin
-!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymax) :: normal_ymax
-!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM) :: normal_bottom
-!! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_top) :: normal_top
-!
-! integer :: num_abs_boundary_faces
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLSQUARE,num_abs_boundary_faces) :: abs_boundary_normal
-! real(kind=CUSTOM_REAL), dimension(NGLLSQUARE,num_abs_boundary_faces) :: abs_boundary_jacobian2Dw
-! integer, dimension(3,NGLLSQUARE,num_abs_boundary_faces) :: abs_boundary_ijk
-! integer, dimension(num_abs_boundary_faces) :: abs_boundary_ispec
-!
-!
-!! computes elastic stiffness term
-! call compute_forces_add_elastic_term(NSPEC_AB,NGLOB_AB,&
-! ATTENUATION,USE_OLSEN_ATTENUATION,displ,accel, &
-! xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
-! hprime_xx,hprime_xxT,&
-! hprimewgll_xx,hprimewgll_xxT,&
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
-! kappastore,mustore,jacobian,ibool,ispec_is_inner,phase_is_inner, &
-! one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,&
-! NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
-! epsilondev_xx,epsilondev_yy,epsilondev_xy,&
-! epsilondev_xz,epsilondev_yz,iflag_attenuation_store,&
-! rho_vs )
-!
-!
-!end subroutine compute_forces_with_Deville
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -110,4 +110,6 @@
enddo
enddo
-end subroutine compute_gradient
\ No newline at end of file
+end subroutine compute_gradient
+
+
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_interpolated_dva.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_interpolated_dva.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_interpolated_dva.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,211 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+subroutine compute_interpolated_dva(displ,veloc,accel,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_r,eta_r,gamma_r, &
+ hxir,hetar,hgammar, &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+
+! returns displacement/velocity/acceleration (dxd,..,vxd,..,axd,.. ) at receiver location
+
+ implicit none
+ include 'constants.h'
+
+ double precision,intent(out) :: dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
+
+ integer :: ispec
+
+ integer :: NSPEC_AB,NGLOB_AB
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_AB) :: displ,veloc,accel
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB):: ibool
+
+ ! receiver information
+ double precision :: xi_r,eta_r,gamma_r
+ double precision,dimension(NGLLX) :: hxir
+ double precision,dimension(NGLLY) :: hetar
+ double precision,dimension(NGLLZ) :: hgammar
+
+! local parameters
+ double precision :: hlagrange
+ integer :: i,j,k,iglob
+
+! perform the general interpolation using Lagrange polynomials
+ dxd = ZERO
+ dyd = ZERO
+ dzd = ZERO
+ vxd = ZERO
+ vyd = ZERO
+ vzd = ZERO
+ axd = ZERO
+ ayd = ZERO
+ azd = ZERO
+
+! takes closest GLL point only (no interpolation)
+ if(FASTER_RECEIVERS_POINTS_ONLY) then
+
+ iglob = ibool(nint(xi_r),nint(eta_r),nint(gamma_r),ispec)
+
+ ! displacement
+ dxd = dble(displ(1,iglob))
+ dyd = dble(displ(2,iglob))
+ dzd = dble(displ(3,iglob))
+ ! velocity
+ vxd = dble(veloc(1,iglob))
+ vyd = dble(veloc(2,iglob))
+ vzd = dble(veloc(3,iglob))
+ ! acceleration
+ axd = dble(accel(1,iglob))
+ ayd = dble(accel(2,iglob))
+ azd = dble(accel(3,iglob))
+
+ else
+
+! interpolates seismograms at exact receiver locations
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ hlagrange = hxir(i)*hetar(j)*hgammar(k)
+
+ ! displacement
+ dxd = dxd + dble(displ(1,iglob))*hlagrange
+ dyd = dyd + dble(displ(2,iglob))*hlagrange
+ dzd = dzd + dble(displ(3,iglob))*hlagrange
+ ! velocity
+ vxd = vxd + dble(veloc(1,iglob))*hlagrange
+ vyd = vyd + dble(veloc(2,iglob))*hlagrange
+ vzd = vzd + dble(veloc(3,iglob))*hlagrange
+ ! acceleration
+ axd = axd + dble(accel(1,iglob))*hlagrange
+ ayd = ayd + dble(accel(2,iglob))*hlagrange
+ azd = azd + dble(accel(3,iglob))*hlagrange
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+end subroutine compute_interpolated_dva
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_interpolated_dva_ac(displ_element,veloc_element,&
+ potential_dot_dot_acoustic,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_r,eta_r,gamma_r, &
+ hxir,hetar,hgammar, &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+
+! acoustic elements
+! returns displacement/velocity/acceleration (dxd,..,vxd,..,axd,.. ) at receiver location
+
+ implicit none
+ include 'constants.h'
+
+ double precision,intent(out) :: dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
+
+ integer :: ispec
+
+ integer :: NSPEC_AB,NGLOB_AB
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: displ_element,veloc_element
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB):: ibool
+
+ ! receiver information
+ double precision :: xi_r,eta_r,gamma_r
+ double precision,dimension(NGLLX) :: hxir
+ double precision,dimension(NGLLY) :: hetar
+ double precision,dimension(NGLLZ) :: hgammar
+
+! local parameters
+ double precision :: hlagrange
+ integer :: i,j,k,iglob
+
+! perform the general interpolation using Lagrange polynomials
+ dxd = ZERO
+ dyd = ZERO
+ dzd = ZERO
+ vxd = ZERO
+ vyd = ZERO
+ vzd = ZERO
+ axd = ZERO
+ ayd = ZERO
+ azd = ZERO
+
+! takes closest GLL point only (no interpolation)
+ if(FASTER_RECEIVERS_POINTS_ONLY) then
+
+ ! displacement
+ dxd = displ_element(1,nint(xi_r),nint(eta_r),nint(gamma_r))
+ dyd = displ_element(2,nint(xi_r),nint(eta_r),nint(gamma_r))
+ dzd = displ_element(3,nint(xi_r),nint(eta_r),nint(gamma_r))
+ ! velocity
+ vxd = veloc_element(1,nint(xi_r),nint(eta_r),nint(gamma_r))
+ vyd = veloc_element(2,nint(xi_r),nint(eta_r),nint(gamma_r))
+ vzd = veloc_element(3,nint(xi_r),nint(eta_r),nint(gamma_r))
+
+ ! pressure
+ iglob = ibool(nint(xi_r),nint(eta_r),nint(gamma_r),ispec)
+ axd = - potential_dot_dot_acoustic(iglob)
+ ayd = - potential_dot_dot_acoustic(iglob)
+ azd = - potential_dot_dot_acoustic(iglob)
+
+ else
+
+! interpolates seismograms at exact receiver locations
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ hlagrange = hxir(i)*hetar(j)*hgammar(k)
+
+ ! displacement
+ dxd = dxd + hlagrange*displ_element(1,i,j,k)
+ dyd = dyd + hlagrange*displ_element(2,i,j,k)
+ dzd = dzd + hlagrange*displ_element(3,i,j,k)
+ ! velocity
+ vxd = vxd + hlagrange*veloc_element(1,i,j,k)
+ vyd = vxd + hlagrange*veloc_element(2,i,j,k)
+ vzd = vxd + hlagrange*veloc_element(3,i,j,k)
+ ! pressure
+ axd = axd - hlagrange*potential_dot_dot_acoustic(iglob)
+ ayd = ayd - hlagrange*potential_dot_dot_acoustic(iglob)
+ azd = azd - hlagrange*potential_dot_dot_acoustic(iglob)
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+end subroutine compute_interpolated_dva_ac
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_stacey_acoustic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_stacey_acoustic.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_stacey_acoustic.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,132 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! for acoustic solver
+
+ subroutine compute_stacey_acoustic(NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic,potential_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces,rhostore,kappastore,ispec_is_acoustic,&
+ SIMULATION_TYPE,SAVE_FORWARD,NSTEP,it,myrank,NGLOB_ADJOINT, &
+ b_potential_dot_dot_acoustic,b_reclen_potential, &
+ b_absorb_potential,b_num_abs_boundary_faces)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic,&
+ potential_dot_acoustic
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rhostore,kappastore
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+! absorbing boundary surface
+ integer :: num_abs_boundary_faces
+ real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ispec(num_abs_boundary_faces)
+
+! adjoint simulations
+ integer:: SIMULATION_TYPE
+ integer:: NSTEP,it,myrank,NGLOB_ADJOINT
+ integer:: b_num_abs_boundary_faces,b_reclen_potential
+ real(kind=CUSTOM_REAL),dimension(NGLOB_ADJOINT) :: b_potential_dot_dot_acoustic
+ real(kind=CUSTOM_REAL),dimension(NGLLSQUARE,b_num_abs_boundary_faces):: b_absorb_potential
+ logical:: SAVE_FORWARD
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: rhol,cpl,jacobianw
+ integer :: ispec,iglob,i,j,k,iface,igll
+ !adjoint locals
+ integer:: reclen1,reclen2
+
+! adjoint simulations:
+ if (SIMULATION_TYPE == 3 .and. num_abs_boundary_faces > 0) then
+ read(IOABS_AC,rec=NSTEP-it+1) reclen1,b_absorb_potential,reclen2
+ if (reclen1 /= b_reclen_potential .or. reclen1 /= reclen2) &
+ call exit_mpi(myrank,'Error reading absorbing contribution b_absorb_potential')
+ endif !adjoint
+
+! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
+ do iface=1,num_abs_boundary_faces
+
+ ispec = abs_boundary_ispec(iface)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! reference gll points on boundary face
+ do igll = 1,NGLLSQUARE
+
+ ! gets local indices for GLL point
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
+
+ ! gets global index
+ iglob=ibool(i,j,k,ispec)
+
+ ! determines bulk sound speed
+ rhol = rhostore(i,j,k,ispec)
+ cpl = sqrt( kappastore(i,j,k,ispec) / rhol )
+
+ ! gets associated, weighted jacobian
+ jacobianw = abs_boundary_jacobian2Dw(igll,iface)
+
+ ! Sommerfeld condition
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob) * jacobianw / cpl / rhol
+
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
+ - b_absorb_potential(igll,iface)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_potential(igll,iface) = potential_dot_acoustic(iglob) * jacobianw / cpl / rhol
+ endif !adjoint
+
+ enddo
+
+ endif ! ispec_is_acoustic
+ endif ! ispec_is_inner
+ enddo ! num_abs_boundary_faces
+
+ ! adjoint simulations: stores absorbed wavefield part
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. num_abs_boundary_faces > 0 ) &
+ write(IOABS_AC,rec=it) b_reclen_potential,b_absorb_potential,b_reclen_potential
+
+ end subroutine compute_stacey_acoustic
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_stacey_elastic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_stacey_elastic.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_stacey_elastic.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,155 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! for elastic solver
+
+! absorbing boundary term for elastic media (Stacey conditions)
+
+ subroutine compute_stacey_elastic(NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_normal,abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ veloc,rho_vp,rho_vs, &
+ ispec_is_elastic,SIMULATION_TYPE,myrank,SAVE_FORWARD, &
+ NSTEP,it,NGLOB_ADJOINT,b_accel, &
+ b_num_abs_boundary_faces,b_reclen_field,b_absorb_field)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! Stacey conditions
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
+
+ logical, dimension(NSPEC_AB) :: ispec_is_elastic
+
+! absorbing boundary surface
+ integer :: num_abs_boundary_faces
+ real(kind=CUSTOM_REAL) :: abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces)
+ real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ispec(num_abs_boundary_faces)
+
+! adjoint simulations
+ integer:: SIMULATION_TYPE
+ integer:: NSTEP,it,myrank,NGLOB_ADJOINT
+ integer:: b_num_abs_boundary_faces,b_reclen_field
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLSQUARE,b_num_abs_boundary_faces):: b_absorb_field
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_ADJOINT):: b_accel
+ logical:: SAVE_FORWARD
+
+! local parameters
+ real(kind=CUSTOM_REAL) vx,vy,vz,nx,ny,nz,tx,ty,tz,vn,jacobianw
+ integer :: ispec,iglob,i,j,k,iface,igll
+
+ !adjoint locals
+ integer:: reclen1,reclen2
+
+
+! adjoint simulations:
+ if (SIMULATION_TYPE == 3 .and. num_abs_boundary_faces > 0) then
+ read(IOABS,rec=NSTEP-it+1) reclen1,b_absorb_field,reclen2
+ if (reclen1 /= b_reclen_field .or. reclen1 /= reclen2) &
+ call exit_mpi(myrank,'Error reading absorbing contribution b_absorb_field')
+ endif !adjoint
+
+
+! absorbs absorbing-boundary surface using Stacey condition (Clayton & Enquist)
+ do iface=1,num_abs_boundary_faces
+
+ ispec = abs_boundary_ispec(iface)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_elastic(ispec) ) then
+
+ ! reference gll points on boundary face
+ do igll = 1,NGLLSQUARE
+
+ ! gets local indices for GLL point
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
+
+ ! gets velocity
+ iglob=ibool(i,j,k,ispec)
+ vx=veloc(1,iglob)
+ vy=veloc(2,iglob)
+ vz=veloc(3,iglob)
+
+ ! gets associated normal
+ nx = abs_boundary_normal(1,igll,iface)
+ ny = abs_boundary_normal(2,igll,iface)
+ nz = abs_boundary_normal(3,igll,iface)
+
+ ! velocity component in normal direction (normal points out of element)
+ vn = vx*nx + vy*ny + vz*nz
+
+ ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+
+ ! gets associated, weighted jacobian
+ jacobianw = abs_boundary_jacobian2Dw(igll,iface)
+
+ ! adds stacey term (weak form)
+ accel(1,iglob) = accel(1,iglob) - tx*jacobianw
+ accel(2,iglob) = accel(2,iglob) - ty*jacobianw
+ accel(3,iglob) = accel(3,iglob) - tz*jacobianw
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_accel(:,iglob) = b_accel(:,iglob) - b_absorb_field(:,igll,iface)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_field(1,igll,iface) = tx*jacobianw
+ b_absorb_field(2,igll,iface) = ty*jacobianw
+ b_absorb_field(3,igll,iface) = tz*jacobianw
+ endif !adjoint
+
+ enddo
+ endif ! ispec_is_elastic
+ endif ! ispec_is_inner
+ enddo
+
+ ! adjoint simulations: stores absorbed wavefield part
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. num_abs_boundary_faces > 0 ) &
+ write(IOABS,rec=it) b_reclen_field,b_absorb_field,b_reclen_field
+
+ end subroutine compute_stacey_elastic
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in 2010-02-23 02:41:02 UTC (rev 16315)
@@ -71,7 +71,12 @@
! integer, parameter :: IMAIN = ISTANDARD_OUTPUT
! I/O unit for source and receiver vtk file
integer, parameter :: IOVTK = 98
-
+! I/O unit for absorbing boundary snapshots
+ integer, parameter :: IOABS = 31
+ integer, parameter :: IOABS_AC = 32
+! I/O unit for plotting source time function
+ integer, Parameter :: IOSTF = 71
+
! flag to print the details of source location
logical, parameter :: SHOW_DETAILS_LOCATE_SOURCE = .false.
@@ -99,16 +104,17 @@
logical,parameter :: ABSORB_FREE_SURFACE = .false.
! absorb boundaries using a PML region
-! (EXPERIMENTAL feature: only acoustic domains supported...
-! user parameters can be specified in PML_init.f90)
+! (EXPERIMENTAL feature)
+! (only acoustic domains supported...)
+! (user parameters can be specified in PML_init.f90)
logical,parameter :: ABSORB_USE_PML = .false.
! ---------------------------------------------------------------------------------------
! LQY -- Following 3 variables stays here temporarily,
! we need to move them to Par_file at a proper time
! ---------------------------------------------------------------------------------------
-! save moho mesh and compute Moho boundary kernels -- unused
-! logical, parameter :: SAVE_MOHO_MESH = .false.
+! save moho mesh and compute Moho boundary kernels
+ logical, parameter :: SAVE_MOHO_MESH = .false.
! number of steps to save the state variables in the forward simulation,
! to be used in the backward reconstruction in the presence of attenuation
@@ -148,12 +154,14 @@
! plots VTK cross-section planes instead of model surface
! (EXPERIMENTAL feature)
+! (requires EXTERNAL_MESH_MOVIE_SURFACE set to true)
logical, parameter :: PLOT_CROSS_SECTIONS = .false.
real(kind=CUSTOM_REAL),parameter :: CROSS_SECTION_X = 67000.0
real(kind=CUSTOM_REAL),parameter :: CROSS_SECTION_Y = 65500.0
real(kind=CUSTOM_REAL),parameter :: CROSS_SECTION_Z = -30000.0
! plots GIF cross-section image
+! (EXPERIMENTAL feature)
! (cross-section plane parameters can be specified in write_PNM_GIF_data.f90)
logical, parameter :: PNM_GIF_IMAGE = .false.
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -32,7 +32,7 @@
include "constants.h"
- integer NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
+ integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
integer NSOURCES
! parameters to be computed based upon parameters above read from file
@@ -60,15 +60,14 @@
print *,'creating file ', trim(HEADER_FILE), ' to compile solver with correct values'
! read the parameter file
- call read_parameter_file( &
- NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
- UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
- ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
- OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
- MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
- SAVE_AVS_DX_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
- NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
+ call read_parameter_file( NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
+ OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
+ MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
+ SAVE_AVS_DX_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
! create include file for the solver
call save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -47,7 +47,7 @@
!-------------------------------------------------------------------------------------------------
-! number of points in each AVS or OpenDX quadrangular cell for movies
+ ! number of points in each AVS or OpenDX quadrangular cell for movies
integer, parameter :: NGNOD2D_AVS_DX = 4
integer it,it1,it2,ivalue,nspectot_AVS_max,ispec
@@ -64,63 +64,36 @@
character(len=256) outputname
- integer iproc,ipoin
+ integer ipoin
-! for sorting routine
+ ! for sorting routine
integer npointot,ilocnum,nglob,i,j,ielm,ieoff,ispecloc
-! integer k
integer, dimension(:), allocatable :: iglob,loc,ireorder
logical, dimension(:), allocatable :: ifseg,mask_point
double precision, dimension(:), allocatable :: xp,yp,zp,xp_save,yp_save,zp_save,field_display
-! movie files stored by solver
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ ! movie files stored by solver
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
store_val_x,store_val_y,store_val_z, &
store_val_ux,store_val_uy,store_val_uz
-! parameters read from parameter file
-! integer NER_SEDIM,NER_BASEMENT_SEDIM,NER_16_BASEMENT, &
-! NER_MOHO_16,NER_BOTTOM_MOHO,NEX_XI,NEX_ETA
-
- integer NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
+ ! parameters read from parameter file
+ integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
integer NSOURCES
-
logical MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
-! logical USE_REGULAR_MESH
integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
-
-! double precision UTM_X_MIN,UTM_X_MAX,UTM_Y_MIN,UTM_Y_MAX,Z_DEPTH_BLOCK
double precision DT
-! double precision LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX
double precision HDUR_MOVIE
-! double precision THICKNESS_TAPER_BLOCK_HR,THICKNESS_TAPER_BLOCK_MR,&
-! VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM
-
-! logical HARVARD_3D_GOCAD_MODEL,
logical TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
OCEANS
-! logical IMPOSE_MINIMUM_VP_GOCAD,HAUKSSON_REGIONAL_MODEL, &
-! BASEMENT_MAP,MOHO_MAP_LUPEI,
logical ABSORBING_CONDITIONS,SAVE_FORWARD
logical ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
-
character(len=256) OUTPUT_FILES,LOCAL_PATH
-! character(len=256) MODEL
-
-! parameters deduced from parameters read from file
integer NPROC
-! integer NEX_PER_PROC_XI,NEX_PER_PROC_ETA
-! integer NER
+ integer ier
+
-! integer NSPEC_AB
-! integer NSPEC2D_A_XI,NSPEC2D_B_XI, &
-! NSPEC2D_A_ETA,NSPEC2D_B_ETA
-! integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
-! NSPEC2D_BOTTOM,NSPEC2D_TOP, &
-! NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX
-! integer NGLOB_AB
-
!--------------------------------------------
!!!! NL NL for external meshes
!--------------------------------------------
@@ -136,12 +109,6 @@
! order of points representing the 2D square element
integer,dimension(NGNOD2D_AVS_DX),parameter :: iorder = (/1,3,2,4/)
-! obsolete, should be defined in OUTPUT_FILES/surface_from_mesher.h...
-! movie arrays (store_val_x_all_external_mesh) size
-! integer, parameter :: NSPEC_SURFACE_EXT_MESH = 15808*4
-! total number of spectral elements at surface
-! integer, parameter :: NSPEC_SURFACE_EXT_MESH = 7650 ! movie: nfaces_surface_glob_ext_mesh
-
! ************** PROGRAM STARTS HERE **************
@@ -153,22 +120,8 @@
print *,'reading parameter file'
print *
-! read the parameter file
- !call read_parameter_file(LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX, &
- ! UTM_X_MIN,UTM_X_MAX,UTM_Y_MIN,UTM_Y_MAX,Z_DEPTH_BLOCK, &
- ! NER_SEDIM,NER_BASEMENT_SEDIM,NER_16_BASEMENT,NER_MOHO_16,NER_BOTTOM_MOHO, &
- ! NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,DT, &
- ! ATTENUATION,USE_OLSEN_ATTENUATION,HARVARD_3D_GOCAD_MODEL,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
- ! THICKNESS_TAPER_BLOCK_HR,THICKNESS_TAPER_BLOCK_MR,VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM, &
- ! OCEANS,IMPOSE_MINIMUM_VP_GOCAD,HAUKSSON_REGIONAL_MODEL,ANISOTROPY, &
- ! BASEMENT_MAP,MOHO_MAP_LUPEI,ABSORBING_CONDITIONS, &
- ! MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- ! NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
- ! SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
- ! NTSTEP_BETWEEN_OUTPUT_INFO,SUPPRESS_UTM_PROJECTION,MODEL,USE_REGULAR_MESH,SIMULATION_TYPE,SAVE_FORWARD)
-
- call read_parameter_file( &
- NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ ! read the parameter file
+ call read_parameter_file(NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
@@ -176,24 +129,20 @@
NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
-
-! compute other parameters based upon values read
-! if( .not. USE_EXTERNAL_MESH ) then
-! call compute_parameters(NER,NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
-! NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
-! NER_BOTTOM_MOHO,NER_MOHO_16,NER_16_BASEMENT,NER_BASEMENT_SEDIM,NER_SEDIM, &
-! NSPEC_AB,NSPEC2D_A_XI,NSPEC2D_B_XI, &
-! NSPEC2D_A_ETA,NSPEC2D_B_ETA, &
-! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
-! NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NGLOB_AB,USE_REGULAR_MESH)
-! endif
-
-! get the base pathname for output files
+
+ ! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+ ! only one global array for movie data, but stored for all surfaces defined
+ ! in file 'surface_from_mesher.h'
+ if(USE_HIGHRES_FOR_MOVIES) then
+ ilocnum = NSPEC_SURFACE_EXT_MESH*NGLLSQUARE
+ else
+ ilocnum = NSPEC_SURFACE_EXT_MESH*NGNOD2D_AVS_DX
+ endif
+ print*,' moviedata element surfaces: ',NSPEC_SURFACE_EXT_MESH
+ print*,' moviedata total elements all: ',ilocnum
print *
- print *,'There are ',NPROC,' slices numbered from 0 to ',NPROC-1
- print *
if(SAVE_DISPLACEMENT) then
print *,'Vertical displacement will be shown in movie'
@@ -202,59 +151,27 @@
endif
print *
- NPROC = 1
-
- if(USE_HIGHRES_FOR_MOVIES) then
- ilocnum = NSPEC_SURFACE_EXT_MESH*NGLLSQUARE
- else
- ilocnum = NSPEC_SURFACE_EXT_MESH*NGNOD2D_AVS_DX
- endif
-
- allocate(store_val_x(ilocnum,0:NPROC-1))
- allocate(store_val_y(ilocnum,0:NPROC-1))
- allocate(store_val_z(ilocnum,0:NPROC-1))
- allocate(store_val_ux(ilocnum,0:NPROC-1))
- allocate(store_val_uy(ilocnum,0:NPROC-1))
- allocate(store_val_uz(ilocnum,0:NPROC-1))
-
+ ! user input
print *,'1 = create files in OpenDX format'
print *,'2 = create files in AVS UCD format'
print *,'3 = create files in GMT xyz Ascii long/lat/Uz format'
print *,'any other value = exit'
print *
-
print *,'enter value:'
read(5,*) iformat
-
if(iformat < 1 .or. iformat > 3) stop 'exiting...'
- if(iformat == 1) then
- USE_OPENDX = .true.
- USE_AVS = .false.
- else if(iformat == 2) then
- USE_OPENDX = .false.
- USE_AVS = .true.
- else
- USE_OPENDX = .false.
- USE_AVS = .false.
- endif
-
+ plot_shaking_map = .false.
print *,'movie frames have been saved every ',NTSTEP_BETWEEN_FRAMES,' time steps'
print *
-
- plot_shaking_map = .false.
print *,'enter first time step of movie (e.g. 1, enter -1 for shaking map)'
- read(5,*) it1
-
+ read(5,*) it1
if(it1 == 0 ) it1 = 1
- if(it1 == -1) plot_shaking_map = .true.
-
+ if(it1 == -1) plot_shaking_map = .true.
if(.not. plot_shaking_map) then
-
print *,'enter last time step of movie (e.g. ',NSTEP,')'
read(5,*) it2
-
print *
print *,'1 = define file names using frame number'
print *,'2 = define file names using time step number'
@@ -263,29 +180,24 @@
print *,'enter value:'
read(5,*) inumber
if(inumber<1 .or. inumber>2) stop 'exiting...'
-
print *
print *,'looping from ',it1,' to ',it2,' every ',NTSTEP_BETWEEN_FRAMES,' time steps'
-
! count number of movie frames
nframes = 0
do it = it1,it2
if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) nframes = nframes + 1
enddo
- print *
- print *,'total number of frames will be ',nframes
- if(nframes == 0) stop 'null number of frames'
-
else
-
! only one frame if shaking map
nframes = 1
it1 = 1
it2 = 1
endif
+ print *
+ print *,'total number of frames will be ',nframes
+ if(nframes == 0) stop 'null number of frames'
iscaling_shake = 0
-
if(plot_shaking_map) then
print *
print *,'norm to display in shaking map:'
@@ -306,24 +218,31 @@
print *
read(5,*) inorm
if(inorm < 1 .or. inorm > 4) stop 'incorrect value of inorm'
- !print *,' norm of velocity vector will be displayed'
endif
-! define the total number of elements at the surface
+! file format flags
+ if(iformat == 1) then
+ USE_OPENDX = .true.
+ USE_AVS = .false.
+ else if(iformat == 2) then
+ USE_OPENDX = .false.
+ USE_AVS = .true.
+ else
+ USE_OPENDX = .false.
+ USE_AVS = .false.
+ endif
+
+ ! define the total number of elements at the surface
if(USE_HIGHRES_FOR_MOVIES) then
nspectot_AVS_max = NSPEC_SURFACE_EXT_MESH * (NGLLX-1) * (NGLLY-1)
else
nspectot_AVS_max = NSPEC_SURFACE_EXT_MESH
- endif
-
- print *
- print *,'there are a total of ',nspectot_AVS_max,' elements at the surface'
- print *
+ endif
-! maximum theoretical number of points at the surface
+ ! maximum theoretical number of points at the surface
npointot = NGNOD2D_AVS_DX * nspectot_AVS_max
-! allocate arrays for sorting routine
+ ! allocate arrays for sorting routine
allocate(iglob(npointot),loc(npointot))
allocate(ifseg(npointot))
allocate(xp(npointot),yp(npointot),zp(npointot))
@@ -332,13 +251,14 @@
allocate(mask_point(npointot))
allocate(ireorder(npointot))
- print *
- if(APPLY_THRESHOLD .and. .not. plot_shaking_map) print *,'Will apply a threshold to amplitude below ',100.*THRESHOLD,' %'
- if(NONLINEAR_SCALING .and. (.not. plot_shaking_map .or. iscaling_shake == 1)) &
- print *,'Will apply a non linear scaling with coef ',POWER_SCALING
+ ! allocates data arrays
+ allocate(store_val_x(ilocnum))
+ allocate(store_val_y(ilocnum))
+ allocate(store_val_z(ilocnum))
+ allocate(store_val_ux(ilocnum))
+ allocate(store_val_uy(ilocnum))
+ allocate(store_val_uz(ilocnum))
-! --------------------------------------
-
if(USE_HIGHRES_FOR_MOVIES) then
allocate(x(NGLLX,NGLLY))
allocate(y(NGLLX,NGLLY))
@@ -346,12 +266,23 @@
allocate(display(NGLLX,NGLLY))
endif
+ ! user output
+ print *
+ print *,'there are a total of ',nspectot_AVS_max,' elements at the surface'
+ print *
+ print *
+ if(APPLY_THRESHOLD .and. .not. plot_shaking_map) &
+ print *,'Will apply a threshold to amplitude below ',100.*THRESHOLD,' %'
+ if(NONLINEAR_SCALING .and. (.not. plot_shaking_map .or. iscaling_shake == 1)) &
+ print *,'Will apply a non linear scaling with coef ',POWER_SCALING
+
+
iframe = 0
! loop on all the time steps in the range entered
do it = it1,it2
- ! check if time step corresponds to a movie frame
+ ! check if time step corresponds to a movie frame
if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0 .or. plot_shaking_map) then
iframe = iframe + 1
@@ -364,13 +295,19 @@
endif
print *
- ! read all the elements from the same file
+ ! read all the elements from the same file
if(plot_shaking_map) then
write(outputname,"('/shakingdata')")
else
write(outputname,"('/moviedata',i6.6)") it
endif
- open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='old',action='read',form='unformatted')
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(outputname),status='old', &
+ action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: ',trim(OUTPUT_FILES)//trim(outputname)
+ stop 'error opening moviedata file'
+ endif
+
read(IOUT) store_val_x
read(IOUT) store_val_y
read(IOUT) store_val_z
@@ -379,285 +316,269 @@
read(IOUT) store_val_uz
close(IOUT)
- ! clear number of elements kept
+ ! clear number of elements kept
ispec = 0
- ! read points for all the slices
- do iproc = 0,NPROC-1
+ ! reset point number
+ ipoin = 0
- ! reset point number
- ipoin = 0
+ do ispecloc = 1, NSPEC_SURFACE_EXT_MESH
- !do ispecloc = 1,NEX_PER_PROC_XI*NEX_PER_PROC_ETA
- do ispecloc = 1, NSPEC_SURFACE_EXT_MESH
+ if(USE_HIGHRES_FOR_MOVIES) then
+ ! assign the OpenDX "elements"
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
- if(USE_HIGHRES_FOR_MOVIES) then
- ! assign the OpenDX "elements"
+ ! x,y,z coordinates
+ xcoord = store_val_x(ipoin)
+ ycoord = store_val_y(ipoin)
+ zcoord = store_val_z(ipoin)
- do j = 1,NGLLY
- do i = 1,NGLLX
+ ! note:
+ ! for shakemaps: ux = norm displacement, uy = norm velocity, uz = norm acceleration
+ ! for movies: ux = velocity x-component, uy = velocity y-component, uz = velocity z-component
+ vectorx = store_val_ux(ipoin)
+ vectory = store_val_uy(ipoin)
+ vectorz = store_val_uz(ipoin)
- ipoin = ipoin + 1
+ x(i,j) = xcoord
+ y(i,j) = ycoord
+ z(i,j) = zcoord
- ! x,y,z coordinates
- xcoord = store_val_x(ipoin,iproc)
- ycoord = store_val_y(ipoin,iproc)
- zcoord = store_val_z(ipoin,iproc)
+ ! shakemap
+ if(plot_shaking_map) then
+ !!!! NL NL mute value near source
+ if ( (sqrt(((x(i,j) - (X_SOURCE_EXT_MESH))**2 + &
+ (y(i,j) - (Y_SOURCE_EXT_MESH))**2 + &
+ (z(i,j) - (Z_SOURCE_EXT_MESH))**2)) < RADIUS_TO_MUTE) &
+ .and. MUTE_SOURCE) then
- ! note:
- ! for shakemaps: ux = norm displacement, uy = norm velocity, uz = norm acceleration
- ! for movies: ux = velocity x-component, uy = velocity y-component, uz = velocity z-component
- vectorx = store_val_ux(ipoin,iproc)
- vectory = store_val_uy(ipoin,iproc)
- vectorz = store_val_uz(ipoin,iproc)
-
- x(i,j) = xcoord
- y(i,j) = ycoord
- z(i,j) = zcoord
-
- ! shakemap
- if(plot_shaking_map) then
- !!!! NL NL mute value near source
- if ( (sqrt(((x(i,j) - (X_SOURCE_EXT_MESH))**2 + &
- (y(i,j) - (Y_SOURCE_EXT_MESH))**2 + &
- (z(i,j) - (Z_SOURCE_EXT_MESH))**2)) < RADIUS_TO_MUTE) &
- .and. MUTE_SOURCE) then
-
- display(i,j) = 0.
- else
- ! chooses norm
- if(inorm == 1) then
- ! norm displacement
- display(i,j) = vectorx
- else if(inorm == 2) then
- ! norm velocity
- display(i,j) = vectory
- else
- ! norm acceleration
- display(i,j) = vectorz
- endif
- endif
+ display(i,j) = 0.
else
- ! movie
+ ! chooses norm
if(inorm == 1) then
- ! norm of velocity
- display(i,j) = sqrt(vectorz**2+vectory**2+vectorx**2)
- else if( inorm == 2 ) then
- ! velocity x-component
+ ! norm displacement
display(i,j) = vectorx
- else if( inorm == 3 ) then
- ! velocity y-component
- display(i,j) = vectory
- else if( inorm == 4 ) then
- ! velocity z-component
- display(i,j) = vectorz
+ else if(inorm == 2) then
+ ! norm velocity
+ display(i,j) = vectory
+ else
+ ! norm acceleration
+ display(i,j) = vectorz
endif
endif
+ else
+ ! movie
+ if(inorm == 1) then
+ ! norm of velocity
+ display(i,j) = sqrt(vectorz**2+vectory**2+vectorx**2)
+ else if( inorm == 2 ) then
+ ! velocity x-component
+ display(i,j) = vectorx
+ else if( inorm == 3 ) then
+ ! velocity y-component
+ display(i,j) = vectory
+ else if( inorm == 4 ) then
+ ! velocity z-component
+ display(i,j) = vectorz
+ endif
+ endif
- enddo
enddo
+ enddo
- ! assign the values of the corners of the OpenDX "elements"
- ispec = ispec + 1
- ielm = (NGLLX-1)*(NGLLY-1)*(ispec-1)
+ ! assign the values of the corners of the OpenDX "elements"
+ ispec = ispec + 1
+ ielm = (NGLLX-1)*(NGLLY-1)*(ispec-1)
- do j = 1,NGLLY-1
- do i = 1,NGLLX-1
- ieoff = NGNOD2D_AVS_DX*(ielm+(i-1)+(j-1)*(NGLLX-1))
- do ilocnum = 1,NGNOD2D_AVS_DX
- ! do k = 1,NGNOD2D_AVS_DX
+ do j = 1,NGLLY-1
+ do i = 1,NGLLX-1
+ ieoff = NGNOD2D_AVS_DX*(ielm+(i-1)+(j-1)*(NGLLX-1))
+ do ilocnum = 1,NGNOD2D_AVS_DX
+ ! do k = 1,NGNOD2D_AVS_DX
- if(ilocnum == 1) then
- xp(ieoff+ilocnum) = dble(x(i,j))
- yp(ieoff+ilocnum) = dble(y(i,j))
- zp(ieoff+ilocnum) = dble(z(i,j))
- field_display(ieoff+ilocnum) = dble(display(i,j))
- elseif(ilocnum == 2) then
+ if(ilocnum == 1) then
+ xp(ieoff+ilocnum) = dble(x(i,j))
+ yp(ieoff+ilocnum) = dble(y(i,j))
+ zp(ieoff+ilocnum) = dble(z(i,j))
+ field_display(ieoff+ilocnum) = dble(display(i,j))
+ elseif(ilocnum == 2) then
- ! accounts for different ordering of square points
- xp(ieoff+ilocnum) = dble(x(i+1,j+1))
- yp(ieoff+ilocnum) = dble(y(i+1,j+1))
- zp(ieoff+ilocnum) = dble(z(i+1,j+1))
- field_display(ieoff+ilocnum) = dble(display(i+1,j+1))
+ ! accounts for different ordering of square points
+ xp(ieoff+ilocnum) = dble(x(i+1,j+1))
+ yp(ieoff+ilocnum) = dble(y(i+1,j+1))
+ zp(ieoff+ilocnum) = dble(z(i+1,j+1))
+ field_display(ieoff+ilocnum) = dble(display(i+1,j+1))
- ! xp(ieoff+ilocnum) = dble(x(i+1,j))
- ! yp(ieoff+ilocnum) = dble(y(i+1,j))
- ! zp(ieoff+ilocnum) = dble(z(i+1,j))
- ! field_display(ieoff+ilocnum) = dble(display(i+1,j))
+ ! xp(ieoff+ilocnum) = dble(x(i+1,j))
+ ! yp(ieoff+ilocnum) = dble(y(i+1,j))
+ ! zp(ieoff+ilocnum) = dble(z(i+1,j))
+ ! field_display(ieoff+ilocnum) = dble(display(i+1,j))
- elseif(ilocnum == 3) then
+ elseif(ilocnum == 3) then
- ! accounts for different ordering of square points
- xp(ieoff+ilocnum) = dble(x(i+1,j))
- yp(ieoff+ilocnum) = dble(y(i+1,j))
- zp(ieoff+ilocnum) = dble(z(i+1,j))
- field_display(ieoff+ilocnum) = dble(display(i+1,j))
+ ! accounts for different ordering of square points
+ xp(ieoff+ilocnum) = dble(x(i+1,j))
+ yp(ieoff+ilocnum) = dble(y(i+1,j))
+ zp(ieoff+ilocnum) = dble(z(i+1,j))
+ field_display(ieoff+ilocnum) = dble(display(i+1,j))
- ! xp(ieoff+ilocnum) = dble(x(i+1,j+1))
- ! yp(ieoff+ilocnum) = dble(y(i+1,j+1))
- ! zp(ieoff+ilocnum) = dble(z(i+1,j+1))
- ! field_display(ieoff+ilocnum) = dble(display(i+1,j+1))
- else
- xp(ieoff+ilocnum) = dble(x(i,j+1))
- yp(ieoff+ilocnum) = dble(y(i,j+1))
- zp(ieoff+ilocnum) = dble(z(i,j+1))
- field_display(ieoff+ilocnum) = dble(display(i,j+1))
- endif
+ ! xp(ieoff+ilocnum) = dble(x(i+1,j+1))
+ ! yp(ieoff+ilocnum) = dble(y(i+1,j+1))
+ ! zp(ieoff+ilocnum) = dble(z(i+1,j+1))
+ ! field_display(ieoff+ilocnum) = dble(display(i+1,j+1))
+ else
+ xp(ieoff+ilocnum) = dble(x(i,j+1))
+ yp(ieoff+ilocnum) = dble(y(i,j+1))
+ zp(ieoff+ilocnum) = dble(z(i,j+1))
+ field_display(ieoff+ilocnum) = dble(display(i,j+1))
+ endif
- enddo
-
- !if( j==1 .and. ispec==1) then
- !print*,'p1',xp(ieoff+1),yp(ieoff+1),zp(ieoff+1)
- !print*,'p2',xp(ieoff+2),yp(ieoff+2),zp(ieoff+2)
- !print*,'p3',xp(ieoff+3),yp(ieoff+3),zp(ieoff+3)
- !print*,'p4',xp(ieoff+4),yp(ieoff+4),zp(ieoff+4)
- !endif
-
enddo
+
+ !if( j==1 .and. ispec==1) then
+ !print*,'p1',xp(ieoff+1),yp(ieoff+1),zp(ieoff+1)
+ !print*,'p2',xp(ieoff+2),yp(ieoff+2),zp(ieoff+2)
+ !print*,'p3',xp(ieoff+3),yp(ieoff+3),zp(ieoff+3)
+ !print*,'p4',xp(ieoff+4),yp(ieoff+4),zp(ieoff+4)
+ !endif
+
enddo
+ enddo
- else
- ! low-resolution (only spectral element corners)
- ispec = ispec + 1
- ieoff = NGNOD2D_AVS_DX*(ispec-1)
+ else
+ ! low-resolution (only spectral element corners)
+ ispec = ispec + 1
+ ieoff = NGNOD2D_AVS_DX*(ispec-1)
- ! four points for each element
- do i = 1,NGNOD2D_AVS_DX
+ ! four points for each element
+ do i = 1,NGNOD2D_AVS_DX
- ! accounts for different ordering of square points
- ilocnum = iorder(i)
-
- ipoin = ipoin + 1
+ ! accounts for different ordering of square points
+ ilocnum = iorder(i)
+
+ ipoin = ipoin + 1
- xcoord = store_val_x(ipoin,iproc)
- ycoord = store_val_y(ipoin,iproc)
- zcoord = store_val_z(ipoin,iproc)
+ xcoord = store_val_x(ipoin)
+ ycoord = store_val_y(ipoin)
+ zcoord = store_val_z(ipoin)
- vectorx = store_val_ux(ipoin,iproc)
- vectory = store_val_uy(ipoin,iproc)
- vectorz = store_val_uz(ipoin,iproc)
+ vectorx = store_val_ux(ipoin)
+ vectory = store_val_uy(ipoin)
+ vectorz = store_val_uz(ipoin)
- xp(ilocnum+ieoff) = dble(xcoord)
- yp(ilocnum+ieoff) = dble(ycoord)
- zp(ilocnum+ieoff) = dble(zcoord)
+ xp(ilocnum+ieoff) = dble(xcoord)
+ yp(ilocnum+ieoff) = dble(ycoord)
+ zp(ilocnum+ieoff) = dble(zcoord)
- ! shakemap
- if(plot_shaking_map) then
- !!!! NL NL mute value near source
- if ( (sqrt(((dble(xcoord) - (X_SOURCE_EXT_MESH))**2 + &
- (dble(ycoord) - (Y_SOURCE_EXT_MESH))**2 + &
- (dble(zcoord) - (Z_SOURCE_EXT_MESH))**2)) < RADIUS_TO_MUTE) &
- .and. MUTE_SOURCE) then
- field_display(ilocnum+ieoff) = 0.
- else
- if(inorm == 1) then
- ! norm of displacement
- field_display(ilocnum+ieoff) = dble(vectorx)
- else if(inorm == 2) then
- ! norm of velocity
- field_display(ilocnum+ieoff) = dble(vectory)
- else
- ! norm of acceleration
- field_display(ilocnum+ieoff) = dble(vectorz)
- endif
- endif
+ ! shakemap
+ if(plot_shaking_map) then
+ !!!! NL NL mute value near source
+ if ( (sqrt(((dble(xcoord) - (X_SOURCE_EXT_MESH))**2 + &
+ (dble(ycoord) - (Y_SOURCE_EXT_MESH))**2 + &
+ (dble(zcoord) - (Z_SOURCE_EXT_MESH))**2)) < RADIUS_TO_MUTE) &
+ .and. MUTE_SOURCE) then
+ field_display(ilocnum+ieoff) = 0.
else
- ! movie
if(inorm == 1) then
+ ! norm of displacement
+ field_display(ilocnum+ieoff) = dble(vectorx)
+ else if(inorm == 2) then
! norm of velocity
- field_display(ilocnum+ieoff) = sqrt(vectorz**2+vectory**2+vectorx**2)
- else if( inorm == 2 ) then
- ! velocity x-component
- field_display(ilocnum+ieoff) = vectorx
- else if( inorm == 3 ) then
- ! velocity y-component
- field_display(ilocnum+ieoff) = vectory
+ field_display(ilocnum+ieoff) = dble(vectory)
else
- ! velocity z-component
- field_display(ilocnum+ieoff) = vectorz
- endif
- ! takes norm of velocity vector
- !field_display(ilocnum+ieoff) =sqrt(vectorz**2+vectory**2+vectorx**2)
+ ! norm of acceleration
+ field_display(ilocnum+ieoff) = dble(vectorz)
+ endif
endif
+ else
+ ! movie
+ if(inorm == 1) then
+ ! norm of velocity
+ field_display(ilocnum+ieoff) = sqrt(vectorz**2+vectory**2+vectorx**2)
+ else if( inorm == 2 ) then
+ ! velocity x-component
+ field_display(ilocnum+ieoff) = vectorx
+ else if( inorm == 3 ) then
+ ! velocity y-component
+ field_display(ilocnum+ieoff) = vectory
+ else
+ ! velocity z-component
+ field_display(ilocnum+ieoff) = vectorz
+ endif
+ ! takes norm of velocity vector
+ !field_display(ilocnum+ieoff) =sqrt(vectorz**2+vectory**2+vectorx**2)
+ endif
- enddo
+ enddo
+ endif ! USE_HIGHRES_FOR_MOVIES
+ enddo ! NSPEC_SURFACE_EXT_MESH
- endif ! USE_HIGHRES_FOR_MOVIES
-
- enddo ! NSPEC_SURFACE_EXT_MESH
- enddo ! NPROC
-
- ! copy coordinate arrays since the sorting routine does not preserve them
+ ! copy coordinate arrays since the sorting routine does not preserve them
xp_save(:) = xp(:)
yp_save(:) = yp(:)
zp_save(:) = zp(:)
- !--- sort the list based upon coordinates to get rid of multiples
+ ! sort the list based upon coordinates to get rid of multiples
print *,'sorting list of points'
call get_global_AVS(nspectot_AVS_max,xp,yp,zp,iglob,loc,ifseg,nglob,npointot, &
- dble(minval(store_val_x(:,0))),dble(maxval(store_val_x(:,0))))
+ dble(minval(store_val_x(:))),dble(maxval(store_val_x(:))))
- !--- print total number of points found
+ ! print total number of points found
print *
print *,'found a total of ',nglob,' points'
print *,'initial number of points (with multiples) was ',npointot
- !--- normalize and scale vector field
+ ! normalize and scale vector field
- ! compute min and max of data value to normalize
+ ! compute min and max of data value to normalize
min_field_current = minval(field_display(:))
max_field_current = maxval(field_display(:))
- ! print minimum and maximum amplitude in current snapshot
+ ! print minimum and maximum amplitude in current snapshot
print *
print *,'minimum amplitude in current snapshot = ',min_field_current
print *,'maximum amplitude in current snapshot = ',max_field_current
print *
- !-----------------------------------------
-
if(plot_shaking_map) then
-
- ! compute min and max of data value to normalize
+ ! compute min and max of data value to normalize
min_field_current = minval(field_display(:))
max_field_current = maxval(field_display(:))
-
- ! print minimum and maximum amplitude in current snapshot
+ ! print minimum and maximum amplitude in current snapshot
print *
print *,'minimum amplitude in current snapshot after removal = ',min_field_current
print *,'maximum amplitude in current snapshot after removal = ',max_field_current
print *
-
endif
- !-----------------------------------------
-
-
- ! apply scaling in all cases for movies
+ ! apply scaling in all cases for movies
if(.not. plot_shaking_map) then
- ! make sure range is always symmetric and center is in zero
- ! this assumption works only for fields that can be negative
- ! would not work for norm of vector for instance
- ! (we would lose half of the color palette if no negative values)
+ ! make sure range is always symmetric and center is in zero
+ ! this assumption works only for fields that can be negative
+ ! would not work for norm of vector for instance
+ ! (we would lose half of the color palette if no negative values)
max_absol = max(abs(min_field_current),abs(max_field_current))
min_field_current = - max_absol
max_field_current = + max_absol
- ! normalize field to [0:1]
- field_display(:) = (field_display(:) - min_field_current) / (max_field_current - min_field_current)
-
- ! rescale to [-1,1]
+ ! normalize field to [0:1]
+ if( abs(max_field_current - min_field_current) > TINYVAL ) &
+ field_display(:) = (field_display(:) - min_field_current) / (max_field_current - min_field_current)
+
+ ! rescale to [-1,1]
field_display(:) = 2.*field_display(:) - 1.
- ! apply threshold to normalized field
+ ! apply threshold to normalized field
if(APPLY_THRESHOLD) &
where(abs(field_display(:)) <= THRESHOLD) field_display = 0.
- ! apply non linear scaling to normalized field if needed
+ ! apply non linear scaling to normalized field if needed
if(NONLINEAR_SCALING) then
where(field_display(:) >= 0.)
field_display = field_display ** POWER_SCALING
@@ -666,29 +587,29 @@
endwhere
endif
- ! map back to [0,1]
+ ! map back to [0,1]
field_display(:) = (field_display(:) + 1.) / 2.
- ! map field to [0:255] for AVS color scale
+ ! map field to [0:255] for AVS color scale
field_display(:) = 255. * field_display(:)
- ! apply scaling only if selected for shaking map
-
+ ! apply scaling only if selected for shaking map
else if(NONLINEAR_SCALING .and. iscaling_shake == 1) then
- ! normalize field to [0:1]
- field_display(:) = field_display(:) / max_field_current
+ ! normalize field to [0:1]
+ if( abs(max_field_current) > TINYVAL ) &
+ field_display(:) = field_display(:) / max_field_current
- ! apply non linear scaling to normalized field
+ ! apply non linear scaling to normalized field
field_display = field_display ** POWER_SCALING
- ! map field to [0:255] for AVS color scale
+ ! map field to [0:255] for AVS color scale
field_display(:) = 255. * field_display(:)
endif
- !--- ****** create AVS file using sorted list ******
+ !--- ****** create AVS file using sorted list ******
if(.not. plot_shaking_map) then
if(inumber == 1) then
@@ -698,7 +619,7 @@
endif
endif
- ! create file name and open file
+ ! create file name and open file
if(plot_shaking_map) then
if(USE_OPENDX) then
@@ -734,12 +655,12 @@
! GMT format not implemented yet
else
- ! output list of points
+ ! output list of points
mask_point = .false.
ipoin = 0
do ispec=1,nspectot_AVS_max
ieoff = NGNOD2D_AVS_DX*(ispec-1)
- ! four points for each element
+ ! four points for each element
do ilocnum = 1,NGNOD2D_AVS_DX
ibool_number = iglob(ilocnum+ieoff)
if(.not. mask_point(ibool_number)) then
@@ -759,16 +680,16 @@
if(USE_OPENDX) &
write(11,*) 'object 2 class array type int rank 1 shape 4 items ',nspectot_AVS_max,' data follows'
- ! output list of elements
+ ! output list of elements
do ispec=1,nspectot_AVS_max
ieoff = NGNOD2D_AVS_DX*(ispec-1)
- ! four points for each element
+ ! four points for each element
ibool_number1 = iglob(ieoff + 1)
ibool_number2 = iglob(ieoff + 2)
ibool_number3 = iglob(ieoff + 3)
ibool_number4 = iglob(ieoff + 4)
if(USE_OPENDX) then
- ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
+ ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
write(11,"(i10,1x,i10,1x,i10,1x,i10)") ireorder(ibool_number1)-1, &
ireorder(ibool_number4)-1,ireorder(ibool_number2)-1,ireorder(ibool_number3)-1
else
@@ -782,18 +703,16 @@
write(11,*) 'attribute "ref" string "positions"'
write(11,*) 'object 3 class array type float rank 0 items ',nglob,' data follows'
else
- ! dummy text for labels
+ ! dummy text for labels
write(11,*) '1 1'
write(11,*) 'a, b'
endif
- ! output data values
+ ! output data values
mask_point = .false.
-
- ! output point data
do ispec=1,nspectot_AVS_max
ieoff = NGNOD2D_AVS_DX*(ispec-1)
- ! four points for each element
+ ! four points for each element
do ilocnum = 1,NGNOD2D_AVS_DX
ibool_number = iglob(ilocnum+ieoff)
if(.not. mask_point(ibool_number)) then
@@ -815,7 +734,7 @@
enddo
enddo
- ! define OpenDX field
+ ! define OpenDX field
if(USE_OPENDX) then
write(11,*) 'attribute "dep" string "positions"'
write(11,*) 'object "irregular positions irregular connections" class field'
@@ -825,12 +744,12 @@
write(11,*) 'end'
endif
- ! end of test for GMT format
+ ! end of test for GMT format
endif
close(11)
- ! end of loop and test on all the time steps for all the movie images
+ ! end of loop and test on all the time steps for all the movie images
endif
enddo ! it
@@ -850,7 +769,7 @@
deallocate(store_val_uy)
deallocate(store_val_uz)
-! deallocate arrays for sorting routine
+ ! deallocate arrays for sorting routine
deallocate(iglob,loc)
deallocate(ifseg)
deallocate(xp,yp,zp)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -47,7 +47,7 @@
etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore,jacobianstore
! for model density, kappa, mu
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,kappastore,mustore !,vpstore,vsstore
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,kappastore,mustore
! mass matrix
real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass,rmass_acoustic,&
@@ -180,7 +180,6 @@
! absorbing boundaries
integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, NSPEC2D_BOTTOM, NSPEC2D_TOP
-! integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
integer, dimension(nspec2D_xmin) :: ibelm_xmin
integer, dimension(nspec2D_xmax) :: ibelm_xmax
integer, dimension(nspec2D_ymin) :: ibelm_ymin
@@ -415,11 +414,11 @@
! endif
! cleanup
+ if( .not. SAVE_MOHO_MESH ) deallocate(xstore_dummy,ystore_dummy,zstore_dummy)
deallocate(xixstore,xiystore,xizstore,&
- etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore)
- deallocate(jacobianstore,iflag_attenuation_store)
- deallocate(xstore_dummy,ystore_dummy,zstore_dummy)
+ etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore)
+ deallocate(jacobianstore,iflag_attenuation_store)
deallocate(kappastore,mustore,rho_vp,rho_vs)
end subroutine create_regions_mesh_ext
@@ -1927,28 +1926,6 @@
endif
endif
-!obsolete...
-! calculates 2D jacobians and normals for each GLL point on face
-! call get_jacobian_boundaries(myrank,iboun,nspec, &
-! xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
-! dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
-! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
-! ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
-! xcoord_iboun,ycoord_iboun,zcoord_iboun, &
-! nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
-! jacobian2D_xmin,jacobian2D_xmax, &
-! jacobian2D_ymin,jacobian2D_ymax, &
-! jacobian2D_bottom,jacobian2D_top, &
-! normal_xmin,normal_xmax, &
-! normal_ymin,normal_ymax, &
-! normal_bottom,normal_top, &
-! NSPEC2D_BOTTOM,NSPEC2D_TOP)
-! obsolete... arrays not used anymore...
-! Stacey put back
-! call get_absorb_ext_mesh(myrank,iboun,nspec, &
-! nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
-! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
-
end subroutine crm_ext_setup_abs_boundary
@@ -2300,11 +2277,6 @@
iy_oceans = free_surface_ijk(1,igll,ispec2D)
iz_oceans = free_surface_ijk(1,igll,ispec2D)
-
-! iz_oceans = NGLLZ
-! do ix_oceans = 1,NGLLX
-! do iy_oceans = 1,NGLLY
-
iglobnum=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
! compute local height of oceans
@@ -2355,10 +2327,6 @@
endif
! take into account inertia of water column
- !weight = wxgll(ix_oceans)*wygll(iy_oceans) &
- ! * dble(jacobian2D_top(ix_oceans,iy_oceans,ispec2D_ocean_bottom)) &
- ! * dble(RHO_OCEANS) * height_oceans
-
weight = dble( free_surface_jacobian2Dw(igll,ispec2D)) &
* dble(RHO_OCEANS) * height_oceans
@@ -2387,6 +2355,352 @@
end subroutine crm_ext_create_ocean_load_mass
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine create_regions_mesh_save_moho( myrank,nglob,nspec, &
+ nspec2D_moho_ext,ibelm_moho,nodes_ibelm_moho, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh,ibool )
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+ integer :: nspec2D_moho_ext
+ integer, dimension(nspec2D_moho_ext) :: ibelm_moho
+ integer, dimension(4,nspec2D_moho_ext) :: nodes_ibelm_moho
+
+ integer :: myrank,nglob,nspec
+
+ ! data from the external mesh
+ integer :: nnodes_ext_mesh
+ double precision, dimension(NDIM,nnodes_ext_mesh) :: nodes_coords_ext_mesh
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! local parameters
+ ! Moho mesh
+ real(CUSTOM_REAL), dimension(:,:,:),allocatable :: normal_moho_top
+ real(CUSTOM_REAL), dimension(:,:,:),allocatable :: normal_moho_bot
+ integer,dimension(:,:,:),allocatable :: ijk_moho_top, ijk_moho_bot
+ integer,dimension(:),allocatable :: ibelm_moho_top, ibelm_moho_bot
+ integer :: NSPEC2D_MOHO
+ logical, dimension(:),allocatable :: is_moho_top, is_moho_bot
+
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
+ real(kind=CUSTOM_REAL) :: jacobian2Dw_face(NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL) :: normal_face(NDIM,NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL),dimension(NDIM):: normal
+ integer :: ijk_face(3,NGLLX,NGLLY)
+
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: iglob_normals
+ integer,dimension(:),allocatable:: iglob_is_surface
+
+ integer :: imoho_bot,imoho_top
+ integer :: ispec2D,ispec,icorner,iface,i,j,k,igll,iglob
+ integer :: iglob_midpoint,idirect,counter
+ integer :: imoho_top_all,imoho_bot_all,imoho_all
+
+ ! corners indices of reference cube faces
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape( (/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape( (/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape( (/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape( (/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape( (/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ ! midpoint indices for each face (xmin,xmax,ymin,ymax,zmin,zmax)
+ integer,dimension(3,6),parameter :: iface_all_midpointijk = &
+ reshape( (/ 1,2,2, NGLLX,2,2, 2,1,2, 2,NGLLY,2, 2,2,1, 2,2,NGLLZ /),(/3,6/)) ! top
+
+ ! temporary arrays for passing information
+ allocate(iglob_is_surface(nglob))
+ allocate(iglob_normals(NDIM,nglob))
+ iglob_is_surface = 0
+ iglob_normals = 0._CUSTOM_REAL
+
+ ! loops over given moho surface elements
+ do ispec2D=1, nspec2D_moho_ext
+
+ ! gets element id
+ ispec = ibelm_moho(ispec2D)
+
+ ! looks for i,j,k indices of GLL points on boundary face
+ ! determines element face by given CUBIT corners
+ ! (note: uses point locations rather than point indices to find the element face,
+ ! because the indices refer no more to the newly indexed ibool array )
+ do icorner=1,NGNOD2D
+ xcoord(icorner) = nodes_coords_ext_mesh(1,nodes_ibelm_moho(icorner,ispec2D))
+ ycoord(icorner) = nodes_coords_ext_mesh(2,nodes_ibelm_moho(icorner,ispec2D))
+ zcoord(icorner) = nodes_coords_ext_mesh(3,nodes_ibelm_moho(icorner,ispec2D))
+ enddo
+
+ ! sets face id of reference element associated with this face
+ call get_element_face_id(ispec,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ iface)
+
+ ! ijk indices of GLL points for face id
+ call get_element_face_gll_indices(iface,ijk_face,NGLLX,NGLLZ)
+
+ ! weighted jacobian and normal
+ call get_jacobian_boundary_face(myrank,nspec, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
+ ispec,iface,jacobian2Dw_face,normal_face,NGLLX,NGLLZ)
+
+ ! normal convention: points away from element
+ ! switch normal direction if necessary
+ do j=1,NGLLY
+ do i=1,NGLLX
+ call get_element_face_normal(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ enddo
+ enddo
+
+ ! stores information on global points on moho surface
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(ijk_face(1,i,j),ijk_face(2,i,j),ijk_face(3,i,j),ispec)
+ ! sets flag
+ iglob_is_surface(iglob) = ispec2D
+ ! sets normals
+ iglob_normals(:,iglob) = normal_face(:,i,j)
+ enddo
+ enddo
+ enddo
+
+ ! stores moho elements
+ NSPEC2D_MOHO = nspec2D_moho_ext
+
+ allocate(ibelm_moho_bot(NSPEC2D_MOHO))
+ allocate(ibelm_moho_top(NSPEC2D_MOHO))
+ allocate(normal_moho_top(NDIM,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(normal_moho_bot(NDIM,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(ijk_moho_bot(3,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(ijk_moho_top(3,NGLLSQUARE,NSPEC2D_MOHO))
+ ibelm_moho_bot = 0
+ ibelm_moho_top = 0
+
+ ! element flags
+ allocate(is_moho_top(nspec))
+ allocate(is_moho_bot(nspec))
+ is_moho_top = .false.
+ is_moho_bot = .false.
+
+ ! finds spectral elements with moho surface
+ imoho_top = 0
+ imoho_bot = 0
+ do ispec=1,nspec
+
+ ! loops over each face
+ do iface = 1,6
+ ! checks if corners of face on surface
+ counter = 0
+ do icorner = 1,NGNOD2D
+ i = iface_all_corner_ijk(1,icorner,iface)
+ j = iface_all_corner_ijk(2,icorner,iface)
+ k = iface_all_corner_ijk(3,icorner,iface)
+ iglob = ibool(i,j,k,ispec)
+
+ ! checks if point on surface
+ if( iglob_is_surface(iglob) > 0 ) then
+ counter = counter+1
+
+ ! reference corner coordinates
+ xcoord(icorner) = xstore_dummy(iglob)
+ ycoord(icorner) = ystore_dummy(iglob)
+ zcoord(icorner) = zstore_dummy(iglob)
+ endif
+ enddo
+
+ ! stores moho informations
+ if( counter == NGNOD2D ) then
+
+ ! gets face GLL points i,j,k indices from element face
+ call get_element_face_gll_indices(iface,ijk_face,NGLLX,NGLLY)
+
+ ! re-computes face infos
+ ! weighted jacobian and normal
+ call get_jacobian_boundary_face(myrank,nspec, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
+ ispec,iface,jacobian2Dw_face,normal_face,NGLLX,NGLLZ)
+
+ ! normal convention: points away from element
+ ! switch normal direction if necessary
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ call get_element_face_normal(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ enddo
+ enddo
+
+ ! takes normal stored temporary on a face midpoint
+ i = iface_all_midpointijk(1,iface)
+ j = iface_all_midpointijk(2,iface)
+ k = iface_all_midpointijk(3,iface)
+ iglob_midpoint = ibool(i,j,k,ispec)
+ normal(:) = iglob_normals(:,iglob_midpoint)
+
+ ! determines whether normal points into element or not (top/bottom distinction)
+ call get_element_face_normal_idirect(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal,idirect )
+
+ ! takes moho surface element id given by id on midpoint
+ ispec2D = iglob_is_surface(iglob_midpoint)
+
+ ! sets face infos for bottom (normal points away from element)
+ if( idirect == 1 ) then
+
+ ! checks validity
+ if( is_moho_bot( ispec) == .true. ) then
+ print*,'error: moho surface geometry bottom'
+ print*,' does not allow for mulitple element faces in kernel computation'
+ call exit_mpi(myrank,'error moho bottom elements')
+ endif
+
+ imoho_bot = imoho_bot + 1
+ is_moho_bot(ispec) = .true.
+ ibelm_moho_bot(ispec2D) = ispec
+
+ ! stores on surface gll points (assuming NGLLX = NGLLY = NGLLZ)
+ igll = 0
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ igll = igll+1
+ ijk_moho_bot(:,igll,ispec2D) = ijk_face(:,i,j)
+ normal_moho_bot(:,igll,ispec2D) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ ! sets face infos for top element
+ else if( idirect == 2 ) then
+
+ ! checks validity
+ if( is_moho_top( ispec) == .true. ) then
+ print*,'error: moho surface geometry top'
+ print*,' does not allow for mulitple element faces kernel computation'
+ call exit_mpi(myrank,'error moho top elements')
+ endif
+
+ imoho_top = imoho_top + 1
+ is_moho_top(ispec) = .true.
+ ibelm_moho_top(ispec2D) = ispec
+
+ ! gll points
+ igll = 0
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ igll = igll+1
+ ijk_moho_top(:,igll,ispec) = ijk_face(:,i,j)
+ ! note: top elements have normal pointing into element
+ normal_moho_top(:,igll,ispec) = - normal_face(:,i,j)
+ enddo
+ enddo
+ endif
+
+ endif ! counter
+
+ enddo ! iface
+
+ ! checks validity of top/bottom distinction
+ if( is_moho_top(ispec) .and. is_moho_bot(ispec) ) then
+ print*,'error: moho surface elements confusing'
+ print*,' element:',ispec,'has top and bottom surface'
+ call exit_mpi(myrank,'error moho surface element')
+ endif
+
+ enddo ! ispec2D
+
+ ! note: surface e.g. could be at the free-surface and have no top elements etc...
+ ! user output
+ call sum_all_i( imoho_top, imoho_top_all )
+ call sum_all_i( imoho_bot, imoho_bot_all )
+ call sum_all_i( NSPEC2D_MOHO, imoho_all )
+ if( myrank == 0 ) then
+ write(IMAIN,*) '********'
+ write(IMAIN,*) 'Moho surface:'
+ write(IMAIN,*) ' total surface elements: ',imoho_all
+ write(IMAIN,*) ' top elements :',imoho_top_all
+ write(IMAIN,*) ' bottom elements:',imoho_bot_all
+ write(IMAIN,*) '********'
+ endif
+
+ ! saves moho files: total number of elements, corner points, all points
+ open(unit=27,file=prname(1:len_trim(prname))//'ibelm_moho.bin',status='unknown',form='unformatted')
+ write(27) NSPEC2D_MOHO
+ write(27) ibelm_moho_top
+ write(27) ibelm_moho_bot
+ write(27) ijk_moho_top
+ write(27) ijk_moho_bot
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'normal_moho.bin',status='unknown',form='unformatted')
+ write(27) normal_moho_top
+ write(27) normal_moho_bot
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'is_moho.bin',status='unknown',form='unformatted')
+ write(27) is_moho_top
+ write(27) is_moho_bot
+ close(27)
+
+end subroutine create_regions_mesh_save_moho
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine bubble_sort( arr, ndim )
+
+! sorts values in array arr[ndim] in increasing order
+
+ implicit none
+
+ integer :: ndim
+ integer :: arr(ndim)
+
+ logical :: swapped
+ integer :: j,tmp
+
+ swapped = .true.
+ do while( swapped )
+ swapped = .false.
+ do j = 1, ndim-1
+ if( arr(j+1) < arr(j) ) then
+ tmp = arr(j)
+ arr(j) = arr(j+1)
+ arr(j+1) = tmp
+ swapped = .true.
+ endif
+ enddo
+ enddo
+
+end subroutine bubble_sort
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
!pll
! subroutine interface(iflag,flag_below,flag_above,ispec,nspec,i,j,k,xstore,ystore,zstore,ibedrock)
@@ -2495,34 +2809,3 @@
! end subroutine interface
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-subroutine bubble_sort( arr, ndim )
-
-! sorts values in array arr[ndim] in increasing order
-
- implicit none
-
- integer :: ndim
- integer :: arr(ndim)
-
- logical :: swapped
- integer :: j,tmp
-
- swapped = .true.
- do while( swapped )
- swapped = .false.
- do j = 1, ndim-1
- if( arr(j+1) < arr(j) ) then
- tmp = arr(j)
- arr(j) = arr(j+1)
- arr(j+1) = tmp
- swapped = .true.
- endif
- enddo
- enddo
-
-end subroutine bubble_sort
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/Makefile
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/Makefile 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/Makefile 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,10 +1,20 @@
# Makefile
+#############################################################
+## modify to match your compiler defaults
+## (which were used to compile SCOTCH libraries from below as well)
F90 = gfortran
+#F90 = ifort
-SCOTCH_LIBS = /data2/tarje/SCOTCH/lib/libscotch.a /data2/tarje/SCOTCH/lib/libscotcherr.a
+## modify to match your library paths
+SCOTCH_LIBS = /opt/seismo-util/source/scotch/lib/libscotch.a \
+ /opt/seismo-util/source/scotch/lib/libscotcherr.a
#SCOTCH_LIBS = /scratch/network/SCOTCH/lib/libscotch.a /scratch/network/SCOTCH/lib/libscotcherr.a
+#############################################################
+
+
+
LIBS = part_decompose_mesh_SCOTCH.o \
decompose_mesh_SCOTCH.o \
program_decompose_mesh_SCOTCH.o
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/OUTPUT_FILES/cubit2specfem3d.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/OUTPUT_FILES/cubit2specfem3d.py 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/OUTPUT_FILES/cubit2specfem3d.py 2010-02-23 02:41:02 UTC (rev 16315)
@@ -1,6 +1,6 @@
#!python
#############################################################################
-# cubit2specfem3d.py #
+# cubit2specfem3d.py #
# this file is part of GEOCUBIT #
# #
# Created by Emanuele Casarotti #
@@ -113,10 +113,8 @@
#
#############################################################################
-
import cubit
-
class mtools(object):
"""docstring for ciao"""
def __init__(self,frequency,list_surf,list_vp):
@@ -289,7 +287,7 @@
elif dot < 0:
return nodes[0],nodes[3],nodes[2],nodes[1]
else:
- print 'error, dot=0', axb,normal,dot,p0,p1,p2
+ print 'error: surface normal, dot=0', axb,normal,dot,p0,p1,p2
def mesh_analysis(self,frequency):
from sets import Set
cubit.cmd('set info off')
@@ -350,14 +348,15 @@
self.freename='free_surface_file'
self.recname='STATIONS'
self.face='QUAD4'
+ self.face2='SHELL4'
self.hex='HEX8'
self.edge='BAR2'
self.topo='face_topo'
self.rec='receivers'
- self.block_definition()
self.ngll=5
self.percent_gll=0.172
self.point_wavelength=5
+ self.block_definition()
cubit.cmd('compress')
def __repr__(self):
pass
@@ -371,9 +370,10 @@
blocks=cubit.get_block_id_list()
for block in blocks:
name=cubit.get_exodus_entity_name('block',block)
- ty=cubit.get_block_element_type(block)
- print block,name,blocks,ty,self.hex,self.face
- if ty == self.hex:
+ type=cubit.get_block_element_type(block)
+ print block,name,blocks,type,self.hex,self.face
+ # block has hexahedral elements (HEX8)
+ if type == self.hex:
flag=None
vel=None
vs=None
@@ -381,15 +381,19 @@
q=0
ani=0
# material domain id
- if name == "acoustic" :
+ if name.find("acoustic") >= 0 :
imaterial = 1
- elif name == "elastic" :
+ elif name.find("elastic") >= 0 :
imaterial = 2
- elif name == "poroelastic" :
+ elif name.find("poroelastic") >= 0 :
imaterial = 3
else :
imaterial = 0
- #
+ print "block: ",name
+ print " could not find appropriate material for this block..."
+ print ""
+ break
+
nattrib=cubit.get_block_attribute_count(block)
if nattrib != 0:
# material flag:
@@ -442,14 +446,28 @@
elif flag==0:
par=tuple([imaterial,flag,name])
material[block]=par
- elif ty == self.face: #Stacey condition, we need hex here for pml
+ elif (type == self.face) or (type == self.face2) :
+ # block has surface elements (QUAD4 or SHELL4)
block_bc_flag.append(4)
block_bc.append(block)
bc[block]=4 #face has connectivity = 4
if name == self.topo: topography_face=block
else:
- print 'blocks no properly defined',ty
- return None, None,None,None,None,None,None,None
+ # block elements differ from HEX8/QUAD4/SHELL4
+ print '****************************************'
+ print 'block not properly defined:'
+ print ' name:',name
+ print ' type:',type
+ print
+ print 'please check your block definitions!'
+ print
+ print 'only supported types are:'
+ print ' HEX8 for volumes'
+ print ' QUAD4 for surface'
+ print ' SHELL4 for surface'
+ print '****************************************'
+ continue
+
nsets=cubit.get_nodeset_id_list()
if len(nsets) == 0: self.receivers=None
for nset in nsets:
@@ -468,7 +486,8 @@
self.bc=bc
self.topography=topography_face
except:
- print 'blocks no properly defined'
+ print '****************************************'
+ print 'sorry, no blocks or blocks not properly defined'
print block_mat
print block_flag
print block_bc
@@ -476,8 +495,9 @@
print material
print bc
print topography
+ print '****************************************'
def mat_parameter(self,properties):
- #TODO: material property acoustic/elastic/poroelastic ? .... where?
+ #note: material property acoustic/elastic/poroelastic are defined by the block's name
print "#material properties:"
print properties
imaterial=properties[0]
@@ -558,22 +578,23 @@
nodecoord.close()
print 'Ok'
def free_write(self,freename=None):
+ # free surface
cubit.cmd('set info off')
cubit.cmd('set echo off')
cubit.cmd('set journal off')
from sets import Set
normal=(0,0,1)
if not freename: freename=self.freename
+ # writes free surface file
+ print 'Writing '+freename+'.....'
freehex=open(freename,'w')
- print 'Writing '+freename+'.....'
- #
- #
+ # searches block definition with name face_topo
for block,flag in zip(self.block_bc,self.block_bc_flag):
if block == self.topography:
name=cubit.get_exodus_entity_name('block',block)
- print name,block
+ print ' block name:',name,'id:',block
quads_all=cubit.get_block_faces(block)
- print 'face = ',len(quads_all)
+ print ' face = ',len(quads_all)
dic_quads_all=dict(zip(quads_all,quads_all))
freehex.write('%10i\n' % len(quads_all))
list_hex=cubit.parse_cubit_list('hex','all')
@@ -587,11 +608,12 @@
txt='%10i %10i %10i %10i %10i\n' % (h,nodes_ok[0],\
nodes_ok[1],nodes_ok[2],nodes_ok[3])
freehex.write(txt)
- freehex.close()
+ freehex.close()
print 'Ok'
cubit.cmd('set info on')
cubit.cmd('set echo on')
def abs_write(self,absname=None):
+ # absorbing boundaries
import re
cubit.cmd('set info off')
cubit.cmd('set echo off')
@@ -599,7 +621,7 @@
from sets import Set
if not absname: absname=self.absname
#
- #
+ # loops through all block definitions
list_hex=cubit.parse_cubit_list('hex','all')
for block,flag in zip(self.block_bc,self.block_bc_flag):
if block != self.topography:
@@ -607,33 +629,31 @@
print name,block
absflag=False
if re.search('xmin',name):
- print 'xmin'
- abshex_local=open(absname+'_xmin','w')
+ filename=absname+'_xmin'
normal=(-1,0,0)
elif re.search('xmax',name):
- print "xmax"
- abshex_local=open(absname+'_xmax','w')
+ filename=absname+'_xmax'
normal=(1,0,0)
elif re.search('ymin',name):
- print "ymin"
- abshex_local=open(absname+'_ymin','w')
+ filename=absname+'_ymin'
normal=(0,-1,0)
elif re.search('ymax',name):
- print "ymax"
- abshex_local=open(absname+'_ymax','w')
+ filename=absname+'_ymax'
normal=(0,1,0)
elif re.search('bottom',name):
- print "bottom"
- abshex_local=open(absname+'_bottom','w')
+ filename=absname+'_bottom'
normal=(0,0,-1)
- elif re.search('abs',name):
- print "abs all - no implemented yet"
- absflag=True
- abshex_local=open(absname,'w')
- #
- #
+ elif re.search('abs',name):
+ print " ...face_abs - not used so far..."
+ continue
+ else:
+ continue
+ # opens file
+ print 'Writing '+filename+'.....'
+ abshex_local=open(filename,'w')
+ # gets face elements
quads_all=cubit.get_block_faces(block)
- dic_quads_all=dict(zip(quads_all,quads_all))
+ dic_quads_all=dict(zip(quads_all,quads_all))
abshex_local.write('%10i\n' % len(quads_all))
#command = "group 'list_hex' add hex in face "+str(quads_all)
#command = command.replace("["," ").replace("]"," ").replace("("," ").replace(")"," ")
@@ -648,6 +668,7 @@
if dic_quads_all.has_key(f):
nodes=cubit.get_connectivity('Face',f)
if not absflag:
+ # checks with specified normal
nodes_ok=self.normal_check(nodes,normal)
txt='%10i %10i %10i %10i %10i\n' % (h,nodes_ok[0],\
nodes_ok[1],nodes_ok[2],nodes_ok[3])
@@ -655,10 +676,55 @@
txt='%10i %10i %10i %10i %10i\n' % (h,nodes[0],\
nodes[1],nodes[2],nodes[3])
abshex_local.write(txt)
+ # closes file
abshex_local.close()
print 'Ok'
cubit.cmd('set info on')
cubit.cmd('set echo on')
+ def surface_write(self,pathdir=None):
+ # optional surfaces, e.g. moho_surface
+ # should be created like e.g.:
+ # > block 10 face in surface 2
+ # > block 10 name 'moho_surface'
+ import re
+ from sets import Set
+ for block in self.block_bc :
+ if block != self.topography:
+ name=cubit.get_exodus_entity_name('block',block)
+ # skips block names like face_abs**, face_topo**
+ if re.search('abs',name):
+ continue
+ elif re.search('topo',name):
+ continue
+ elif re.search('surface',name):
+ filename=pathdir+name+'_file'
+ else:
+ continue
+ # gets face elements
+ print ' surface block name: ',name,'id: ',block
+ quads_all=cubit.get_block_faces(block)
+ print ' face = ',len(quads_all)
+ if len(quads_all) == 0 :
+ continue
+ # writes out surface infos to file
+ print 'Writing '+filename+'.....'
+ surfhex_local=open(filename,'w')
+ dic_quads_all=dict(zip(quads_all,quads_all))
+ # writes number of surface elements
+ surfhex_local.write('%10i\n' % len(quads_all))
+ # writes out element node ids
+ list_hex=cubit.parse_cubit_list('hex','all')
+ for h in list_hex:
+ faces=cubit.get_sub_elements('hex',h,2)
+ for f in faces:
+ if dic_quads_all.has_key(f):
+ nodes=cubit.get_connectivity('Face',f)
+ txt='%10i %10i %10i %10i %10i\n' % (h,nodes[0],\
+ nodes[1],nodes[2],nodes[3])
+ surfhex_local.write(txt)
+ # closes file
+ surfhex_local.close()
+ print 'Ok'
def rec_write(self,recname):
print 'Writing '+self.recname+'.....'
recfile=open(self.recname,'w')
@@ -674,25 +740,36 @@
cubit.cmd('set journal off')
if len(path) != 0:
if path[-1] != '/': path=path+'/'
+ # mesh file
self.mesh_write(path+self.mesh_name)
+ # mesh material
self.material_write(path+self.material_name)
+ # mesh coordinates
self.nodescoord_write(path+self.nodecoord_name)
+ # material definitions
+ self.nummaterial_write(path+self.nummaterial_name)
+ # free surface: face_top
self.free_write(path+self.freename)
+ # absorbing surfaces: abs_***
self.abs_write(path+self.absname)
- self.nummaterial_write(path+self.nummaterial_name)
+ # any other surfaces: ***surface***
+ self.surface_write(path)
+ # receivers
if self.receivers: self.rec_write(path+self.recname)
cubit.cmd('set info on')
cubit.cmd('set echo on')
def export2SESAME(path_exporting_mesh_SPECFEM3D_SESAME):
+ cubit.cmd('set info on')
+ cubit.cmd('set echo on')
sem_mesh=mesh()
sem_mesh.write(path=path_exporting_mesh_SPECFEM3D_SESAME)
-
if __name__ == '__main__':
- path='/Users/emanuele/Desktop/'
- export2SESAME(path)
-
-#TODO: change the algorithm for the abs detection of the hex
-
+ path='MESH/'
+ export2SESAME(path)
+
+# call by:
+# import cubit2specfem3d
+# cubit2specfem3d.export2SESAME('MESH')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -9,7 +9,7 @@
include './scotchf.h'
! number of partitions
- integer :: nparts ! e.g. 4 for partitioning for 4 processes/CPUs
+ integer :: nparts ! e.g. 4 for partitioning for 4 CPUs or 4 processes
! mesh arrays
integer(long) :: nspec
@@ -54,6 +54,11 @@
integer, dimension(:), allocatable :: ibelm_xmin, ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top
integer, dimension(:,:), allocatable :: nodes_ibelm_xmin, nodes_ibelm_xmax, nodes_ibelm_ymin
integer, dimension(:,:), allocatable :: nodes_ibelm_ymax, nodes_ibelm_bottom, nodes_ibelm_top
+
+ ! moho surface (optional)
+ integer :: nspec2D_moho
+ integer, dimension(:), allocatable :: ibelm_moho
+ integer, dimension(:,:), allocatable :: nodes_ibelm_moho
character(len=256) :: prname
@@ -64,7 +69,6 @@
double precision, dimension(SCOTCH_STRATDIM) :: scotchstrat
character(len=256), parameter :: scotch_strategy='b{job=t,map=t,poli=S,sep=h{pass=30}}'
integer :: ierr,idummy
- !integer :: i
!pll
double precision , dimension(:,:), allocatable :: mat_prop
@@ -72,8 +76,8 @@
character (len=30), dimension(:,:), allocatable :: undef_mat_prop
! default mesh file directory
- character(len=256) :: localpath_name ! './OUTPUT_FILES'
- character(len=256) :: outputpath_name ! './OUTPUT_FILES'
+ character(len=256) :: localpath_name
+ character(len=256) :: outputpath_name
integer :: q_flag,aniso_flag,idomain_id
double precision :: vp,vs,rho
@@ -365,6 +369,24 @@
close(98)
print*, ' nspec2D_top = ', nspec2D_top
+ ! reads in moho_surface boundary files (optional)
+ open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/moho_surface_file', &
+ status='old', form='formatted',iostat=ierr)
+ if( ierr /= 0 ) then
+ nspec2D_moho = 0
+ else
+ read(98,*) nspec2D_moho
+ endif
+ allocate(ibelm_moho(nspec2D_moho))
+ allocate(nodes_ibelm_moho(4,nspec2D_moho))
+ do ispec2D = 1,nspec2D_moho
+ ! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
+ read(98,*) ibelm_moho(ispec2D), nodes_ibelm_moho(1,ispec2D), nodes_ibelm_moho(2,ispec2D), &
+ nodes_ibelm_moho(3,ispec2D), nodes_ibelm_moho(4,ispec2D)
+ end do
+ close(98)
+ if( nspec2D_moho > 0 ) print*, ' nspec2D_moho = ', nspec2D_moho
+
end subroutine read_mesh_files
!----------------------------------------------------------------------------------------------
@@ -499,7 +521,13 @@
! call acoustic_elastic_repartitioning (nspec, nnodes, elmnts, &
! count_def_mat, mat(1,:) , mat_prop, &
! sup_neighbour, nsize, &
- ! nproc, part, nfaces_coupled, faces_coupled)
+ ! nparts, part, nfaces_coupled, faces_coupled)
+
+ ! re-partitioning puts moho-surface coupled elements into same partition
+ call moho_surface_repartitioning (nspec, nnodes, elmnts, &
+ sup_neighbour, nsize, nparts, part, &
+ nspec2D_moho,ibelm_moho,nodes_ibelm_moho )
+
! local number of each element for each partition
call Construct_glob2loc_elmnts(nspec, part, glob2loc_elmnts,nparts)
@@ -510,13 +538,14 @@
! mpi interfaces
! acoustic/elastic boundaries WILL BE SEPARATED into different MPI partitions
- call Construct_interfaces(nspec, sup_neighbour, part, elmnts, xadj, adjncy, tab_interfaces, &
+ call Construct_interfaces(nspec, sup_neighbour, part, elmnts, &
+ xadj, adjncy, tab_interfaces, &
tab_size_interfaces, ninterfaces, &
nparts)
- !or: acoustic/elastic boundaries will NOT be separated into different MPI partitions
- !call Construct_interfaces_no_acoustic_elastic_separation(nspec, &
- ! sup_neighbour, part, elmnts, xadj, adjncy, tab_interfaces, &
+ !or: uncomment if you want acoustic/elastic boundaries NOT to be separated into different MPI partitions
+ !call Construct_interfaces_no_ac_el_sep(nspec, sup_neighbour, part, elmnts, &
+ ! xadj, adjncy, tab_interfaces, &
! tab_size_interfaces, ninterfaces, &
! count_def_mat, mat_prop(3,:), mat(1,:), nparts)
@@ -595,6 +624,12 @@
my_ninterface, my_interfaces, my_nb_interfaces, &
glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
glob2loc_nodes, 2, nparts)
+
+ ! writes out moho surface (optional)
+ call write_moho_surface_database(15, ipart, nspec, &
+ glob2loc_elmnts, glob2loc_nodes_nparts, &
+ glob2loc_nodes_parts, glob2loc_nodes, part, &
+ nspec2D_moho,ibelm_moho,nodes_ibelm_moho)
close(15)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -31,13 +31,12 @@
nnodes_elmnts, nodes_elmnts, &
max_neighbour, ncommonnodes)
-! include './constants_decompose_mesh_SCOTCH.h'
-
integer(long), intent(in) :: nelmnts
integer, intent(in) :: nnodes
integer(long), intent(in) :: nsize
integer(long), intent(in) :: sup_neighbour
- integer, dimension(0:esize*nelmnts-1), intent(in) :: elmnts
+ integer, dimension(0:esize*nelmnts-1), intent(in) :: elmnts
+
integer, dimension(0:nelmnts) :: xadj
integer, dimension(0:sup_neighbour*nelmnts-1) :: adjncy
integer, dimension(0:nnodes-1) :: nnodes_elmnts
@@ -45,6 +44,7 @@
integer, intent(out) :: max_neighbour
integer, intent(in) :: ncommonnodes
+ ! local parameters
integer :: i, j, k, l, m, nb_edges
logical :: is_neighbour
integer :: num_node, n
@@ -96,9 +96,12 @@
end do
if ( .not.is_neighbour ) then
adjncy(nodes_elmnts(k+j*nsize)*sup_neighbour+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))>sup_neighbour) stop 'ERROR : too much neighbours per element, modify the mesh.'
+
adjncy(nodes_elmnts(l+j*nsize)*sup_neighbour+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))>sup_neighbour) stop 'ERROR : too much neighbours per element, modify the mesh.'
end if
@@ -366,13 +369,11 @@
! Elements with undefined material are considered as elastic elements.
!--------------------------------------------------
- subroutine Construct_interfaces_no_acoustic_elastic_separation(nelmnts, &
+ subroutine Construct_interfaces_no_ac_el_sep(nelmnts, &
sup_neighbour, part, elmnts, xadj, adjncy, &
tab_interfaces, tab_size_interfaces, ninterfaces, &
nb_materials, cs_material, num_material,nparts)
-! include './constants_decompose_mesh_SCOTCH.h'
-
integer(long), intent(in) :: nelmnts, sup_neighbour
integer, dimension(0:nelmnts-1), intent(in) :: part
integer, dimension(0:esize*nelmnts-1), intent(in) :: elmnts
@@ -509,15 +510,16 @@
end do
end do
- end subroutine Construct_interfaces_no_acoustic_elastic_separation
+ end subroutine Construct_interfaces_no_ac_el_sep
!--------------------------------------------------
! Write nodes (their coordinates) pertaining to iproc partition in the corresponding Database
!--------------------------------------------------
- subroutine write_glob2loc_nodes_database(IIN_database, iproc, npgeo, nodes_coords, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
- glob2loc_nodes, nnodes, num_phase)
+ subroutine write_glob2loc_nodes_database(IIN_database, iproc, npgeo, &
+ nodes_coords, glob2loc_nodes_nparts, glob2loc_nodes_parts, &
+ glob2loc_nodes, nnodes, num_phase)
integer, intent(in) :: IIN_database
integer, intent(in) :: nnodes, iproc, num_phase
@@ -591,13 +593,14 @@
! Write elements on boundaries (and their four nodes on boundaries) pertaining to iproc partition in the corresponding Database
!--------------------------------------------------
subroutine write_boundaries_database(IIN_database, iproc, nelmnts, nspec2D_xmin, nspec2D_xmax, &
- nspec2D_ymin, nspec2D_ymax, nspec2D_bottom, nspec2D_top, &
- ibelm_xmin, ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top, &
- nodes_ibelm_xmin, nodes_ibelm_xmax, nodes_ibelm_ymin, nodes_ibelm_ymax, nodes_ibelm_bottom, nodes_ibelm_top, &
- glob2loc_elmnts, glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes, part)
+ nspec2D_ymin, nspec2D_ymax, nspec2D_bottom, nspec2D_top, &
+ ibelm_xmin, ibelm_xmax, ibelm_ymin, &
+ ibelm_ymax, ibelm_bottom, ibelm_top, &
+ nodes_ibelm_xmin, nodes_ibelm_xmax, nodes_ibelm_ymin, &
+ nodes_ibelm_ymax, nodes_ibelm_bottom, nodes_ibelm_top, &
+ glob2loc_elmnts, glob2loc_nodes_nparts, &
+ glob2loc_nodes_parts, glob2loc_nodes, part )
-! include './constants_decompose_mesh_SCOTCH.h'
-
integer, intent(in) :: IIN_database
integer, intent(in) :: iproc
integer(long), intent(in) :: nelmnts
@@ -621,10 +624,11 @@
integer, dimension(:), pointer :: glob2loc_nodes
integer, dimension(1:nelmnts) :: part
+ ! local parameters
integer :: i,j
integer :: loc_node1, loc_node2, loc_node3, loc_node4
- integer :: loc_nspec2D_xmin,loc_nspec2D_xmax,loc_nspec2D_ymin,loc_nspec2D_ymax,loc_nspec2D_bottom,loc_nspec2D_top
-
+ integer :: loc_nspec2D_xmin,loc_nspec2D_xmax,loc_nspec2D_ymin, &
+ loc_nspec2D_ymax,loc_nspec2D_bottom,loc_nspec2D_top
! counts number of elements for boundary at xmin, xmax, ymin, ymax, bottom, top in this partition
loc_nspec2D_xmin = 0
@@ -832,7 +836,6 @@
end do
-
end subroutine write_boundaries_database
@@ -1070,6 +1073,82 @@
end subroutine write_interfaces_database
!--------------------------------------------------
+ ! Write elements on surface boundaries (and their four nodes on boundaries)
+ ! pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+ subroutine write_moho_surface_database(IIN_database, iproc, nelmnts, &
+ glob2loc_elmnts, glob2loc_nodes_nparts, &
+ glob2loc_nodes_parts, glob2loc_nodes, part, &
+ nspec2D_moho,ibelm_moho,nodes_ibelm_moho)
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc
+ integer(long), intent(in) :: nelmnts
+
+ integer, dimension(:), pointer :: glob2loc_elmnts
+ integer, dimension(:), pointer :: glob2loc_nodes_nparts
+ integer, dimension(:), pointer :: glob2loc_nodes_parts
+ integer, dimension(:), pointer :: glob2loc_nodes
+ integer, dimension(1:nelmnts) :: part
+
+ integer ,intent(in) :: nspec2D_moho
+ integer ,dimension(nspec2D_moho), intent(in) :: ibelm_moho
+ integer, dimension(4,nspec2D_moho), intent(in) :: nodes_ibelm_moho
+
+ integer :: i,j
+ integer :: loc_node1, loc_node2, loc_node3, loc_node4
+ integer :: loc_nspec2D_moho
+
+ ! counts number of elements for moho surface in this partition
+ ! optional moho
+ loc_nspec2D_moho = 0
+ do i=1,nspec2D_moho
+ if(part(ibelm_moho(i)) == iproc) then
+ loc_nspec2D_moho = loc_nspec2D_moho + 1
+ end if
+ end do
+ ! format: #surface_id, #number of elements
+ write(IIN_database,*) 7, loc_nspec2D_moho
+
+ ! outputs element index and element node indices
+ ! note: assumes that element indices in ibelm_* arrays are in the range from 1 to nspec
+ ! (this is assigned by CUBIT, if this changes the following indexing must be changed as well)
+ ! while glob2loc_elmnts(.) is shifted from 0 to nspec-1 thus
+ ! we need to have the arg of glob2loc_elmnts start at 0 ==> glob2loc_nodes(ibelm_** -1 )
+
+ ! optional moho
+ do i=1,nspec2D_moho
+ if(part(ibelm_moho(i)) == iproc) then
+ do j = glob2loc_nodes_nparts(nodes_ibelm_moho(1,i)-1), glob2loc_nodes_nparts(nodes_ibelm_moho(1,i))-1
+ if (glob2loc_nodes_parts(j) == iproc ) then
+ loc_node1 = glob2loc_nodes(j)+1
+ end if
+ end do
+ do j = glob2loc_nodes_nparts(nodes_ibelm_moho(2,i)-1), glob2loc_nodes_nparts(nodes_ibelm_moho(2,i))-1
+ if (glob2loc_nodes_parts(j) == iproc ) then
+ loc_node2 = glob2loc_nodes(j)+1
+ end if
+ end do
+ do j = glob2loc_nodes_nparts(nodes_ibelm_moho(3,i)-1), glob2loc_nodes_nparts(nodes_ibelm_moho(3,i))-1
+ if (glob2loc_nodes_parts(j) == iproc ) then
+ loc_node3 = glob2loc_nodes(j)+1
+ end if
+ end do
+ do j = glob2loc_nodes_nparts(nodes_ibelm_moho(4,i)-1), glob2loc_nodes_nparts(nodes_ibelm_moho(4,i))-1
+ if (glob2loc_nodes_parts(j) == iproc ) then
+ loc_node4 = glob2loc_nodes(j)+1
+ end if
+ end do
+ write(IIN_database,*) glob2loc_elmnts(ibelm_moho(i)-1)+1, loc_node1, loc_node2, loc_node3, loc_node4
+ end if
+
+ end do
+
+ end subroutine write_moho_surface_database
+
+
+
+ !--------------------------------------------------
! loading : sets weights for acoustic/elastic elements to account for different
! expensive calculations in specfem simulations
!--------------------------------------------------
@@ -1140,13 +1219,10 @@
integer, intent(in) :: nnodes, nproc, nb_materials
integer(long), intent(in) :: sup_neighbour,nsize
- !double precision, dimension(nb_materials), intent(in) :: phi_material
integer, dimension(1:nelmnts), intent(in) :: num_material
double precision, dimension(6,nb_materials),intent(in) :: mat_prop
- !integer, dimension(:), pointer :: elmnts
- !integer, dimension(:), pointer :: part
integer, dimension(0:nelmnts-1) :: part
integer, dimension(0:esize*nelmnts-1) :: elmnts
@@ -1157,10 +1233,6 @@
logical, dimension(nb_materials) :: is_acoustic, is_elastic
! neighbors
- !integer, dimension(:), pointer :: xadj
- !integer, dimension(:), pointer :: adjncy
- !integer, dimension(:), pointer :: nodes_elmnts
- !integer, dimension(:), pointer :: nnodes_elmnts
integer, dimension(:), allocatable :: xadj
integer, dimension(:), allocatable :: adjncy
integer, dimension(:), allocatable :: nnodes_elmnts
@@ -1184,13 +1256,14 @@
enddo
! gets neighbors by 4 common nodes (face)
- allocate(xadj(1:nelmnts+1))
- allocate(adjncy(1:sup_neighbour*nelmnts))
- allocate(nnodes_elmnts(1:nnodes))
- allocate(nodes_elmnts(1:nsize*nnodes))
+ allocate(xadj(0:nelmnts))
+ allocate(adjncy(0:sup_neighbour*nelmnts-1))
+ allocate(nnodes_elmnts(0:nnodes-1))
+ allocate(nodes_elmnts(0:nsize*nnodes-1))
!call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,4)
- call mesh2dual_ncommonnodes(nelmnts, nnodes, nsize, sup_neighbour, elmnts, xadj, adjncy, nnodes_elmnts, &
- nodes_elmnts, max_neighbour, 4)
+ call mesh2dual_ncommonnodes(nelmnts, nnodes, nsize, sup_neighbour, &
+ elmnts, xadj, adjncy, nnodes_elmnts, &
+ nodes_elmnts, max_neighbour, 4)
! counts coupled elements
nfaces_coupled = 0
@@ -1241,7 +1314,156 @@
end subroutine acoustic_elastic_repartitioning
+ !--------------------------------------------------
+ ! Repartitioning : two coupled moho surface elements are transfered to the same partition
+ !--------------------------------------------------
+ subroutine moho_surface_repartitioning (nelmnts, nnodes, elmnts, &
+ sup_neighbour, nsize, nproc, part, &
+ nspec2D_moho,ibelm_moho,nodes_ibelm_moho)
+ implicit none
+
+ ! number of (spectral) elements ( <-> nspec )
+ integer(long),intent(in) :: nelmnts
+
+ ! number of (global) nodes, number or processes
+ integer, intent(in) :: nnodes, nproc
+
+ ! maximum number of neighours and max number of elements-that-contain-the-same-node
+ integer(long), intent(in) :: sup_neighbour,nsize
+
+ ! partition index on each element
+ integer, dimension(0:nelmnts-1) :: part
+
+ ! mesh element indexing
+ ! ( elmnts(esize,nspec) )
+ integer, dimension(0:esize*nelmnts-1) :: elmnts
+
+ ! moho surface
+ integer ,intent(in) :: nspec2D_moho
+ integer ,dimension(nspec2D_moho), intent(in) :: ibelm_moho
+ integer, dimension(4,nspec2D_moho), intent(in) :: nodes_ibelm_moho
+
+ ! local parameters
+ integer :: nfaces_coupled
+ integer, dimension(:,:), pointer :: faces_coupled
+
+ logical, dimension(:),allocatable :: is_moho,node_is_moho
+
+ ! for neighbors
+ integer, dimension(:), allocatable :: xadj
+ integer, dimension(:), allocatable :: adjncy
+ integer, dimension(:), allocatable :: nnodes_elmnts
+ integer, dimension(:), allocatable :: nodes_elmnts
+ integer :: max_neighbour
+
+ integer :: i, j, iface, inode, ispec2D, counter
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ ! temporary flag arrays
+ allocate( is_moho(0:nelmnts-1)) ! element ids start from 0
+ allocate( node_is_moho(0:nnodes-1) ) ! node ids start from 0
+ is_moho(:) = .false.
+ node_is_moho(:) = .false.
+
+ ! sets moho flags for known elements
+ do ispec2D = 1, nspec2D_moho
+ ! note: assumes that element indices in ibelm_* arrays are in the range from 1 to nspec
+ el = ibelm_moho(ispec2D) - 1
+ is_moho(el) = .true.
+
+ ! sets node flags
+ do j=1,4
+ ! note: assumes that node indices in nodes_ibelm_* arrays are in the range from 1 to nodes
+ inode = nodes_ibelm_moho(j,ispec2D) - 1
+ node_is_moho(inode) = .true.
+ enddo
+ enddo
+
+ ! checks if element has moho surface
+ do el = 0, nelmnts-1
+ if( is_moho(el) ) cycle
+
+ ! loops over all element corners
+ counter = 0
+ do i=0,esize-1
+ ! note: assumes that node indices in elmnts array are in the range from 0 to nodes-1
+ inode = elmnts(el*esize+i)
+ if( node_is_moho(inode) ) counter = counter + 1
+ enddo
+
+ ! sets flag if it has a surface
+ if( counter == 4 ) is_moho(el) = .true.
+ enddo
+
+ ! statistics output
+ counter = 0
+ do el=0, nelmnts-1
+ if ( is_moho(el) ) counter = counter + 1
+ enddo
+ print*,' moho elements = ',counter
+
+ ! gets neighbors by 4 common nodes (face)
+ allocate(xadj(0:nelmnts)) ! contains number of adjacent elements (neighbours)
+ allocate(adjncy(0:sup_neighbour*nelmnts-1)) ! contains all element id indices of adjacent elements
+ allocate(nnodes_elmnts(0:nnodes-1))
+ allocate(nodes_elmnts(0:nsize*nnodes-1))
+
+ call mesh2dual_ncommonnodes(nelmnts, nnodes, nsize, sup_neighbour, &
+ elmnts, xadj, adjncy, nnodes_elmnts, &
+ nodes_elmnts, max_neighbour, 4)
+
+ ! counts coupled elements
+ nfaces_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_moho(el) ) then
+ do el_adj = xadj(el), xadj(el+1) - 1
+ ! increments counter if it contains face
+ if( is_moho(adjncy(el_adj)) ) nfaces_coupled = nfaces_coupled + 1
+ enddo
+ endif
+ enddo
+
+ ! coupled elements
+ allocate(faces_coupled(2,nfaces_coupled))
+
+ ! stores elements indices
+ nfaces_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_moho(el) ) then
+ do el_adj = xadj(el), xadj(el+1) - 1
+ if ( is_moho(adjncy(el_adj)) ) then
+ nfaces_coupled = nfaces_coupled + 1
+ faces_coupled(1,nfaces_coupled) = el
+ faces_coupled(2,nfaces_coupled) = adjncy(el_adj)
+ endif
+ enddo
+ endif
+ enddo
+
+ ! puts coupled elements into same partition
+ do i = 1, nfaces_coupled*nproc
+ is_repartitioned = .false.
+ do iface = 1, nfaces_coupled
+ if ( part(faces_coupled(1,iface)) /= part(faces_coupled(2,iface)) ) then
+ ! coupled moho elements are in different partitions
+ if ( part(faces_coupled(1,iface)) < part(faces_coupled(2,iface)) ) then
+ part(faces_coupled(2,iface)) = part(faces_coupled(1,iface))
+ else
+ part(faces_coupled(1,iface)) = part(faces_coupled(2,iface))
+ endif
+ is_repartitioned = .true.
+ endif
+ enddo
+ if ( .not. is_repartitioned ) then
+ exit
+ endif
+ enddo
+
+ end subroutine moho_surface_repartitioning
+
+
end module part_decompose_mesh_SCOTCH
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -32,15 +32,14 @@
use specfem_par_acoustic
use specfem_par_elastic
implicit none
-
-! detecting surface points/elements (based on valence check on NGLL points) for external mesh
-
+ ! for mesh surface
allocate(ispec_is_surface_external_mesh(NSPEC_AB))
allocate(iglob_is_surface_external_mesh(NGLOB_AB))
-! allocate(valence_external_mesh(NGLOB_AB))
- if (.not. RECVS_CAN_BE_BURIED_EXT_MESH .or. EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) then
+! determines model surface
+ if (.not. RECVS_CAN_BE_BURIED_EXT_MESH .or. &
+ EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) then
! returns surface points/elements
! in ispec_is_surface_external_mesh / iglob_is_surface_external_mesh and
@@ -57,9 +56,9 @@
endif
! takes cross-section surfaces instead
- if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
- if( PLOT_CROSS_SECTIONS ) then
- call detect_surface_cross_section(NPROC,NGLOB_AB,NSPEC_AB,ibool,&
+ if( (EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) &
+ .and. PLOT_CROSS_SECTIONS ) then
+ call detect_surface_cross_section(NPROC,NGLOB_AB,NSPEC_AB,ibool,&
ispec_is_surface_external_mesh, &
iglob_is_surface_external_mesh, &
nfaces_surface_ext_mesh, &
@@ -70,10 +69,9 @@
ibool_interfaces_ext_mesh,&
CROSS_SECTION_X,CROSS_SECTION_Y,CROSS_SECTION_Z, &
xstore,ystore,zstore,myrank)
- endif
endif
- ! takes number of faces for top, free surface only
+! takes number of faces for top, free surface only
if( MOVIE_SURFACE .or. CREATE_SHAKEMAP ) then
nfaces_surface_ext_mesh = num_free_surface_faces
! face corner indices
@@ -87,7 +85,7 @@
iorderj(4) = NGLLY
endif
- ! handles movies and shakemaps
+! handles movies and shakemaps
if( EXTERNAL_MESH_MOVIE_SURFACE .or. &
EXTERNAL_MESH_CREATE_SHAKEMAP .or. &
MOVIE_SURFACE .or. &
@@ -95,10 +93,15 @@
call setup_movie_meshes()
endif
+! stores wavefields for whole volume
if (MOVIE_VOLUME) then
+ ! acoustic
if( ACOUSTIC_SIMULATION .or. ELASTIC_SIMULATION ) then
- allocate(velocity_movie(NDIM,NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(velocity_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(velocity_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(velocity_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
endif
+ ! elastic only
if( ELASTIC_SIMULATION ) then
allocate(div(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(curl_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
@@ -111,43 +114,10 @@
endif
endif
- ! handles cross-section gif image
+! initializes cross-section gif image
if( PNM_GIF_IMAGE ) then
call write_PNM_GIF_initialize()
endif
-
-! obsolete...
-! allocate files to save movies and shaking map
-! if(MOVIE_SURFACE .or. CREATE_SHAKEMAP) then
-! if (USE_HIGHRES_FOR_MOVIES) then
-! !nmovie_points = NGLLX * NGLLY * NSPEC2D_TOP
-! nmovie_points = NGLLX * NGLLY * num_free_surface_faces
-! else
-! !nmovie_points = NGNOD2D * NSPEC2D_TOP
-! nmovie_points = NGNOD2D * num_free_surface_faces
-! endif
-! allocate(store_val_x(nmovie_points))
-! allocate(store_val_y(nmovie_points))
-! allocate(store_val_z(nmovie_points))
-! allocate(store_val_ux(nmovie_points))
-! allocate(store_val_uy(nmovie_points))
-! allocate(store_val_uz(nmovie_points))
-! allocate(store_val_norm_displ(nmovie_points))
-! allocate(store_val_norm_veloc(nmovie_points))
-! allocate(store_val_norm_accel(nmovie_points))
-!
-! allocate(store_val_x_all(nmovie_points,0:NPROC-1))
-! allocate(store_val_y_all(nmovie_points,0:NPROC-1))
-! allocate(store_val_z_all(nmovie_points,0:NPROC-1))
-! allocate(store_val_ux_all(nmovie_points,0:NPROC-1))
-! allocate(store_val_uy_all(nmovie_points,0:NPROC-1))
-! allocate(store_val_uz_all(nmovie_points,0:NPROC-1))
-!
-! ! to compute max of norm for shaking map
-! store_val_norm_displ(:) = -1.
-! store_val_norm_veloc(:) = -1.
-! store_val_norm_accel(:) = -1.
-! endif
!!!! NL NL REGOLITH : runs at cines for asteroid simulations. Elements in contact with surface are part of the regolith layer.
@@ -226,7 +196,7 @@
!!!!!!!!!! DK DK endif
- end subroutine
+ end subroutine detect_mesh_surfaces
!!!! NL NL REGOLITH
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -257,21 +257,19 @@
allocate(valence_external_mesh(nglob),ispec_has_points(nspec),stat=ier)
if( ier /= 0 ) stop 'error allocate valence array'
-! initialize surface indices
- ispec_is_surface_external_mesh(:) = .false.
- iglob_is_surface_external_mesh(:) = .false.
-
- valence_external_mesh(:) = 0
- ispec_has_points(:) = .false.
-
! an estimation of the minimum distance between global points (for an element width)
mindist = minval( (xstore(ibool(1,3,3,:)) - xstore(ibool(NGLLX,3,3,:)))**2 &
+ (ystore(ibool(1,3,3,:)) - ystore(ibool(NGLLX,3,3,:)))**2 &
+ (zstore(ibool(1,3,3,:)) - zstore(ibool(NGLLX,3,3,:)))**2 )
mindist = sqrt(mindist)
+
+! initialize surface indices
+ ispec_is_surface_external_mesh(:) = .false.
+ iglob_is_surface_external_mesh(:) = .false.
+ nfaces_surface_ext_mesh = 0
+ valence_external_mesh(:) = 0
! sets valence value to one corresponding to process rank for points on cross-sections
- count = 0
do ispec = 1, nspec
do k = 1, NGLLZ
do j = 1, NGLLY
@@ -282,24 +280,18 @@
if( abs( xstore(iglob) - x_section ) < 0.2*mindist ) then
! sets valence to 1 for points on cross-sections
valence_external_mesh(iglob) = myrank+1
- count = count + 1
- ispec_has_points(ispec) = .true.
endif
! y cross-section
if( abs( ystore(iglob) - y_section ) < 0.2*mindist ) then
! sets valence to 1 for points on cross-sections
valence_external_mesh(iglob) = myrank+1
- count = count + 1
- ispec_has_points(ispec) = .true.
endif
! z cross-section
if( abs( zstore(iglob) - z_section ) < 0.2*mindist ) then
! sets valence to 1 for points on cross-sections
valence_external_mesh(iglob) = myrank+1
- count = count + 1
- ispec_has_points(ispec) = .true.
endif
enddo
@@ -316,6 +308,7 @@
! determines spectral elements containing surface points
! (only counts element outer faces, no planes inside element)
+ ispec_has_points(:) = .false.
count = 0
do ispec = 1, nspec
@@ -627,7 +620,8 @@
ispec_is_image_surface(:) = .false.
iglob_is_image_surface(:) = .false.
valence_external_mesh(:) = 0
-
+ num_iglob_image_surface = 0
+
! an estimation of the minimum distance between global points
mindist = minval( (xstore(ibool(1,1,1,:)) - xstore(ibool(2,1,1,:)))**2 &
+ (ystore(ibool(1,1,1,:)) - ystore(ibool(2,1,1,:)))**2 &
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -29,6 +29,7 @@
use specfem_par
use specfem_par_elastic
+ use specfem_par_acoustic
implicit none
@@ -37,10 +38,21 @@
! save last frame
if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- open(unit=27,file=prname(1:len_trim(prname))//'save_forward_arrays.bin',status='unknown',form='unformatted')
- write(27) displ
- write(27) veloc
- write(27) accel
+ open(unit=27,file=prname(1:len_trim(prname))//'save_forward_arrays.bin',&
+ status='unknown',form='unformatted')
+
+ if( ACOUSTIC_SIMULATION ) then
+ write(27) potential_acoustic
+ write(27) potential_dot_acoustic
+ write(27) potential_dot_dot_acoustic
+ endif
+
+ if( ELASTIC_SIMULATION ) then
+ write(27) displ
+ write(27) veloc
+ write(27) accel
+ endif
+
if (ATTENUATION) then
write(27) R_xx
write(27) R_yy
@@ -55,41 +67,52 @@
endif
close(27)
+! adjoint simulations
else if (SIMULATION_TYPE == 3) then
- ! rhop, beta, alpha kernels
-! save kernels to binary files
-!! DK DK removed kernels from here because not supported for CUBIT + SCOTCH yet
-
+ ! adjoint kernels
+ call save_adjoint_kernels()
+
endif
- if(ABSORBING_CONDITIONS .and. (SIMULATION_TYPE == 3 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- !if (nspec2D_xmin > 0) close(31)
- !if (nspec2D_xmax > 0) close(32)
- !if (nspec2D_ymin > 0) close(33)
- !if (nspec2D_ymax > 0) close(34)
- !if (NSPEC2D_BOTTOM > 0) close(35)
+! closing source time function file
+ if(PRINT_SOURCE_TIME_FUNCTION .and. myrank == 0) then
+ close(IOSTF)
endif
+
+! stacey absorbing fields will be reconstructed for adjoint simulations
+! using snapshot files of wavefields
+ if( ABSORBING_CONDITIONS ) then
+ ! closes absorbing wavefield saved/to-be-saved by forward simulations
+ if( num_abs_boundary_faces > 0 .and. (SIMULATION_TYPE == 3 .or. &
+ (SIMULATION_TYPE == 1 .and. SAVE_FORWARD)) ) then
+
+ if( ELASTIC_SIMULATION) close(IOABS)
+ if( ACOUSTIC_SIMULATION) close(IOABS_AC)
+
+ endif
+ endif
+! seismograms and source parameter gradients for (pure type=2) adjoint simulation runs
if (nrec_local > 0) then
if (.not. (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3)) then
-! call write_adj_seismograms(myrank,seismograms_d,number_receiver_global, &
-! nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
- call write_adj_seismograms2(myrank,seismograms_eps,number_receiver_global, &
+ ! seismograms
+ call write_adj_seismograms2_to_file(myrank,seismograms_eps,number_receiver_global, &
nrec_local,it,DT,NSTEP,t0,LOCAL_PATH)
+
+ ! source gradients (for sources in elastic domains)
do irec_local = 1, nrec_local
write(outputname,'(a,i5.5)') 'OUTPUT_FILES/src_frechet.',number_receiver_global(irec_local)
open(unit=27,file=trim(outputname),status='unknown')
-!
-! r -> z, theta -> -y, phi -> x
-!
-! Mrr = Mzz
-! Mtt = Myy
-! Mpp = Mxx
-! Mrt = -Myz
-! Mrp = Mxz
-! Mtp = -Mxy
-
+ !
+ ! r -> z, theta -> -y, phi -> x
+ !
+ ! Mrr = Mzz
+ ! Mtt = Myy
+ ! Mpp = Mxx
+ ! Mrt = -Myz
+ ! Mrp = Mxz
+ ! Mtp = -Mxy
write(27,*) Mzz_der(irec_local)
write(27,*) Myy_der(irec_local)
write(27,*) Mxx_der(irec_local)
@@ -104,7 +127,6 @@
endif
endif
-
! close the main output file
if(myrank == 0) then
write(IMAIN,*)
@@ -116,4 +138,4 @@
! synchronize all the processes to make sure everybody has finished
call sync_all()
- end subroutine
\ No newline at end of file
+ end subroutine finalize_simulation
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/flags.guess
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/flags.guess 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/flags.guess 2010-02-23 02:41:02 UTC (rev 16315)
@@ -33,9 +33,9 @@
#FLAGS_CHECK="-O2 -xT -static-intel -r8 -mcmodel=large -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -check nobounds -align sequence -assume byterecl -ftrapuv -fpe0 -ftz -traceback"
fi
if test x"$FLAGS_NO_CHECK" = x; then
-# standard options (leave option -ftz, which is *critical* for performance)
-# add -Winline to get information about routines that are inlined
-# add -vec-report3 to get information about loops that are vectorized or not
+ # standard options (leave option -ftz, which is *critical* for performance)
+ # add -Winline to get information about routines that are inlined
+ # add -vec-report3 to get information about loops that are vectorized or not
#FLAGS_NO_CHECK="-O3 -xP -vec-report0 -e95 -std95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check nobounds -align sequence -assume byterecl -fpe3 -ftz" # -mcmodel=medium
# ifort v 10.1 with these flags shows best performance
@@ -48,12 +48,12 @@
# GNU gfortran
#
if test x"$FLAGS_NO_CHECK" = x; then
-# works with: GNU Fortran (GCC) 4.1.2 20080704
+ # works with: GNU Fortran (GCC) 4.1.2 20080704
FLAGS_NO_CHECK="-std=gnu -fimplicit-none -frange-check -O3 -pedantic -pedantic-errors -Waliasing -Wampersand -Wline-truncation -Wsurprising -Wunderflow -fno-trapping-math"
-# FLAGS_NO_CHECK="-std=f95 -fimplicit-none -frange-check -O3 -fmax-errors=10 -pedantic -pedantic-errors -Waliasing -Wampersand -Wcharacter-truncation -Wline-truncation -Wsurprising -Wno-tabs -Wunderflow -fno-trapping-math" # -mcmodel=medium
-# older gfortran syntax
-# FLAGS_NO_CHECK="-std=f95 -fimplicit-none -frange-check -O3 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow -fno-trapping-math" # -mcmodel=medium
+ # FLAGS_NO_CHECK="-std=f95 -fimplicit-none -frange-check -O3 -fmax-errors=10 -pedantic -pedantic-errors -Waliasing -Wampersand -Wcharacter-truncation -Wline-truncation -Wsurprising -Wno-tabs -Wunderflow -fno-trapping-math" # -mcmodel=medium
+ # older gfortran syntax
+ # FLAGS_NO_CHECK="-std=f95 -fimplicit-none -frange-check -O3 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow -fno-trapping-math" # -mcmodel=medium
fi
if test x"$FLAGS_CHECK" = x; then
FLAGS_CHECK="\$(FLAGS_NO_CHECK)" # -fbounds-check
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -193,8 +193,7 @@
! number of spectral elements in each block
integer nspec,npointot
-! parameters needed to store the radii of the grid points
-! integer, dimension(:), allocatable :: idoubling
+! local to global indexing array
integer, dimension(:,:,:,:), allocatable :: ibool
! arrays with the mesh in double precision
@@ -211,15 +210,11 @@
character(len=100) :: topo_file
integer, dimension(:,:), allocatable :: itopo_bathy
-! use integer array to store Moho depth
-! integer imoho_depth(NX_MOHO,NY_MOHO)
-
! timer MPI
double precision, external :: wtime
double precision :: time_start,tCPU
! parameters read from parameter file
- integer :: NPROC_XI,NPROC_ETA
integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,SIMULATION_TYPE
integer :: NSOURCES
@@ -236,7 +231,7 @@
character(len=256) OUTPUT_FILES,LOCAL_PATH
! parameters deduced from parameters read from file
- integer NPROC
+ integer :: NPROC
! static memory size that will be needed by the solver
double precision :: max_static_memory_size,max_static_memory_size_request
@@ -246,24 +241,9 @@
integer NSPEC2D_BOTTOM,NSPEC2D_TOP
-! integer NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX, &
-! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
-
double precision min_elevation,max_elevation
double precision min_elevation_all,max_elevation_all
-! for tapered basement map
-! integer iz_basement
-! double precision z_basement(NX_BASEMENT,NY_BASEMENT)
-! character(len=256) BASEMENT_MAP_FILE
-
-! to filter list of stations
-! integer nrec,nrec_filtered
-! double precision stlat,stlon,stele,stbur
-! character(len=MAX_LENGTH_STATION_NAME) station_name
-! character(len=MAX_LENGTH_NETWORK_NAME) network_name
-! character(len=256) rec_filename!,filtered_rec_filename
-
! for Databases of external meshes
character(len=256) prname
integer :: dummy_node
@@ -290,24 +270,23 @@
integer, dimension(:,:), allocatable :: nodes_ibelm_xmin,nodes_ibelm_xmax, &
nodes_ibelm_ymin, nodes_ibelm_ymax, nodes_ibelm_bottom, nodes_ibelm_top
-
- integer :: ispec2D, boundary_number,j
+ ! absorbing boundary
+ integer :: ispec2D, boundary_number
integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, nspec2D_bottom_ext, nspec2D_top_ext
character (len=30), dimension(:,:), allocatable :: undef_mat_prop
+ ! moho (optional)
+ integer :: nspec2D_moho_ext
+ integer, dimension(:), allocatable :: ibelm_moho
+ integer, dimension(:,:), allocatable :: nodes_ibelm_moho
+
! number of points per spectral element
integer, parameter :: NGLLCUBE = NGLLX * NGLLY * NGLLZ
-! for vectorization of loops
-! integer, parameter :: NGLLCUBE_NDIM = NGLLCUBE * NDIM
integer :: nglob,nglob_total,nspec_total
-! auxiliary variables to generate the mesh
-! integer ix,iy
-
integer,dimension(:),allocatable :: ispec_is_surface_external_mesh,iglob_is_surface_external_mesh
integer :: nfaces_surface_ext_mesh,nfaces_surface_glob_ext_mesh
- integer :: i
end module generate_databases_par
@@ -385,19 +364,20 @@
implicit none
! reads DATA/Par_file
- call read_parameter_file( &
- NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
- UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
- ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
- OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
- MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
- SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
- NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
+ call read_parameter_file( NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
+ OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
+ MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
+ SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
-! checks user input parameters for mesher to run
- if (sizeprocs == 1 .and. (NPROC_XI /= 1 .or. NPROC_ETA /= 1)) then
- stop 'must have NPROC_XI = NPROC_ETA = 1 for a serial run'
+! check that the code is running with the requested nb of processes
+ if(sizeprocs /= NPROC) then
+ write(IMAIN,*) 'error: number of processors supposed to run on: ',NPROC
+ write(IMAIN,*) 'error: number of processors actually run on: ',sizeprocs
+ call exit_MPI(myrank,'wrong number of MPI processes')
endif
! there would be a problem with absorbing boundaries for different NGLLX,NGLLY,NGLLZ values
@@ -412,23 +392,6 @@
! chris -- once the steps in decompose_mesh_SCOTCH are integrated into generate_database.f90,
! NPROC will be known
-! Need to initialize NPROC_AB, put this call back in as a result
-! compute other parameters based upon values read
-! call compute_parameters(NER,NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
-! NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
-! NER_BOTTOM_MOHO,NER_MOHO_16,NER_16_BASEMENT,NER_BASEMENT_SEDIM,NER_SEDIM, &
-! NSPEC_AB,NSPEC2D_A_XI,NSPEC2D_B_XI, &
-! NSPEC2D_A_ETA,NSPEC2D_B_ETA, &
-! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
-! NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NGLOB_AB,USE_REGULAR_MESH)
-
-! check that the code is running with the requested nb of processes
- if(sizeprocs /= NPROC) then
- write(IMAIN,*) 'error: number of processors supposed to run on: ',NPROC
- write(IMAIN,*) 'error: number of processors actually run on: ',sizeprocs
- call exit_MPI(myrank,'wrong number of MPI processes')
- endif
-
if(myrank == 0) then
write(IMAIN,*) 'This is process ',myrank
write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
@@ -571,6 +534,8 @@
implicit none
integer :: num_xmin,num_xmax,num_ymin,num_ymax,num_top,num_bottom,num
+ integer :: num_moho
+ integer :: j
! read databases about external mesh simulation
! global node coordinates
@@ -658,9 +623,6 @@
NSPEC2D_BOTTOM = nspec2D_bottom_ext
NSPEC2D_TOP = nspec2D_top_ext
-! NSPEC2DMAX_XMIN_XMAX = max(nspec2D_xmin,nspec2D_xmax)
-! NSPEC2DMAX_YMIN_YMAX = max(nspec2D_ymin,nspec2D_ymax)
-
allocate(ibelm_xmin(nspec2D_xmin),nodes_ibelm_xmin(4,nspec2D_xmin))
do ispec2D = 1,nspec2D_xmin
read(IIN,*) ibelm_xmin(ispec2D),(nodes_ibelm_xmin(j,ispec2D),j=1,4)
@@ -703,7 +665,6 @@
write(IMAIN,*) ' xmin,xmax: ',num_xmin,num_xmax
write(IMAIN,*) ' ymin,ymax: ',num_ymin,num_ymax
write(IMAIN,*) ' bottom,top: ',num_bottom,num_top
- !write(IMAIN,*) ' xmin_xmax,ymin_ymax: ',NSPEC2DMAX_XMIN_XMAX, NSPEC2DMAX_YMIN_YMAX
endif
call sync_all()
@@ -739,14 +700,36 @@
my_interfaces_ext_mesh(5,ie,num_interface), my_interfaces_ext_mesh(6,ie,num_interface)
enddo
enddo
- close(IIN)
-
+
call sum_all_i(num_interfaces_ext_mesh,num)
if(myrank == 0) then
write(IMAIN,*) ' number of MPI partition interfaces: ',num
endif
call sync_all()
+
+ ! optional moho
+ if( SAVE_MOHO_MESH ) then
+ read(IIN,*,iostat=ier) boundary_number ,nspec2D_moho_ext
+ if( ier /= 0 ) call exit_mpi(myrank,'error reading moho mesh in database')
+
+ if(boundary_number /= 7) stop "Error : invalid database file"
+
+ allocate(ibelm_moho(nspec2D_moho_ext),nodes_ibelm_moho(4,nspec2D_moho_ext))
+ do ispec2D = 1,nspec2D_moho_ext
+ ! format: #element_id #node_id1 #node_id2 #node_id3 #node_id4
+ read(IIN,*) ibelm_moho(ispec2D),(nodes_ibelm_moho(j,ispec2D),j=1,4)
+ end do
+
+ call sum_all_i(nspec2D_moho_ext,num_moho)
+ if(myrank == 0) then
+ write(IMAIN,*) ' moho surfaces: ',num_moho
+ endif
+ call sync_all()
+ endif
+
+ close(IIN)
+
end subroutine gd_read_partition_files
!
@@ -810,7 +793,12 @@
ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO, &
itopo_bathy)
- call sync_all()
+! Moho boundary parameters, 2-D jacobians and normals
+ if( SAVE_MOHO_MESH ) then
+ call create_regions_mesh_save_moho(myrank,nglob,nspec, &
+ nspec2D_moho_ext,ibelm_moho,nodes_ibelm_moho, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh,ibool )
+ endif
! defines global number of nodes in model
NGLOB_AB = nglob
@@ -829,6 +817,8 @@
endif
endif
+
+! clean-up
deallocate(xstore,ystore,zstore)
! make sure everybody is synchronized
@@ -846,8 +836,10 @@
use generate_databases_par
implicit none
+
+ integer :: i
-!--- print number of points and elements in the mesh
+! print number of points and elements in the mesh
call sum_all_i(NGLOB_AB,nglob_total)
call sum_all_i(NSPEC_AB,nspec_total)
call sync_all()
@@ -918,48 +910,6 @@
SIMULATION_TYPE,max_static_memory_size,nfaces_surface_glob_ext_mesh)
endif
-! filters stations file
-! if( myrank == 0 ) then
-! call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS')
-! call get_value_string(filtered_rec_filename, 'solver.STATIONS_FILTERED', 'DATA/STATIONS_FILTERED')
-! get total number of stations
-! open(unit=IIN,file=rec_filename,iostat=ios,status='old',action='read')
-! nrec = 0
-! do while(ios == 0)
-! read(IIN,"(a)",iostat=ios) dummystring
-! if(ios == 0) nrec = nrec + 1
-! enddo
-! close(IIN)
-! filter list of stations, only retain stations that are in the model
-! nrec_filtered = 0
-! open(unit=IIN,file=rec_filename,status='old',action='read')
-! do irec = 1,nrec
-! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
-! if((stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
-! .or. USE_EXTERNAL_MESH) &
-! nrec_filtered = nrec_filtered + 1
-! enddo
-! close(IIN)
-! write(IMAIN,*)
-! write(IMAIN,*) 'there are ',nrec,' stations in file ', trim(rec_filename)
-! write(IMAIN,*) 'saving ',nrec_filtered,' stations inside the model in file ', trim(filtered_rec_filename)
-! write(IMAIN,*) 'excluding ',nrec - nrec_filtered,' stations located outside the model'
-! write(IMAIN,*)
-! if(nrec_filtered < 1) call exit_MPI(myrank,'need at least one station in the model')
-! if(nrec < 1) call exit_MPI(myrank,'need at least one station in the model')
-! open(unit=IIN,file=rec_filename,status='old',action='read')
-! open(unit=IOUT,file=filtered_rec_filename,status='unknown')
-! do irec = 1,nrec
-! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
-! if((stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
-! .or. USE_EXTERNAL_MESH) &
-! write(IOUT,*) station_name(1:len_trim(station_name)),' ',network_name(1:len_trim(network_name)),' ', &
-! sngl(stlat),' ',sngl(stlon), ' ', sngl(stele), ' ', sngl(stbur)
-! enddo
-! close(IIN)
-! close(IOUT)
-! endif ! end of section executed by main process only
-
! elapsed time since beginning of mesh generation
if(myrank == 0) then
tCPU = wtime() - time_start
@@ -980,4 +930,3 @@
call sync_all()
end subroutine gd_finalize
-
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_cmt.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_cmt.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_cmt.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -23,7 +23,7 @@
!
!=====================================================================
- subroutine get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,NSOURCES)
+ subroutine get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,NSOURCES)
implicit none
@@ -33,7 +33,6 @@
double precision sec
double precision, dimension(NSOURCES) :: t_cmt,hdur,lat,long,depth
double precision moment_tensor(6,NSOURCES)
- double precision DT
integer mo,da,julian_day,isource
character(len=5) datasource
@@ -48,73 +47,75 @@
! read source number isource
do isource=1,NSOURCES
-! read header with event information
- read(1,"(a4,i5,i3,i3,i3,i3,f6.2)") datasource,yr,mo,da,ho,mi,sec
- jda=julian_day(yr,mo,da)
+ read(1,"(a256)") string
+ ! skips empty lines
+ do while( len_trim(string) == 0 )
+ read(1,"(a256)") string
+ enddo
+
+ ! read header with event information
+ read(string,"(a4,i5,i3,i3,i3,i3,f6.2)") datasource,yr,mo,da,ho,mi,sec
+ jda=julian_day(yr,mo,da)
-! ignore line with event name
- read(1,"(a)") string
+ ! ignore line with event name
+ read(1,"(a)") string
-! read time shift
- read(1,"(a)") string
- read(string(12:len_trim(string)),*) t_cmt(isource)
+ ! read time shift
+ read(1,"(a)") string
+ read(string(12:len_trim(string)),*) t_cmt(isource)
-! read half duration
- read(1,"(a)") string
- read(string(15:len_trim(string)),*) hdur(isource)
+ ! read half duration
+ read(1,"(a)") string
+ read(string(15:len_trim(string)),*) hdur(isource)
-! read latitude
- read(1,"(a)") string
- read(string(10:len_trim(string)),*) lat(isource)
+ ! read latitude
+ read(1,"(a)") string
+ read(string(10:len_trim(string)),*) lat(isource)
-! read longitude
- read(1,"(a)") string
- read(string(11:len_trim(string)),*) long(isource)
+ ! read longitude
+ read(1,"(a)") string
+ read(string(11:len_trim(string)),*) long(isource)
-! read depth
- read(1,"(a)") string
- read(string(7:len_trim(string)),*) depth(isource)
+ ! read depth
+ read(1,"(a)") string
+ read(string(7:len_trim(string)),*) depth(isource)
-! read Mrr
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(1,isource)
+ ! read Mrr
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(1,isource)
-! read Mtt
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(2,isource)
+ ! read Mtt
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(2,isource)
-! read Mpp
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(3,isource)
+ ! read Mpp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(3,isource)
-! read Mrt
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(4,isource)
+ ! read Mrt
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(4,isource)
-! read Mrp
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(5,isource)
+ ! read Mrp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(5,isource)
-! read Mtp
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) moment_tensor(6,isource)
+ ! read Mtp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(6,isource)
-! null half-duration indicates a Heaviside
-! replace with very short error function
- if(hdur(isource) < 5. * DT) hdur(isource) = 5. * DT
-
enddo
close(1)
-!
-! scale the moment tensor
-! CMTSOLUTION file values are in dyne.cm
-! 1 dyne is 1 gram * 1 cm / (1 second)^2
-! 1 Newton is 1 kg * 1 m / (1 second)^2
-! thus 1 Newton = 100,000 dynes
-! therefore 1 dyne.cm = 1e-7 Newton.m
-!
+ !
+ ! scale the moment tensor
+ ! CMTSOLUTION file values are in dyne.cm
+ ! 1 dyne is 1 gram * 1 cm / (1 second)^2
+ ! 1 Newton is 1 kg * 1 m / (1 second)^2
+ ! thus 1 Newton = 100,000 dynes
+ ! therefore 1 dyne.cm = 1e-7 Newton.m
+ !
moment_tensor(:,:) = moment_tensor(:,:) * 1.d-7
end subroutine get_cmt
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -365,7 +365,7 @@
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
! global point locations
- real(kind=CUSTOM_REAL) :: xstore_dummy(nglob),ystore_dummy(nglob),zstore_dummy(nglob)
+ real(kind=CUSTOM_REAL),dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
! face normal
real(kind=CUSTOM_REAL),dimension(NDIM) :: normal
@@ -379,7 +379,7 @@
face_n(1) = (ycoord(2)-ycoord(1))*(zcoord(3)-zcoord(1)) - (zcoord(2)-zcoord(1))*(ycoord(3)-ycoord(1))
face_n(2) = - (xcoord(2)-xcoord(1))*(zcoord(3)-zcoord(1)) + (zcoord(2)-zcoord(1))*(xcoord(3)-xcoord(1))
face_n(3) = (xcoord(2)-xcoord(1))*(ycoord(3)-ycoord(1)) - (ycoord(2)-ycoord(1))*(xcoord(3)-xcoord(1))
- tmp = sqrt( face_n(1)**2 + face_n(2)**2 + face_n(3)**2 )
+ tmp = sqrt( face_n(1)*face_n(1) + face_n(2)*face_n(2) + face_n(3)*face_n(3) )
if( abs(tmp) < TINYVAL ) then
print*,'error get face normal: length',tmp
print*,'normal:',face_n(:)
@@ -433,4 +433,106 @@
endif
!print*,'face ',iface,'scalarproduct:',tmp
-end subroutine get_element_face_normal
+end subroutine get_element_face_normal
+
+!
+!----
+!
+
+subroutine get_element_face_normal_idirect(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal,idirect)
+
+! returns direction of normal:
+! idirect = 1 to point outwards of/away from element
+! idirect = 2 to point into element
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: ispec,iface,nspec,nglob
+
+! face corner locations
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
+
+! index array
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! global point locations
+ real(kind=CUSTOM_REAL) :: xstore_dummy(nglob),ystore_dummy(nglob),zstore_dummy(nglob)
+
+! face normal
+ real(kind=CUSTOM_REAL),dimension(NDIM) :: normal
+
+! direction type
+ integer, intent(out) :: idirect
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: face_n(3),tmp,v_tmp(3)
+ integer :: iglob
+
+! initializes
+ idirect = 0
+
+! determines initial orientation given by three corners on the face
+ ! cross-product of vectors from corner 1 to corner 2 and from corner 1 to corner 3
+ face_n(1) = (ycoord(2)-ycoord(1))*(zcoord(3)-zcoord(1)) - (zcoord(2)-zcoord(1))*(ycoord(3)-ycoord(1))
+ face_n(2) = - (xcoord(2)-xcoord(1))*(zcoord(3)-zcoord(1)) + (zcoord(2)-zcoord(1))*(xcoord(3)-xcoord(1))
+ face_n(3) = (xcoord(2)-xcoord(1))*(ycoord(3)-ycoord(1)) - (ycoord(2)-ycoord(1))*(xcoord(3)-xcoord(1))
+ tmp = sqrt( face_n(1)**2 + face_n(2)**2 + face_n(3)**2 )
+ if( abs(tmp) < TINYVAL ) then
+ print*,'error get face normal: length',tmp
+ print*,'normal:',face_n(:)
+ call exit_mpi(0,'error get element face normal')
+ endif
+ face_n(:) = face_n(:)/tmp
+
+! checks that this normal direction is outwards of element:
+ ! takes additional corner out of face plane and determines scalarproduct to normal
+ select case( iface )
+ case(1) ! opposite to xmin face
+ iglob = ibool(NGLLX,1,1,ispec)
+ case(2) ! opposite to xmax face
+ iglob = ibool(1,1,1,ispec)
+ case(3) ! opposite to ymin face
+ iglob = ibool(1,NGLLY,1,ispec)
+ case(4) ! opposite to ymax face
+ iglob = ibool(1,1,1,ispec)
+ case(5) ! opposite to bottom
+ iglob = ibool(1,1,NGLLZ,ispec)
+ case(6) ! opposite to top
+ iglob = ibool(1,1,1,ispec)
+ end select
+ ! vector from corner 1 to this opposite one
+ v_tmp(1) = xstore_dummy(iglob) - xcoord(1)
+ v_tmp(2) = ystore_dummy(iglob) - ycoord(1)
+ v_tmp(3) = zstore_dummy(iglob) - zcoord(1)
+
+ ! scalarproduct
+ tmp = v_tmp(1)*face_n(1) + v_tmp(2)*face_n(2) + v_tmp(3)*face_n(3)
+
+ ! makes sure normal points outwards, that is points away from this additional corner and scalarproduct is negative
+ if( tmp > 0.0 ) then
+ face_n(:) = - face_n(:)
+ endif
+
+! in case given normal has zero length, exit
+ if( ( normal(1)**2 + normal(2)**2 + normal(3)**2 ) < TINYVAL ) then
+ print*,'problem: given normal is zero'
+ return
+ endif
+
+! otherwise determines orientation of normal
+ tmp = face_n(1)*normal(1) + face_n(2)*normal(2) + face_n(3)*normal(3)
+ if( tmp < 0.0 ) then
+ ! points into element
+ idirect = 2
+ else
+ ! points away from element/ outwards
+ idirect = 1
+ endif
+
+end subroutine get_element_face_normal_idirect
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_global.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_global.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -262,10 +262,10 @@
! mask to sort ibool
integer, dimension(:), allocatable :: mask_ibool
- integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
+ integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
+ integer :: inumber
+ integer:: i,j,k,ispec,ier
- integer :: inumber,i,j,k,ispec,ier
-
! copies original array
allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
allocate(mask_ibool(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_value_parameters.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_value_parameters.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -80,3 +80,18 @@
value_to_get = default_value
end subroutine get_value_string
+
+!--------------------
+
+! dummy subroutine to avoid warnings about variable not used in other subroutines
+ subroutine unused_string(s)
+
+ implicit none
+
+ character(len=*) s
+
+ if (len(s) == 1) continue
+
+ end subroutine unused_string
+
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -31,85 +31,82 @@
use specfem_par_elastic
use specfem_par_acoustic
use specfem_par_poroelastic
+ use specfem_par_movie
implicit none
- integer :: sizeprocs
+ integer :: ier
-! sizeprocs returns number of processes started
-! (should be equal to NPROC)
-! myrank is the rank of each process, between 0 and sizeprocs-1.
-! as usual in MPI, process 0 is in charge of coordinating everything
-! and also takes care of the main output
- call world_size(sizeprocs)
- call world_rank(myrank)
+ ! read the parameter file
+ call read_parameter_file( NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
+ OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
+ MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
+ SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
-! read the parameter file
- call read_parameter_file( &
- NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
- UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
- ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
- OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
- MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
- SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
- NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
-
- if (sizeprocs == 1 .and. (NPROC_XI /= 1 .or. NPROC_ETA /= 1)) then
- stop 'must have NPROC_XI = NPROC_ETA = 1 for a serial run'
- endif
-
-! check that the code is running with the requested nb of processes
- if(sizeprocs /= NPROC) call exit_MPI(myrank,'wrong number of MPI processes')
- !NPROC = sizeprocs
-
-! check simulation type
- if (SIMULATION_TYPE /= 1 .and. SIMULATION_TYPE /= 2 .and. SIMULATION_TYPE /= 3) &
- call exit_mpi(myrank,'SIMULATION_TYPE can only be 1, 2, or 3')
-
-! check simulation parameters
- if (SIMULATION_TYPE /= 1 .and. NSOURCES > 1000) call exit_mpi(myrank, 'for adjoint simulations, NSOURCES <= 1000')
-! LQY -- note: kernel simulations with attenuation turned on has been implemented
-
-! get the base pathname for output files
+ ! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-! check that optimized routines from Deville et al. (2002) can be used
- if( USE_DEVILLE_PRODUCTS) then
- if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
- stop 'optimized routines from Deville et al. (2002) such as mxm_m1_m2_5points can only be used if NGLL = 5'
- endif
+ ! myrank is the rank of each process, between 0 and NPROC-1.
+ ! as usual in MPI, process 0 is in charge of coordinating everything
+ ! and also takes care of the main output
+ call world_rank(myrank)
-! should be implemented now...
-! absorbing surfaces
-! if( ABSORBING_CONDITIONS ) then
-! if( .not. USE_DEVILLE_PRODUCTS ) stop 'ABSORPTION only implemented for USE_DEVILLE_PRODUCTS routine'
-!
-! ! for arbitrary orientation of elements, which face belongs to xmin... -
-! ! does it makes sense to have different NGLLX,NGLLY,NGLLZ?
-! ! there is a problem with absorbing boundaries for faces with different NGLLX,NGLLY,NGLLZ values
-! ! just to be sure for now..
-! if( NGLLX /= NGLLY .and. NGLLY /= NGLLZ ) &
-! stop 'must have NGLLX = NGLLY = NGLLZ'
-! endif
-
- ! exclusive movie flags
- if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
- MOVIE_SURFACE = .false.
- CREATE_SHAKEMAP = .false.
+ ! checks flags
+ call initialize_simulation_check()
+
+ ! open main output file, only written to by process 0
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
+ open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_solver.txt',status='unknown')
+ ! user output
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '**********************************************'
+ write(IMAIN,*) '**** Specfem 3-D Solver - MPI version f90 ****'
+ write(IMAIN,*) '**********************************************'
+ write(IMAIN,*)
+ write(IMAIN,*)
+ if(FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',NPROC-1
+ write(IMAIN,*)
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices'
+ write(IMAIN,*)
+ write(IMAIN,*) ' NDIM = ',NDIM
+ write(IMAIN,*)
+ write(IMAIN,*) ' NGLLX = ',NGLLX
+ write(IMAIN,*) ' NGLLY = ',NGLLY
+ write(IMAIN,*) ' NGLLZ = ',NGLLZ
+ write(IMAIN,*)
+ ! write information about precision used for floating-point operations
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IMAIN,*) 'using single precision for the calculations'
+ else
+ write(IMAIN,*) 'using double precision for the calculations'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',&
+ tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
+ write(IMAIN,*)
endif
-! chris: DT_ext_mesh & NSTE_ext_mesh were in constants.h, I suppressed it, now it is Par_file & read in
-! read_parameters_file.f90
-! DT = DT_ext_mesh
-! NSTEP = NSTEP_ext_mesh
+ ! reads in numbers of spectral elements and points for this process' domain
call create_name_database(prname,myrank,LOCAL_PATH)
- open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
-
+ open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',&
+ action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: could not open database '
+ print*,'path: ',prname(1:len_trim(prname))//'external_mesh.bin'
+ call exit_mpi(myrank,'error opening database')
+ endif
read(27) NSPEC_AB
read(27) NGLOB_AB
close(27)
-! attenuation arrays size
+ ! attenuation arrays size
if( ATTENUATION ) then
!pll
NSPEC_ATTENUATION_AB = NSPEC_AB
@@ -118,7 +115,7 @@
NSPEC_ATTENUATION_AB = 1
endif
-! anisotropy arrays size
+ ! anisotropy arrays size
if( ANISOTROPY ) then
NSPEC_ANISO = NSPEC_AB
else
@@ -126,54 +123,7 @@
NSPEC_ANISO = 1
endif
-! open main output file, only written to by process 0
- if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
- open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_solver.txt',status='unknown')
-
- if(myrank == 0) then
-
- write(IMAIN,*)
- write(IMAIN,*) '**********************************************'
- write(IMAIN,*) '**** Specfem 3-D Solver - MPI version f90 ****'
- write(IMAIN,*) '**********************************************'
- write(IMAIN,*)
- write(IMAIN,*)
-
- if(FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field'
-
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',NPROC,' MPI processes'
- write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
- write(IMAIN,*)
-
- write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi'
- write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta'
- write(IMAIN,*) 'There is a total of ',NPROC,' slices'
-
- write(IMAIN,*)
- write(IMAIN,*) ' NDIM = ',NDIM
- write(IMAIN,*)
- write(IMAIN,*) ' NGLLX = ',NGLLX
- write(IMAIN,*) ' NGLLY = ',NGLLY
- write(IMAIN,*) ' NGLLZ = ',NGLLZ
- write(IMAIN,*)
-
-! write information about precision used for floating-point operations
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IMAIN,*) 'using single precision for the calculations'
- else
- write(IMAIN,*) 'using double precision for the calculations'
- endif
- write(IMAIN,*)
- write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
- write(IMAIN,*)
-
- endif
-
-! check that we have at least one source
- if(NSOURCES < 1) call exit_MPI(myrank,'need at least one source')
-
-! allocate arrays for storing the databases
+ ! allocate arrays for storing the databases
allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(xix(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(xiy(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
@@ -185,53 +135,130 @@
allocate(gammay(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(gammaz(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(jacobian(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
-! mesh node locations
+ ! mesh node locations
allocate(xstore(NGLOB_AB))
allocate(ystore(NGLOB_AB))
allocate(zstore(NGLOB_AB))
-! material properties
-! allocate(rhostore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ ! material properties
allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(mustore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
-! material flags
+ ! material flags
allocate(ispec_is_acoustic(NSPEC_AB))
allocate(ispec_is_elastic(NSPEC_AB))
allocate(ispec_is_poroelastic(NSPEC_AB))
+
+ ! ocean mass matrix
+ allocate(rmass_ocean_load(NGLOB_AB))
-! allocate(not_fully_in_bedrock(NSPEC_AB))
-! allocate(flag_sediments(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
-! allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
-! allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
-! allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
-! allocate(c66store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ ! initializes adjoint simulations
+ call initialize_simulation_adjoint()
-! allocate(idoubling(NSPEC_AB))
-!mass matrix
-! allocate(rmass(NGLOB_AB))
- allocate(rmass_ocean_load(NGLOB_AB))
- !allocate(updated_dof_ocean_load(NGLOB_AB))
+ end subroutine initialize_simulation
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine initialize_simulation_check()
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_poroelastic
+ use specfem_par_movie
+ implicit none
+
+ integer :: sizeprocs
-! attenuation
-! allocate(iflag_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ ! sizeprocs returns number of processes started
+ ! (should be equal to NPROC)
+ call world_size(sizeprocs)
- end subroutine
+ ! check that the code is running with the requested nb of processes
+ if(sizeprocs /= NPROC) call exit_MPI(myrank,'wrong number of MPI processes')
+
+ ! check that we have at least one source
+ if(NSOURCES < 1) call exit_MPI(myrank,'need at least one source')
+
+ ! check simulation type
+ if (SIMULATION_TYPE /= 1 .and. SIMULATION_TYPE /= 2 .and. SIMULATION_TYPE /= 3) &
+ call exit_mpi(myrank,'SIMULATION_TYPE can only be 1, 2, or 3')
+
+ ! check that optimized routines from Deville et al. (2002) can be used
+ if( USE_DEVILLE_PRODUCTS) then
+ if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
+ stop 'Deville et al. (2002) routines can only be used if NGLLX = NGLLY = NGLLZ = 5'
+ endif
+
+ ! absorbing surfaces
+ if( ABSORBING_CONDITIONS ) then
+ ! for arbitrary orientation of elements, which face belongs to xmin,xmax,etc... -
+ ! does it makes sense to have different NGLLX,NGLLY,NGLLZ?
+ ! there is a problem with absorbing boundaries for faces with different NGLLX,NGLLY,NGLLZ values
+ ! just to be sure for now..
+ if( NGLLX /= NGLLY .and. NGLLY /= NGLLZ ) &
+ stop 'ABSORBING_CONDITIONS must have NGLLX = NGLLY = NGLLZ'
+ endif
+
+ ! exclusive movie flags
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
+ if( EXTERNAL_MESH_MOVIE_SURFACE .and. EXTERNAL_MESH_CREATE_SHAKEMAP ) &
+ stop 'EXTERNAL_MESH_MOVIE_SURFACE and EXTERNAL_MESH_MOVIE_SURFACE cannot be both true'
+ if( MOVIE_SURFACE ) &
+ stop 'MOVIE_SURFACE cannot be used when EXTERNAL_MESH_MOVIE_SURFACE or EXTERNAL_MESH_CREATE_SHAKEMAP is true'
+ if( CREATE_SHAKEMAP ) &
+ stop 'CREATE_SHAKEMAP cannot be used when EXTERNAL_MESH_MOVIE_SURFACE or EXTERNAL_MESH_CREATE_SHAKEMAP is true'
+ endif
+
+ end subroutine initialize_simulation_check
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine initialize_simulation_adjoint()
+
+! initialization for ADJOINT simulations
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_poroelastic
+ implicit none
+
+ ! check simulation parameters
+ if (SIMULATION_TYPE /= 1 .and. NSOURCES > 1000) &
+ call exit_mpi(myrank, 'for adjoint simulations, NSOURCES <= 1000')
+
+ ! snapshot file names: ADJOINT attenuation
+ if (ATTENUATION .and. ((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3)) &
+ call create_name_database(prname_Q,myrank,LOCAL_PATH_Q)
+
+ ! number of elements and points for adjoint arrays
+ if( SIMULATION_TYPE == 3 ) then
+ NSPEC_ADJOINT = NSPEC_AB
+ NGLOB_ADJOINT = NGLOB_AB
+ else
+ ! dummy array size
+ NSPEC_ADJOINT = 1
+ NGLOB_ADJOINT = 1
+ endif
+
+ ! strain/attenuation
+ if( ATTENUATION .and. SIMULATION_TYPE == 3 ) then
+ NSPEC_ATT_AND_KERNEL = NSPEC_AB
+ else
+ NSPEC_ATT_AND_KERNEL = 1
+ endif
+
+ ! moho boundary
+ if( SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3 ) then
+ NSPEC_BOUN = NSPEC_AB
+ else
+ NSPEC_BOUN = 1
+ endif
+
+ end subroutine initialize_simulation_adjoint
+
+
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -31,7 +31,7 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
-
+ use specfem_par_movie
implicit none
!
@@ -64,69 +64,44 @@
do it = 1,NSTEP
-! simulation status output and stability check
+ ! simulation status output and stability check
if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
call it_check_stability()
endif
-! update displacement using Newark time scheme
+ ! update displacement using Newark time scheme
call it_update_displacement_scheme()
-! acoustic solver
-! (needs to be done first, before elastic one)
+ ! acoustic solver
+ ! (needs to be done first, before elastic one)
if( ACOUSTIC_SIMULATION ) call compute_forces_acoustic()
-! elastic solver
+ ! elastic solver
if( ELASTIC_SIMULATION ) call compute_forces_elastic()
-! poroelastic solver
+ ! poroelastic solver
if( POROELASTIC_SIMULATION ) stop 'poroelastic simulation not implemented yet'
-! write the seismograms with time shift
+ ! write the seismograms with time shift
if (nrec_local > 0) then
- call it_write_seismograms()
+ call write_seismograms()
endif
-! resetting d/v/a/R/eps for the backward reconstruction with attenuation
+ ! resetting d/v/a/R/eps for the backward reconstruction with attenuation
if (ATTENUATION ) then
call it_store_attenuation_arrays()
- endif ! ATTENUATION
-
-! shakemap creation
- if (EXTERNAL_MESH_CREATE_SHAKEMAP) then
- call it_create_shakemap_em()
endif
-! movie file creation
- if(EXTERNAL_MESH_MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- call it_create_movie_surface_em()
+ ! adjoint simulations: kernels
+ if( SIMULATION_TYPE == 3 ) then
+ call it_update_adjointkernels()
endif
-! save MOVIE on the SURFACE
- if(MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
-
- !stop 'DK DK MOVIE_SURFACE has been removed for now because we need a flag to detect the surface elements'
-
- call it_movie_surface_output_o()
+ ! outputs movie files
+ if( MOVIE_SIMULATION ) then
+ call write_movie_output()
endif
-
-! compute SHAKING INTENSITY MAP
- if(CREATE_SHAKEMAP) then
-
- !stop 'DK DK CREATE_SHAKEMAP has been removed for now because we need a flag to detect the surface elements'
-
- call it_create_shakemap_o()
- endif
-
-! save MOVIE in full 3D MESH
- if(MOVIE_VOLUME .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- call it_movie_volume_output()
- endif
-
-! creates cross-section GIF image
- if(PNM_GIF_IMAGE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0 ) then
- call write_PNM_GIF_create_image()
- endif
+
!
!---- end of time iteration loop
!
@@ -165,12 +140,19 @@
! compute the maximum of the maxima for all the slices using an MPI reduction
call max_all_cr(Usolidnorm,Usolidnorm_all)
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) then
-! b_Usolidnorm = maxval(sqrt(b_displ(1,:)**2 + b_displ(2,:)**2 + b_displ(3,:)**2))
-! call max_all_cr(b_Usolidnorm,b_Usolidnorm_all)
-! endif
+! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ if( ELASTIC_SIMULATION ) then
+ b_Usolidnorm = maxval(sqrt(b_displ(1,:)**2 + b_displ(2,:)**2 + b_displ(3,:)**2))
+ else
+ if( ACOUSTIC_SIMULATION ) then
+ b_Usolidnorm = maxval(abs(b_potential_dot_dot_acoustic(:)))
+ endif
+ endif
+ call max_all_cr(b_Usolidnorm,b_Usolidnorm_all)
+ endif
+! user output
if(myrank == 0) then
write(IMAIN,*) 'Time step # ',it
@@ -189,11 +171,12 @@
write(IMAIN,*) 'Max norm displacement vector U in all slices (m) = ',Usolidnorm_all
else
if( ACOUSTIC_SIMULATION ) then
- write(IMAIN,*) 'Max norm pressure P in all slices (m) = ',Usolidnorm_all
+ write(IMAIN,*) 'Max norm pressure P in all slices (Pa) = ',Usolidnorm_all
endif
endif
-! if (SIMULATION_TYPE == 3) write(IMAIN,*) &
-! 'Max norm displacement vector U (backward) in all slices (m) = ',b_Usolidnorm_all
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) write(IMAIN,*) &
+ 'Max norm U (backward) in all slices = ',b_Usolidnorm_all
! compute estimated remaining simulation time
t_remain = (NSTEP - it) * (tCPU/dble(it))
@@ -235,8 +218,9 @@
write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
write(IOUT,*) 'Max norm displacement vector U in all slices (m) = ',Usolidnorm_all
-! if (SIMULATION_TYPE == 3) write(IOUT,*) &
-! 'Max norm displacement vector U (backward) in all slices (m) = ',b_Usolidnorm_all
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) write(IOUT,*) &
+ 'Max norm U (backward) in all slices = ',b_Usolidnorm_all
close(IOUT)
@@ -245,8 +229,10 @@
! than the greatest possible floating-point number of the machine
if(Usolidnorm_all > STABILITY_THRESHOLD .or. Usolidnorm_all < 0) &
call exit_MPI(myrank,'forward simulation became unstable and blew up')
-! if(SIMULATION_TYPE == 3 .and. (b_Usolidnorm_all > STABILITY_THRESHOLD .or. b_Usolidnorm_all < 0)) &
-! call exit_MPI(myrank,'backward simulation became unstable and blew up')
+ ! adjoint simulations
+ if(SIMULATION_TYPE == 3 .and. (b_Usolidnorm_all > STABILITY_THRESHOLD &
+ .or. b_Usolidnorm_all < 0)) &
+ call exit_MPI(myrank,'backward simulation became unstable and blew up')
endif ! myrank
@@ -290,7 +276,8 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
-
+ use PML_par
+ use PML_par_acoustic
implicit none
! updates acoustic potentials
@@ -300,1207 +287,223 @@
+ deltatsqover2 * potential_dot_dot_acoustic(:)
potential_dot_acoustic(:) = potential_dot_acoustic(:) &
+ deltatover2 * potential_dot_dot_acoustic(:)
- potential_dot_dot_acoustic(:) = 0._CUSTOM_REAL
+ potential_dot_dot_acoustic(:) = 0._CUSTOM_REAL
+
+ ! time marching potentials
+ if(PML) call PML_acoustic_time_march(NSPEC_AB,NGLOB_AB,ibool,&
+ potential_acoustic,potential_dot_acoustic,&
+ deltat,deltatsqover2,deltatover2,&
+ num_PML_ispec,PML_ispec,PML_damping_d,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot,&
+ iglob_is_PML_interface,PML_mask_ibool,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh,&
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC,&
+ ispec_is_acoustic)
endif
! updates elastic displacement and velocity
if( ELASTIC_SIMULATION ) then
displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
- accel(:,:) = 0._CUSTOM_REAL
-
- !! DK DK array not created yet for CUBIT
- ! if (SIMULATION_TYPE == 3) then
- ! b_displ(:,:) = b_displ(:,:) + b_deltat*b_veloc(:,:) + b_deltatsqover2*b_accel(:,:)
- ! b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
- ! b_accel(:,:) = 0._CUSTOM_REAL
- ! endif
+ accel(:,:) = 0._CUSTOM_REAL
endif
-
- end subroutine it_update_displacement_scheme
-
-!=====================================================================
-
- subroutine it_write_seismograms()
-
-! writes the seismograms with time shift
-
- use specfem_par
- use specfem_par_acoustic
- use specfem_par_elastic
- use specfem_par_poroelastic
- implicit none
- ! local parameters
- real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: displ_element,veloc_element
- double precision :: dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd,hlagrange
- integer :: irec_local,irec
- integer :: iglob,ispec,i,j,k
-
- do irec_local = 1,nrec_local
-
-! get global number of that receiver
- irec = number_receiver_global(irec_local)
-
-! perform the general interpolation using Lagrange polynomials
- if(FASTER_RECEIVERS_POINTS_ONLY) then
- ispec = ispec_selected_rec(irec)
- iglob = ibool(nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
- nint(gamma_receiver(irec)),ispec)
-
- ! elastic wave field
- if( ispec_is_elastic(ispec) ) then
- dxd = dble(displ(1,iglob))
- dyd = dble(displ(2,iglob))
- dzd = dble(displ(3,iglob))
- vxd = dble(veloc(1,iglob))
- vyd = dble(veloc(2,iglob))
- vzd = dble(veloc(3,iglob))
- axd = dble(accel(1,iglob))
- ayd = dble(accel(2,iglob))
- azd = dble(accel(3,iglob))
- endif
-
- ! acoustic wave field
- if( ispec_is_acoustic(ispec) ) then
- ! displacement
- call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
- potential_acoustic, displ_element,&
- hprime_xx,hprime_yy,hprime_zz, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- ibool,rhostore)
- ! velocity
- call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
- potential_dot_acoustic, veloc_element,&
- hprime_xx,hprime_yy,hprime_zz, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- ibool,rhostore)
- ! displacement
- dxd = displ_element(1,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
- nint(gamma_receiver(irec)))
- dyd = displ_element(2,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
- nint(gamma_receiver(irec)))
- dzd = displ_element(3,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
- nint(gamma_receiver(irec)))
- ! velocity
- vxd = veloc_element(1,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
- nint(gamma_receiver(irec)))
- vyd = veloc_element(2,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
- nint(gamma_receiver(irec)))
- vzd = veloc_element(3,nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
- nint(gamma_receiver(irec)))
- ! pressure
- axd = - potential_dot_dot_acoustic(iglob)
- ayd = - potential_dot_dot_acoustic(iglob)
- azd = - potential_dot_dot_acoustic(iglob)
- endif ! acoustic
-
- else
-
- dxd = ZERO
- dyd = ZERO
- dzd = ZERO
-
- vxd = ZERO
- vyd = ZERO
- vzd = ZERO
-
- axd = ZERO
- ayd = ZERO
- azd = ZERO
-
- if (SIMULATION_TYPE == 1) then
-
- ispec = ispec_selected_rec(irec)
-
- ! elastic wave field
- if( ispec_is_elastic(ispec) ) then
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- ! receivers are always located at the surface of the mesh
- iglob = ibool(i,j,k,ispec)
-
- hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
-
- ! elastic wave field
- if( ispec_is_elastic(ispec) ) then
- ! save displacement
- dxd = dxd + dble(displ(1,iglob))*hlagrange
- dyd = dyd + dble(displ(2,iglob))*hlagrange
- dzd = dzd + dble(displ(3,iglob))*hlagrange
- ! save velocity
- vxd = vxd + dble(veloc(1,iglob))*hlagrange
- vyd = vyd + dble(veloc(2,iglob))*hlagrange
- vzd = vzd + dble(veloc(3,iglob))*hlagrange
- ! save acceleration
- axd = axd + dble(accel(1,iglob))*hlagrange
- ayd = ayd + dble(accel(2,iglob))*hlagrange
- azd = azd + dble(accel(3,iglob))*hlagrange
- endif
-
- enddo
- enddo
- enddo
- endif
-
- ! acoustic wave field
- if( ispec_is_acoustic(ispec) ) then
- ! displacement vector
- call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
- potential_acoustic, displ_element,&
- hprime_xx,hprime_yy,hprime_zz, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- ibool,rhostore)
- ! velocity vector
- call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
- potential_dot_acoustic, veloc_element,&
- hprime_xx,hprime_yy,hprime_zz, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- ibool,rhostore)
- ! interpolates vector field
- do k= 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
- hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
- ! displacement
- dxd = dxd + hlagrange*displ_element(1,i,j,k)
- dyd = dyd + hlagrange*displ_element(2,i,j,k)
- dzd = dzd + hlagrange*displ_element(3,i,j,k)
- ! velocity
- vxd = vxd + hlagrange*veloc_element(1,i,j,k)
- vyd = vxd + hlagrange*veloc_element(2,i,j,k)
- vzd = vxd + hlagrange*veloc_element(3,i,j,k)
- ! pressure
- axd = axd - hlagrange*potential_dot_dot_acoustic(iglob)
- ayd = ayd - hlagrange*potential_dot_dot_acoustic(iglob)
- azd = azd - hlagrange*potential_dot_dot_acoustic(iglob)
- enddo
- enddo
- enddo
- endif ! acoustic
-
- else if (SIMULATION_TYPE == 2) then
-
- ! adjoint source is placed at receiver
- ispec = ispec_selected_source(irec)
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- iglob = ibool(i,j,k,ispec)
-
- hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
-
- dxd = dxd + dble(displ(1,iglob))*hlagrange
- dyd = dyd + dble(displ(2,iglob))*hlagrange
- dzd = dzd + dble(displ(3,iglob))*hlagrange
- vxd = vxd + dble(veloc(1,iglob))*hlagrange
- vyd = vyd + dble(veloc(2,iglob))*hlagrange
- vzd = vzd + dble(veloc(3,iglob))*hlagrange
- axd = axd + dble(accel(1,iglob))*hlagrange
- ayd = ayd + dble(accel(2,iglob))*hlagrange
- azd = azd + dble(accel(3,iglob))*hlagrange
-
- displ_s(:,i,j,k) = displ(:,iglob)
-
- enddo
- enddo
- enddo
-
- !ispec = ispec_selected_source(irec)
-
- call compute_adj_source_frechet(displ_s,Mxx(irec),Myy(irec),Mzz(irec),Mxy(irec),Mxz(irec),Myz(irec),eps_s,eps_m_s, &
- hxir_store(irec_local,:),hetar_store(irec_local,:),hgammar_store(irec_local,:), &
- hpxir_store(irec_local,:),hpetar_store(irec_local,:),hpgammar_store(irec_local,:),hprime_xx,hprime_yy,hprime_zz, &
- xix(:,:,:,ispec),xiy(:,:,:,ispec),xiz(:,:,:,ispec),etax(:,:,:,ispec),etay(:,:,:,ispec),etaz(:,:,:,ispec), &
- gammax(:,:,:,ispec),gammay(:,:,:,ispec),gammaz(:,:,:,ispec))
-
- stf = comp_source_time_function(dble(NSTEP-it)*DT-t0-t_cmt(irec),hdur_gaussian(irec))
- stf_deltat = stf * deltat
- Mxx_der(irec_local) = Mxx_der(irec_local) + eps_s(1,1) * stf_deltat
- Myy_der(irec_local) = Myy_der(irec_local) + eps_s(2,2) * stf_deltat
- Mzz_der(irec_local) = Mzz_der(irec_local) + eps_s(3,3) * stf_deltat
- Mxy_der(irec_local) = Mxy_der(irec_local) + 2 * eps_s(1,2) * stf_deltat
- Mxz_der(irec_local) = Mxz_der(irec_local) + 2 * eps_s(1,3) * stf_deltat
- Myz_der(irec_local) = Myz_der(irec_local) + 2 * eps_s(2,3) * stf_deltat
-
- sloc_der(:,irec_local) = sloc_der(:,irec_local) + eps_m_s(:) * stf_deltat
-
- else if (SIMULATION_TYPE == 3) then
-
- ispec = ispec_selected_rec(irec)
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- iglob = ibool(i,j,k,ispec)
-
- hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
-
-!! DK DK array not created yet for CUBIT
-! dxd = dxd + dble(b_displ(1,iglob))*hlagrange
-! dyd = dyd + dble(b_displ(2,iglob))*hlagrange
-! dzd = dzd + dble(b_displ(3,iglob))*hlagrange
-! vxd = vxd + dble(b_veloc(1,iglob))*hlagrange
-! vyd = vyd + dble(b_veloc(2,iglob))*hlagrange
-! vzd = vzd + dble(b_veloc(3,iglob))*hlagrange
-! axd = axd + dble(b_accel(1,iglob))*hlagrange
-! ayd = ayd + dble(b_accel(2,iglob))*hlagrange
-! azd = azd + dble(b_accel(3,iglob))*hlagrange
- enddo
- enddo
- enddo
- endif ! SIMULATION_TYPE
-
- endif ! FASTER_RECEIVERS_POINTS_ONLY
-
-! store North, East and Vertical components
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- seismograms_d(:,irec_local,it) = sngl((nu(:,1,irec)*dxd + nu(:,2,irec)*dyd + nu(:,3,irec)*dzd))
- seismograms_v(:,irec_local,it) = sngl((nu(:,1,irec)*vxd + nu(:,2,irec)*vyd + nu(:,3,irec)*vzd))
- seismograms_a(:,irec_local,it) = sngl((nu(:,1,irec)*axd + nu(:,2,irec)*ayd + nu(:,3,irec)*azd))
- else
- seismograms_d(:,irec_local,it) = (nu(:,1,irec)*dxd + nu(:,2,irec)*dyd + nu(:,3,irec)*dzd)
- seismograms_v(:,irec_local,it) = (nu(:,1,irec)*vxd + nu(:,2,irec)*vyd + nu(:,3,irec)*vzd)
- seismograms_a(:,irec_local,it) = (nu(:,1,irec)*axd + nu(:,2,irec)*ayd + nu(:,3,irec)*azd)
+! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ ! acoustic backward fields
+ if( ACOUSTIC_SIMULATION ) then
+ b_potential_acoustic(:) = b_potential_acoustic(:) &
+ + b_deltat * b_potential_dot_acoustic(:) &
+ + b_deltatsqover2 * 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(:) = 0._CUSTOM_REAL
endif
-
- if (SIMULATION_TYPE == 2) seismograms_eps(:,:,irec_local,it) = eps_s(:,:)
-
- enddo ! nrec_local
-
-! write the current or final seismograms
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_SEISMOS) == 0 .or. it == NSTEP) then
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- call write_seismograms(myrank,seismograms_d,number_receiver_global,station_name, &
- network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
- call write_seismograms(myrank,seismograms_v,number_receiver_global,station_name, &
- network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,2)
- call write_seismograms(myrank,seismograms_a,number_receiver_global,station_name, &
- network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,3)
- else
- call write_adj_seismograms(myrank,seismograms_d,number_receiver_global, &
- nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
+ ! elastic backward fields
+ if( ELASTIC_SIMULATION ) then
+ b_displ(:,:) = b_displ(:,:) + b_deltat*b_veloc(:,:) + b_deltatsqover2*b_accel(:,:)
+ b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
+ b_accel(:,:) = 0._CUSTOM_REAL
endif
endif
- end subroutine it_write_seismograms
+! adjoint simulations: moho kernel
+ if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+ ispec2D_moho_top = 0
+ ispec2D_moho_bot = 0
+ endif
-!================================================================
+ end subroutine it_update_displacement_scheme
+!=====================================================================
+
+
subroutine it_store_attenuation_arrays()
! resetting d/v/a/R/eps for the backward reconstruction with attenuation
use specfem_par
use specfem_par_elastic
+ use specfem_par_acoustic
implicit none
if( it > 1 .and. it < NSTEP) then
+ ! adjoint simulatioins
if (SIMULATION_TYPE == 3 .and. mod(NSTEP-it,NSTEP_Q_SAVE) == 0) then
+ ! reads files content
write(outputname,"('save_Q_arrays_',i6.6,'.bin')") NSTEP-it
- open(unit=27,file=trim(prname_Q)//trim(outputname),status='old',action='read',form='unformatted')
-!! DK DK array not created yet for CUBIT
-! read(27) b_displ
-! read(27) b_veloc
-! read(27) b_accel
-! read(27) b_R_xx
-! read(27) b_R_yy
-! read(27) b_R_xy
-! read(27) b_R_xz
-! read(27) b_R_yz
-! read(27) b_epsilondev_xx
-! read(27) b_epsilondev_yy
-! read(27) b_epsilondev_xy
-! read(27) b_epsilondev_xz
-! read(27) b_epsilondev_yz
+ open(unit=27,file=trim(prname_Q)//trim(outputname),status='old',&
+ action='read',form='unformatted')
+ if( ELASTIC_SIMULATION ) then
+ read(27) b_displ
+ read(27) b_veloc
+ read(27) b_accel
+ read(27) b_R_xx
+ read(27) b_R_yy
+ read(27) b_R_xy
+ read(27) b_R_xz
+ read(27) b_R_yz
+ read(27) b_epsilondev_xx
+ read(27) b_epsilondev_yy
+ read(27) b_epsilondev_xy
+ read(27) b_epsilondev_xz
+ read(27) b_epsilondev_yz
+ endif
+ if( ACOUSTIC_SIMULATION ) then
+ read(27) b_potential_acoustic
+ read(27) b_potential_dot_acoustic
+ read(27) b_potential_dot_dot_acoustic
+ endif
close(27)
else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. mod(it,NSTEP_Q_SAVE) == 0) then
+ ! stores files content
write(outputname,"('save_Q_arrays_',i6.6,'.bin')") it
- open(unit=27,file=trim(prname_Q)//trim(outputname),status='unknown',action='write',form='unformatted')
- write(27) displ
- write(27) veloc
- write(27) accel
- write(27) R_xx
- write(27) R_yy
- write(27) R_xy
- write(27) R_xz
- write(27) R_yz
- write(27) epsilondev_xx
- write(27) epsilondev_yy
- write(27) epsilondev_xy
- write(27) epsilondev_xz
- write(27) epsilondev_yz
+ open(unit=27,file=trim(prname_Q)//trim(outputname),status='unknown',&
+ action='write',form='unformatted')
+ if( ELASTIC_SIMULATION ) then
+ write(27) displ
+ write(27) veloc
+ write(27) accel
+ write(27) R_xx
+ write(27) R_yy
+ write(27) R_xy
+ write(27) R_xz
+ write(27) R_yz
+ write(27) epsilondev_xx
+ write(27) epsilondev_yy
+ write(27) epsilondev_xy
+ write(27) epsilondev_xz
+ write(27) epsilondev_yz
+ endif
+ if( ACOUSTIC_SIMULATION ) then
+ write(27) b_potential_acoustic
+ write(27) b_potential_dot_acoustic
+ write(27) b_potential_dot_dot_acoustic
+ endif
close(27)
endif ! SIMULATION_TYPE
endif ! it
end subroutine it_store_attenuation_arrays
-
+
!================================================================
- subroutine it_create_shakemap_em()
+ subroutine it_update_adjointkernels()
-! creation of shapemap file
-
- use specfem_par
- use specfem_par_elastic
- use specfem_par_movie
- implicit none
-
- integer :: ipoin,ispec,iglob,ispec2D
+! kernel calculations
-! initializes arrays for point coordinates
- if (it == 1) then
- store_val_ux_external_mesh(:) = -HUGEVAL
- store_val_uy_external_mesh(:) = -HUGEVAL
- store_val_uz_external_mesh(:) = -HUGEVAL
- do ispec2D = 1,nfaces_surface_ext_mesh
- if (USE_HIGHRES_FOR_MOVIES) then
- do ipoin = 1, NGLLX*NGLLY
- iglob = faces_surface_ext_mesh(ipoin,ispec2D)
- ! x,y,z coordinates
- store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
- store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
- store_val_z_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = zstore(iglob)
- enddo
- else
- do ipoin = 1, 4
- iglob = faces_surface_ext_mesh(ipoin,ispec2D)
- ! x,y,z coordinates
- store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
- store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
- store_val_z_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = zstore(iglob)
- enddo
- endif
- enddo
- endif
-
-! stores displacement, velocity and acceleration amplitudes
- do ispec2D = 1,nfaces_surface_ext_mesh
- ispec = faces_surface_ext_mesh_ispec(ispec2D)
- ! high-resolution
- if (USE_HIGHRES_FOR_MOVIES) then
- do ipoin = 1, NGLLX*NGLLY
- iglob = faces_surface_ext_mesh(ipoin,ispec2D)
- ! saves norm of displacement,velocity and acceleration vector
- if( ispec_is_elastic(ispec) ) then
- ! norm of displacement
- store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
- max(store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
- sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2))
- ! norm of velocity
- store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
- max(store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
- sqrt(veloc(1,iglob)**2 + veloc(2,iglob)**2 + veloc(3,iglob)**2))
- ! norm of acceleration
- store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
- max(store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
- sqrt(accel(1,iglob)**2 + accel(2,iglob)**2 + accel(3,iglob)**2))
- endif
- enddo
- else
- ! low-resolution: only corner points outputted
- do ipoin = 1, 4
- iglob = faces_surface_ext_mesh(ipoin,ispec2D)
- ! saves norm of displacement,velocity and acceleration vector
- if( ispec_is_elastic(ispec) ) then
- ! norm of displacement
- store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
- max(store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
- sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2))
- ! norm of velocity
- store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
- max(store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
- sqrt(veloc(1,iglob)**2 + veloc(2,iglob)**2 + veloc(3,iglob)**2))
- ! norm of acceleration
- store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
- max(store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
- sqrt(accel(1,iglob)**2 + accel(2,iglob)**2 + accel(3,iglob)**2))
- endif
- enddo
- endif
- enddo
-
-! finalizes shakemap: master process collects all info
- if (it == NSTEP) then
- if (USE_HIGHRES_FOR_MOVIES) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- else
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- endif
-
-! creates shakemap file
- if(myrank == 0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
- write(IOUT) store_val_x_all_external_mesh ! x coordinates
- write(IOUT) store_val_y_all_external_mesh ! y coordinates
- write(IOUT) store_val_z_all_external_mesh ! z coordinates
- write(IOUT) store_val_ux_all_external_mesh ! norm of displacement vector
- write(IOUT) store_val_uy_all_external_mesh ! norm of velocity vector
- write(IOUT) store_val_uz_all_external_mesh ! norm of acceleration vector
- close(IOUT)
- endif
- endif
-
- end subroutine it_create_shakemap_em
-
-
-!================================================================
-
- subroutine it_create_movie_surface_em()
-
-! creation of moviedata files
-
use specfem_par
use specfem_par_elastic
use specfem_par_acoustic
- use specfem_par_movie
+
implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: b_displ_elm,accel_elm
+ real(kind=CUSTOM_REAL) :: kappal
+ integer :: i,j,k,ispec,iglob
- real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: veloc_element
- integer :: ispec2D,ispec,ipoin,iglob,i,j,k
- logical :: is_done
-
-! initializes arrays for point coordinates
- if (it == NTSTEP_BETWEEN_FRAMES ) then
- do ispec2D = 1,nfaces_surface_ext_mesh
- if (USE_HIGHRES_FOR_MOVIES) then
- do ipoin = 1, NGLLX*NGLLY
- iglob = faces_surface_ext_mesh(ipoin,ispec2D)
- ! x,y,z coordinates
- store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
- store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
- store_val_z_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = zstore(iglob)
- enddo
- else
- do ipoin = 1, 4
- iglob = faces_surface_ext_mesh(ipoin,ispec2D)
- ! x,y,z coordinates
- store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
- store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
- store_val_z_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = zstore(iglob)
- enddo
- endif
- enddo
- endif
-
-! saves surface velocities
- do ispec2D = 1,nfaces_surface_ext_mesh
- ispec = faces_surface_ext_mesh_ispec(ispec2D)
+ !elastic domains
+ if(ELASTIC_SIMULATION ) then
- if( ispec_is_acoustic(ispec) ) then
- ! velocity vector
- call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
- potential_dot_acoustic, veloc_element,&
- hprime_xx,hprime_yy,hprime_zz, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- ibool,rhostore)
- endif
+ ! NOTE: kappa and mu kernels have already been updated in compute_forces_elastic()
- if (USE_HIGHRES_FOR_MOVIES) then
- do ipoin = 1, NGLLX*NGLLY
- iglob = faces_surface_ext_mesh(ipoin,ispec2D)
- ! x,y,z coordinates
- !store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
- !store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
- !store_val_z_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = zstore(iglob)
- ! saves velocity vector
- if( ispec_is_elastic(ispec) ) then
- ! velocity x,y,z-components
- store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(1,iglob)
- store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(2,iglob)
- store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(3,iglob)
- endif
- ! acoustic pressure potential
- if( ispec_is_acoustic(ispec) ) then
- ! velocity vector
- is_done = .false.
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- if( iglob == ibool(i,j,k,ispec) ) then
- store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(1,i,j,k)
- store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(2,i,j,k)
- store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(3,i,j,k)
- is_done = .true.
- exit
- endif
- enddo
- if( is_done ) exit
- enddo
- if( is_done ) exit
+ ! density kernel update
+ do ispec = 1, NSPEC_AB
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! note: takes displacement from backward/reconstructed (forward) field b_displ
+ ! and acceleration from adjoint field accel (containing adjoint sources)
+ !
+ ! note: : time integral summation uses deltat
+ !
+ ! compare with Tromp et al. (2005), eq. (14), which takes adjoint displacement
+ ! and forward acceleration, that is the symmetric form of what is calculated here
+ ! however, this kernel expression is symmetric with regards to interchange adjoint - forward field
+ rho_kl(i,j,k,ispec) = rho_kl(i,j,k,ispec) &
+ + deltat * dot_product(accel(:,iglob), b_displ(:,iglob))
enddo
- ! only pressure
- !store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
- !store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
- !store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
- endif
- enddo
- else
- do ipoin = 1, 4
- iglob = faces_surface_ext_mesh(ipoin,ispec2D)
- ! x,y,z coordinates
- !store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
- !store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
- !store_val_z_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = zstore(iglob)
- ! saves velocity vector
- if( ispec_is_elastic(ispec) ) then
- ! velocity x,y,z-components
- store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(1,iglob)
- store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(2,iglob)
- store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(3,iglob)
- endif
- ! acoustic pressure potential
- if( ispec_is_acoustic(ispec) ) then
- ! velocity vector
- is_done = .false.
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- if( iglob == ibool(i,j,k,ispec) ) then
- store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(1,i,j,k)
- store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(2,i,j,k)
- store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(3,i,j,k)
- is_done = .true.
- exit
- endif
- enddo
- if( is_done ) exit
- enddo
- if( is_done ) exit
- enddo
- ! only pressure
- !store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
- !store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
- !store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = -potential_dot_dot_acoustic(iglob)
- endif
- enddo
- endif
- enddo
-
-! master process collects all info
- if (USE_HIGHRES_FOR_MOVIES) then
- ! collects locations only once
- if (it == NTSTEP_BETWEEN_FRAMES ) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- endif
- ! updates/gathers velocity field (high-res)
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- else
- ! collects locations only once
- if (it == NTSTEP_BETWEEN_FRAMES ) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- endif
- ! updates/gathers velocity field (low-res)
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- endif
-
-! file output
- if(myrank == 0) then
- write(outputname,"('/moviedata',i6.6)") it
- open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted')
- write(IOUT) store_val_x_all_external_mesh ! x coordinate
- write(IOUT) store_val_y_all_external_mesh ! y coordinate
- write(IOUT) store_val_z_all_external_mesh ! z coordinate
- write(IOUT) store_val_ux_all_external_mesh ! velocity x-component
- write(IOUT) store_val_uy_all_external_mesh ! velocity y-component
- write(IOUT) store_val_uz_all_external_mesh ! velocity z-component
- close(IOUT)
- endif
-
- end subroutine it_create_movie_surface_em
-
-
-!=====================================================================
-
- subroutine it_movie_surface_output_o()
-
-! outputs moviedata files
-
- use specfem_par
- use specfem_par_elastic
- use specfem_par_movie
-
- implicit none
- integer :: imin,imax,jmin,jmax,kmin,kmax,iface,igll
- integer :: ipoin,iloc
- integer :: ispec,i,j,k,iglob
-
-! initializes arrays for point coordinates
- if (it == NTSTEP_BETWEEN_FRAMES ) then
- ipoin = 0
- do iface=1,num_free_surface_faces
- ispec = free_surface_ispec(iface)
- ! high_resolution
- if (USE_HIGHRES_FOR_MOVIES) then
- do igll = 1, NGLLSQUARE
- ipoin = ipoin + 1
- i = free_surface_ijk(1,igll,iface)
- j = free_surface_ijk(2,igll,iface)
- k = free_surface_ijk(3,igll,iface)
- iglob = ibool(i,j,k,ispec)
- ! coordinates
- store_val_x_external_mesh(ipoin) = xstore(iglob)
- store_val_y_external_mesh(ipoin) = ystore(iglob)
- store_val_z_external_mesh(ipoin) = zstore(iglob)
enddo
- else
- imin = minval( free_surface_ijk(1,:,iface) )
- imax = maxval( free_surface_ijk(1,:,iface) )
- jmin = minval( free_surface_ijk(2,:,iface) )
- jmax = maxval( free_surface_ijk(2,:,iface) )
- kmin = minval( free_surface_ijk(3,:,iface) )
- kmax = maxval( free_surface_ijk(3,:,iface) )
- do iloc = 1, NGNOD2D
- ipoin = ipoin + 1
- ! corner points
- if( imin == imax ) then
- iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
- else if( jmin == jmax ) then
- iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
- else
- iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
- endif
- ! coordinates
- store_val_x_external_mesh(ipoin) = xstore(iglob)
- store_val_y_external_mesh(ipoin) = ystore(iglob)
- store_val_z_external_mesh(ipoin) = zstore(iglob)
- enddo
- endif
+ enddo
enddo
- endif
-
-! outputs values at free surface
- ipoin = 0
- do iface=1,num_free_surface_faces
- ispec = free_surface_ispec(iface)
- ! high_resolution
- if (USE_HIGHRES_FOR_MOVIES) then
- do igll = 1, NGLLSQUARE
- ipoin = ipoin + 1
- i = free_surface_ijk(1,igll,iface)
- j = free_surface_ijk(2,igll,iface)
- k = free_surface_ijk(3,igll,iface)
- iglob = ibool(i,j,k,ispec)
- ! coordinates
- !store_val_x_external_mesh(ipoin) = xstore(iglob)
- !store_val_y_external_mesh(ipoin) = ystore(iglob)
- !store_val_z_external_mesh(ipoin) = zstore(iglob)
- ! elastic displacement/velocity
- if( ispec_is_elastic(ispec) ) then
- if(SAVE_DISPLACEMENT) then
- store_val_ux_external_mesh(ipoin) = displ(1,iglob)
- store_val_uy_external_mesh(ipoin) = displ(2,iglob)
- store_val_uz_external_mesh(ipoin) = displ(3,iglob)
- else
- store_val_ux_external_mesh(ipoin) = veloc(1,iglob)
- store_val_uy_external_mesh(ipoin) = veloc(2,iglob)
- store_val_uz_external_mesh(ipoin) = veloc(3,iglob)
- endif
- endif
- enddo
- else
- imin = minval( free_surface_ijk(1,:,iface) )
- imax = maxval( free_surface_ijk(1,:,iface) )
- jmin = minval( free_surface_ijk(2,:,iface) )
- jmax = maxval( free_surface_ijk(2,:,iface) )
- kmin = minval( free_surface_ijk(3,:,iface) )
- kmax = maxval( free_surface_ijk(3,:,iface) )
- do iloc = 1, NGNOD2D
- ipoin = ipoin + 1
- ! corner points
- if( imin == imax ) then
- iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
- else if( jmin == jmax ) then
- iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
- else
- iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
- endif
- ! coordinates
- !store_val_x_external_mesh(ipoin) = xstore(iglob)
- !store_val_y_external_mesh(ipoin) = ystore(iglob)
- !store_val_z_external_mesh(ipoin) = zstore(iglob)
- ! elastic displacement/velocity
- if( ispec_is_elastic(ispec) ) then
- if(SAVE_DISPLACEMENT) then
- store_val_ux_external_mesh(ipoin) = displ(1,iglob)
- store_val_uy_external_mesh(ipoin) = displ(2,iglob)
- store_val_uz_external_mesh(ipoin) = displ(3,iglob)
- else
- store_val_ux_external_mesh(ipoin) = veloc(1,iglob)
- store_val_uy_external_mesh(ipoin) = veloc(2,iglob)
- store_val_uz_external_mesh(ipoin) = veloc(3,iglob)
- endif
- endif
- enddo ! iloc
- endif
- enddo ! iface
-
-! master process collects all info
- if (USE_HIGHRES_FOR_MOVIES) then
- if (it == NTSTEP_BETWEEN_FRAMES ) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- endif
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- else
- if (it == NTSTEP_BETWEEN_FRAMES ) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- endif
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- endif
-
-! file output
- if(myrank == 0) then
- write(outputname,"('/moviedata_free_surface',i6.6)") it
- open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted')
- write(IOUT) store_val_x_all_external_mesh ! x coordinate
- write(IOUT) store_val_y_all_external_mesh ! y coordinate
- write(IOUT) store_val_z_all_external_mesh ! z coordinate
- write(IOUT) store_val_ux_all_external_mesh ! velocity x-component
- write(IOUT) store_val_uy_all_external_mesh ! velocity y-component
- write(IOUT) store_val_uz_all_external_mesh ! velocity z-component
- close(IOUT)
- endif
-
-! obsolete...
-! ispec = nmovie_points
-!
-! call gather_all_cr(store_val_x,ispec,store_val_x_all,ispec,NPROC)
-! call gather_all_cr(store_val_y,ispec,store_val_y_all,ispec,NPROC)
-! call gather_all_cr(store_val_z,ispec,store_val_z_all,ispec,NPROC)
-! call gather_all_cr(store_val_ux,ispec,store_val_ux_all,ispec,NPROC)
-! call gather_all_cr(store_val_uy,ispec,store_val_uy_all,ispec,NPROC)
-! call gather_all_cr(store_val_uz,ispec,store_val_uz_all,ispec,NPROC)
-!
-!! save movie data to disk in home directory
-! if(myrank == 0) then
-! write(outputname,"('/moviedata',i6.6)") it
-! open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted')
-! write(IOUT) store_val_x_all
-! write(IOUT) store_val_y_all
-! write(IOUT) store_val_z_all
-! write(IOUT) store_val_ux_all
-! write(IOUT) store_val_uy_all
-! write(IOUT) store_val_uz_all
-! close(IOUT)
-! endif
-
- end subroutine it_movie_surface_output_o
-
-
-!=====================================================================
-
- subroutine it_create_shakemap_o()
-
-! outputs shakemap file
-
- use specfem_par
- use specfem_par_elastic
- use specfem_par_movie
-
- implicit none
- integer :: imin,imax,jmin,jmax,kmin,kmax,iface,igll,iloc,ipoin
- integer :: ispec,i,j,k,iglob
-
-! outputs values on free surface
- ipoin = 0
- do iface=1,num_free_surface_faces
- ispec = free_surface_ispec(iface)
- ! save all points for high resolution, or only four corners for low resolution
- if(USE_HIGHRES_FOR_MOVIES) then
- do igll = 1, NGLLSQUARE
- ipoin = ipoin + 1
- i = free_surface_ijk(1,igll,iface)
- j = free_surface_ijk(2,igll,iface)
- k = free_surface_ijk(3,igll,iface)
- iglob = ibool(i,j,k,ispec)
- store_val_x_external_mesh(ipoin) = xstore(iglob)
- store_val_y_external_mesh(ipoin) = ystore(iglob)
- store_val_z_external_mesh(ipoin) = zstore(iglob)
- ! todo: are we only interested in the absolute maximum of horizontal (E,N) components?
- if( ispec_is_elastic( ispec) ) then
- ! horizontal displacement
- store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),abs(displ(1,iglob)),abs(displ(2,iglob)))
- ! horizontal velocity
- store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),abs(veloc(1,iglob)),abs(veloc(2,iglob)))
- ! horizontal acceleration
- store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),abs(accel(1,iglob)),abs(accel(2,iglob)))
- endif
- enddo
- else
- imin = minval( free_surface_ijk(1,:,iface) )
- imax = maxval( free_surface_ijk(1,:,iface) )
- jmin = minval( free_surface_ijk(2,:,iface) )
- jmax = maxval( free_surface_ijk(2,:,iface) )
- kmin = minval( free_surface_ijk(3,:,iface) )
- kmax = maxval( free_surface_ijk(3,:,iface) )
- do iloc = 1, NGNOD2D
- ipoin = ipoin + 1
- ! corner points
- if( imin == imax ) then
- iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
- else if( jmin == jmax ) then
- iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
- else
- iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
- endif
- ! coordinates
- store_val_x_external_mesh(ipoin) = xstore(iglob)
- store_val_y_external_mesh(ipoin) = ystore(iglob)
- store_val_z_external_mesh(ipoin) = zstore(iglob)
- ! todo: are we only interested in the absolute maximum of horizontal (E,N) components?
- if( ispec_is_elastic( ispec) ) then
- store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),abs(displ(1,iglob)),abs(displ(2,iglob)))
- store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),abs(veloc(1,iglob)),abs(veloc(2,iglob)))
- store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),abs(accel(1,iglob)),abs(accel(2,iglob)))
- endif
- enddo
- endif ! USE_HIGHRES_FOR_MOVIES
- enddo
-
-! save shakemap only at the end of the simulation
- if(it == NSTEP) then
- if (USE_HIGHRES_FOR_MOVIES) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
- store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- else
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
- store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
- nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- endif
-
-! creates shakemap file
- if(myrank == 0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata_freesurface',status='unknown',form='unformatted')
- write(IOUT) store_val_x_all_external_mesh ! x coordinates
- write(IOUT) store_val_y_all_external_mesh ! y coordinates
- write(IOUT) store_val_z_all_external_mesh ! z coordinates
- write(IOUT) store_val_ux_all_external_mesh ! norm of displacement vector
- write(IOUT) store_val_uy_all_external_mesh ! norm of velocity vector
- write(IOUT) store_val_uz_all_external_mesh ! norm of acceleration vector
- close(IOUT)
- endif
-
-! obsolete...
-! ispec = nmovie_points
-! call gather_all_cr(store_val_x,ispec,store_val_x_all,ispec,NPROC)
-! call gather_all_cr(store_val_y,ispec,store_val_y_all,ispec,NPROC)
-! call gather_all_cr(store_val_z,ispec,store_val_z_all,ispec,NPROC)
-! call gather_all_cr(store_val_norm_displ,ispec,store_val_ux_all,ispec,NPROC)
-! call gather_all_cr(store_val_norm_veloc,ispec,store_val_uy_all,ispec,NPROC)
-! call gather_all_cr(store_val_norm_accel,ispec,store_val_uz_all,ispec,NPROC)
-!
-!! save movie data to disk in home directory
-! if(myrank == 0) then
-! open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
-! write(IOUT) store_val_x_all
-! write(IOUT) store_val_y_all
-! write(IOUT) store_val_z_all
-!! this saves norm of displacement, velocity and acceleration
-!! but we use the same ux, uy, uz arrays as for the movies to save memory
-! write(IOUT) store_val_ux_all
-! write(IOUT) store_val_uy_all
-! write(IOUT) store_val_uz_all
-! close(IOUT)
-! endif
-!
- endif ! NTSTEP
-
- end subroutine it_create_shakemap_o
-
+ ! moho kernel
+ if (SAVE_MOHO_MESH) then
+ call compute_boundary_kernel()
+ endif
-!=====================================================================
+ endif ! elastic
- subroutine it_movie_volume_output()
-
-! outputs movie files for div, curl and velocity
-
- use specfem_par
- use specfem_par_elastic
- use specfem_par_acoustic
- use specfem_par_movie
- implicit none
-
- real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: veloc_element
- integer :: ispec,i,j,k,l,iglob
-
-! save velocity here to avoid static offset on displacement for movies
- velocity_movie(:,:,:,:,:) = 0._CUSTOM_REAL
-
+ ! acoustic domains
if( ACOUSTIC_SIMULATION ) then
- ! uses div as temporary array to store velocity on all gll points
+
do ispec=1,NSPEC_AB
- if( .not. ispec_is_acoustic(ispec) ) cycle
-
- ! calculates velocity
- call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
- potential_dot_acoustic, veloc_element,&
+
+ ! acoustic wave field
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! backward fields: displacement vector
+ call compute_gradient(ispec,NSPEC_ADJOINT,NGLOB_ADJOINT, &
+ b_potential_acoustic, b_displ_elm,&
hprime_xx,hprime_yy,hprime_zz, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
ibool,rhostore)
- velocity_movie(:,:,:,:,ispec) = veloc_element(:,:,:,:)
- enddo
- endif ! acoustic
+ ! adjoint fields: acceleration vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic, accel_elm,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
-! save full snapshot data to local disk
- if( ELASTIC_SIMULATION ) then
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! density kernel
+ rho_ac_kl(i,j,k,ispec) = rho_ac_kl(i,j,k,ispec) &
+ - deltat * dot_product(accel_elm(:,i,j,k), b_displ_elm(:,i,j,k))
- ! calculate strain div and curl
- do ispec=1,NSPEC_AB
- if( .not. ispec_is_elastic(ispec) ) cycle
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- tempy1l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
-
- tempz1l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l = tempx1l + veloc(1,iglob)*hp1
- tempy1l = tempy1l + veloc(2,iglob)*hp1
- tempz1l = tempz1l + veloc(3,iglob)*hp1
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l = tempx2l + veloc(1,iglob)*hp2
- tempy2l = tempy2l + veloc(2,iglob)*hp2
- tempz2l = tempz2l + veloc(3,iglob)*hp2
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l = tempx3l + veloc(1,iglob)*hp3
- tempy3l = tempy3l + veloc(2,iglob)*hp3
- tempz3l = tempz3l + veloc(3,iglob)*hp3
+ ! bulk modulus kernel
+ kappal = kappastore(i,j,k,ispec)
+ kappa_ac_kl(i,j,k,ispec) = kappa_ac_kl(i,j,k,ispec) &
+ - deltat * kappal &
+ * potential_dot_dot_acoustic(iglob)/kappal &
+ * b_potential_dot_dot_acoustic(iglob)/kappal
enddo
-
- ! get derivatives of ux, uy and uz with respect to x, y and z
-
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
-
- dvxdxl(i,j,k) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- dvxdyl(i,j,k) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- dvxdzl(i,j,k) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
- dvydxl(i,j,k) = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
- dvydyl(i,j,k) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
- dvydzl(i,j,k) = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
-
- dvzdxl(i,j,k) = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
- dvzdyl(i,j,k) = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
- dvzdzl(i,j,k) = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
-
enddo
enddo
- enddo
+
+ endif ! ispec_is_acoustic
+ enddo
+ endif !acoustic
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- div(i,j,k,ispec) = dvxdxl(i,j,k) + dvydyl(i,j,k) + dvzdzl(i,j,k)
- curl_x(i,j,k,ispec) = dvzdyl(i,j,k) - dvydzl(i,j,k)
- curl_y(i,j,k,ispec) = dvxdzl(i,j,k) - dvzdxl(i,j,k)
- curl_z(i,j,k,ispec) = dvydxl(i,j,k) - dvxdyl(i,j,k)
-
- iglob = ibool(i,j,k,ispec)
- velocity_movie(:,i,j,k,ispec) = veloc(:,iglob)
- enddo
- enddo
- enddo
- enddo !NSPEC_AB
-
- write(outputname,"('/proc',i6.6,'_div_it',i6.6,'.bin')") myrank,it
- open(unit=27,file='OUTPUT_FILES'//trim(outputname),status='unknown',form='unformatted')
- write(27) div
- close(27)
- write(outputname,"('/proc',i6.6,'_curl_x_it',i6.6,'.bin')") myrank,it
- open(unit=27,file='OUTPUT_FILES'//trim(outputname),status='unknown',form='unformatted')
- write(27) curl_x
- close(27)
- write(outputname,"('/proc',i6.6,'_curl_y_it',i6.6,'.bin')") myrank,it
- open(unit=27,file='OUTPUT_FILES'//trim(outputname),status='unknown',form='unformatted')
- write(27) curl_y
- close(27)
- write(outputname,"('/proc',i6.6,'_curl_z_it',i6.6,'.bin')") myrank,it
- open(unit=27,file='OUTPUT_FILES'//trim(outputname),status='unknown',form='unformatted')
- write(27) curl_z
- close(27)
-
- !write(outputname,"('veloc_proc',i6.6,'_it',i6.6,'.bin')") myrank,it
- !open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- !write(27) veloc
- !close(27)
+ end subroutine it_update_adjointkernels
- endif ! elastic
-
- if( ACOUSTIC_SIMULATION .or. ELASTIC_SIMULATION ) then
- write(outputname,"('/proc',i6.6,'_veloc_it',i6.6,'.bin')") myrank,it
- open(unit=27,file='OUTPUT_FILES'//trim(outputname),status='unknown',form='unformatted')
- write(27) velocity_movie
- close(27)
- endif
-
- end subroutine it_movie_volume_output
-
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/locate_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/locate_receivers.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/locate_receivers.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -31,15 +31,14 @@
nrec,islice_selected_rec,ispec_selected_rec, &
xi_receiver,eta_receiver,gamma_receiver,station_name,network_name,nu, &
NPROC,utm_x_source,utm_y_source, &
- TOPOGRAPHY,UTM_PROJECTION_ZONE, &
- iglob_is_surface_external_mesh,ispec_is_surface_external_mesh &
- )
+ TOPOGRAPHY,UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ iglob_is_surface_external_mesh,ispec_is_surface_external_mesh )
implicit none
include "constants.h"
- logical TOPOGRAPHY
+ logical TOPOGRAPHY,SUPPRESS_UTM_PROJECTION
integer NPROC,UTM_PROJECTION_ZONE
@@ -191,9 +190,9 @@
read(1,*,iostat=ios) station_name(irec),network_name(irec),stlat(irec),stlon(irec),stele(irec),stbur(irec)
if (ios /= 0) call exit_mpi(myrank, 'Error reading station file '//trim(rec_filename))
-! convert station location to UTM
- call utm_geo(stlon(irec),stlat(irec),stutm_x(irec),stutm_y(irec),UTM_PROJECTION_ZONE,ILONGLAT2UTM, &
- .true.)
+! convert station location to UTM
+ call utm_geo(stlon(irec),stlat(irec),stutm_x(irec),stutm_y(irec),&
+ UTM_PROJECTION_ZONE,ILONGLAT2UTM,SUPPRESS_UTM_PROJECTION)
! compute horizontal distance between source and receiver in km
horiz_dist(irec) = dsqrt((stutm_y(irec)-utm_y_source)**2 + (stutm_x(irec)-utm_x_source)**2) / 1000.
@@ -641,23 +640,30 @@
if(final_distance(irec) == HUGEVAL) call exit_MPI(myrank,'error locating receiver')
write(IMAIN,*) ' original latitude: ',sngl(stlat(irec))
- write(IMAIN,*) ' original longitude: ',sngl(stlon(irec))
- write(IMAIN,*) ' original UTM x: ',sngl(stutm_x(irec))
- write(IMAIN,*) ' original UTM y: ',sngl(stutm_y(irec))
- write(IMAIN,*) ' horizontal distance: ',sngl(horiz_dist(irec))
- if(TOPOGRAPHY) write(IMAIN,*) ' topography elevation: ',sngl(elevation(irec))
- write(IMAIN,*) ' target x, y, z: ',sngl(x_target(irec)),sngl(y_target(irec)),sngl(z_target(irec))
+ write(IMAIN,*) ' original longitude: ',sngl(stlon(irec))
+ if( SUPPRESS_UTM_PROJECTION ) then
+ write(IMAIN,*) ' original x: ',sngl(stutm_x(irec))
+ write(IMAIN,*) ' original y: ',sngl(stutm_y(irec))
+ else
+ write(IMAIN,*) ' original UTM x: ',sngl(stutm_x(irec))
+ write(IMAIN,*) ' original UTM y: ',sngl(stutm_y(irec))
+ endif
+ write(IMAIN,*) ' horizontal distance: ',sngl(horiz_dist(irec))
+ if(TOPOGRAPHY) write(IMAIN,*) ' topography elevation: ',sngl(elevation(irec))
+ write(IMAIN,*) ' target x, y, z: ',sngl(x_target(irec)),sngl(y_target(irec)),sngl(z_target(irec))
- write(IMAIN,*) 'closest estimate found: ',sngl(final_distance(irec)),' m away'
- write(IMAIN,*) ' in slice ',islice_selected_rec(irec),' in element ',ispec_selected_rec(irec)
+ write(IMAIN,*) ' closest estimate found: ',sngl(final_distance(irec)),' m away'
+ write(IMAIN,*) ' in slice ',islice_selected_rec(irec),' in element ',ispec_selected_rec(irec)
if(FASTER_RECEIVERS_POINTS_ONLY) then
- write(IMAIN,*) 'in point i,j,k = ',nint(xi_receiver(irec)),nint(eta_receiver(irec)),nint(gamma_receiver(irec))
- !write(IMAIN,*) 'in point i,j,k = ',x_found(irec),y_found(irec),z_found(irec)
- write(IMAIN,*) 'nu1 = ',nu(1,:,irec)
- write(IMAIN,*) 'nu2 = ',nu(2,:,irec)
- write(IMAIN,*) 'nu3 = ',nu(3,:,irec)
+ write(IMAIN,*) ' in point i,j,k = ',nint(xi_receiver(irec)),nint(eta_receiver(irec)),nint(gamma_receiver(irec))
+ write(IMAIN,*) ' nu1 = ',nu(1,:,irec)
+ write(IMAIN,*) ' nu2 = ',nu(2,:,irec)
+ write(IMAIN,*) ' nu3 = ',nu(3,:,irec)
else
- write(IMAIN,*) ' at xi,eta,gamma coordinates = ',xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec)
+ write(IMAIN,*) ' at coordinates: '
+ write(IMAIN,*) ' xi = ',xi_receiver(irec)
+ write(IMAIN,*) ' eta = ',eta_receiver(irec)
+ write(IMAIN,*) ' gamma = ',gamma_receiver(irec)
endif
! add warning if estimate is poor
@@ -747,8 +753,9 @@
end subroutine locate_receivers
-!===========================
+!=====================================================================
+
subroutine station_filter(myrank,filename,filtered_filename,nfilter, &
LATITUDE_MIN, LATITUDE_MAX, LONGITUDE_MIN, LONGITUDE_MAX)
@@ -758,46 +765,74 @@
! input
integer :: myrank
- character(len=*) filename,filtered_filename
- double precision LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX
+ character(len=*) :: filename,filtered_filename
+ double precision :: LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX
! output
- integer nfilter
+ integer :: nfilter
- integer irec, nrec, nrec_filtered, ios
+ integer :: nrec, nrec_filtered, ios !, irec
- double precision stlat,stlon,stele,stbur
- character(len=MAX_LENGTH_STATION_NAME) station_name
- character(len=MAX_LENGTH_NETWORK_NAME) network_name
- character(len=256) dummystring
+ double precision :: stlat,stlon,stele,stbur
+ character(len=MAX_LENGTH_STATION_NAME) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME) :: network_name
+ character(len=256) :: dummystring
nrec = 0
nrec_filtered = 0
+ ! counts number of lines in stations file
open(unit=IIN, file=trim(filename), status = 'old', iostat = ios)
if (ios /= 0) call exit_mpi(myrank, 'No file '//trim(filename)//', exit')
do while(ios == 0)
- read(IIN,"(a)",iostat = ios) dummystring
- if(ios == 0) nrec = nrec + 1
+ read(IIN,"(a256)",iostat = ios) dummystring
+ if(ios /= 0) exit
+
+ if( len_trim(dummystring) > 0 ) nrec = nrec + 1
enddo
close(IIN)
+ ! reads in station locations
open(unit=IIN, file=trim(filename), status = 'old', iostat = ios)
- do irec = 1, nrec
- read(IIN, *) station_name, network_name, stlat, stlon, stele, stbur
- if(stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
+ !do irec = 1,nrec
+ ! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
+ do while(ios == 0)
+ read(IIN,"(a256)",iostat = ios) dummystring
+ if( ios /= 0 ) exit
+
+ ! counts number of stations in min/max region
+ if( len_trim(dummystring) > 0 ) then
+ dummystring = trim(dummystring)
+ read(dummystring, *) station_name, network_name, stlat, stlon, stele, stbur
+
+ ! counts stations within lon/lat region
+ if( stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. &
+ stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
nrec_filtered = nrec_filtered + 1
+ endif
enddo
close(IIN)
+ ! writes out filtered stations file
if (myrank == 0) then
- open(unit=IIN,file=trim(filename),status='old',action='read')
+ open(unit=IIN,file=trim(filename),status='old',action='read',iostat=ios)
open(unit=IOUT,file=trim(filtered_filename),status='unknown')
- write(IOUT,*) nrec_filtered
- do irec = 1,nrec
- read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
- if(stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
- write(IOUT,*) station_name,' ',network_name,' ',sngl(stlat),' ',sngl(stlon), ' ',sngl(stele), ' ',sngl(stbur)
+ !write(IOUT,*) nrec_filtered
+ !do irec = 1,nrec
+ do while(ios == 0)
+ read(IIN,"(a256)",iostat = ios) dummystring
+ if( ios /= 0 ) exit
+
+ !read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
+ if( len_trim(dummystring) > 0 ) then
+ dummystring = trim(dummystring)
+ read(dummystring, *) station_name, network_name, stlat, stlon, stele, stbur
+
+ if( stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. &
+ stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
+ write(IOUT,*) trim(station_name),' ',trim(network_name),' ',sngl(stlat), &
+ ' ',sngl(stlon), ' ',sngl(stele), ' ',sngl(stbur)
+ endif
enddo
close(IIN)
close(IOUT)
@@ -808,6 +843,16 @@
write(IMAIN,*) 'excluding ',nrec - nrec_filtered,' stations located outside the model'
write(IMAIN,*)
+ if( nrec_filtered < 1 ) then
+ write(IMAIN,*) 'error filtered stations:'
+ write(IMAIN,*) ' simulation needs at least 1 station but got ',nrec_filtered
+ write(IMAIN,*)
+ write(IMAIN,*) ' check that stations in file '//trim(filename)//' are within'
+ write(IMAIN,*) ' latitude min/max : ',LATITUDE_MIN,LATITUDE_MAX
+ write(IMAIN,*) ' longitude min/max: ',LONGITUDE_MIN,LONGITUDE_MAX
+ write(IMAIN,*)
+ endif
+
endif
nfilter = nrec_filtered
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -29,11 +29,11 @@
subroutine locate_source(ibool,NSOURCES,myrank,NSPEC_AB,NGLOB_AB,xstore,ystore,zstore, &
xigll,yigll,zigll,NPROC, &
- sec,t_cmt,yr,jda,ho,mi,utm_x_source,utm_y_source, &
- NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ t_cmt,yr,jda,ho,mi,utm_x_source,utm_y_source, &
+ DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
islice_selected_source,ispec_selected_source, &
xi_source,eta_source,gamma_source, &
- TOPOGRAPHY,UTM_PROJECTION_ZONE, &
+ TOPOGRAPHY,UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
PRINT_SOURCE_TIME_FUNCTION, &
nu_source,iglob_is_surface_external_mesh,ispec_is_surface_external_mesh, &
ispec_is_acoustic,ispec_is_elastic)
@@ -43,9 +43,9 @@
include "constants.h"
integer NPROC,UTM_PROJECTION_ZONE
- integer NSTEP,NSPEC_AB,NGLOB_AB,NSOURCES
+ integer NSPEC_AB,NGLOB_AB,NSOURCES
- logical TOPOGRAPHY,PRINT_SOURCE_TIME_FUNCTION
+ logical TOPOGRAPHY,PRINT_SOURCE_TIME_FUNCTION,SUPPRESS_UTM_PROJECTION
double precision DT
@@ -71,16 +71,16 @@
double precision dist
double precision xi,eta,gamma,dx,dy,dz,dxi,deta
-! Gauss-Lobatto-Legendre points of integration
+ ! Gauss-Lobatto-Legendre points of integration
double precision xigll(NGLLX)
double precision yigll(NGLLY)
double precision zigll(NGLLZ)
-! topology of the control points of the surface element
+ ! topology of the control points of the surface element
integer iax,iay,iaz
integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
-! coordinates of the control points of the surface element
+ ! coordinates of the control points of the surface element
double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
integer iter_loop
@@ -98,7 +98,7 @@
integer islice_selected_source(NSOURCES)
-! timer MPI
+ ! timer MPI
double precision, external :: wtime
double precision time_start,tCPU
@@ -114,7 +114,7 @@
double precision, dimension(:), allocatable :: tmp_local
double precision, dimension(:,:),allocatable :: tmp_all_local
- double precision hdur(NSOURCES), hdur_gaussian(NSOURCES), t0
+ double precision hdur(NSOURCES) !, hdur_gaussian(NSOURCES) !, t0
double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
@@ -123,7 +123,7 @@
double precision, dimension(NSOURCES) :: lat,long,depth,elevation
double precision moment_tensor(6,NSOURCES)
- character(len=256) OUTPUT_FILES,plot_file
+ character(len=256) OUTPUT_FILES
double precision, dimension(NSOURCES) :: x_found_source,y_found_source,z_found_source
double precision distmin
@@ -131,7 +131,7 @@
integer, dimension(:), allocatable :: tmp_i_local
integer, dimension(:,:),allocatable :: tmp_i_all_local
-! for surface locating and normal computing with external mesh
+ ! for surface locating and normal computing with external mesh
integer :: pt0_ix,pt0_iy,pt0_iz,pt1_ix,pt1_iy,pt1_iz,pt2_ix,pt2_iy,pt2_iz
real(kind=CUSTOM_REAL), dimension(3) :: u_vector,v_vector,w_vector
logical, dimension(NGLOB_AB) :: iglob_is_surface_external_mesh
@@ -139,49 +139,54 @@
integer ix_initial_guess_source,iy_initial_guess_source,iz_initial_guess_source
-! for calculation of source time function
- integer it
- double precision time_source
- double precision, external :: comp_source_time_function
+ ! for calculation of source time function
+ !integer it
+ !double precision time_source
+ !double precision, external :: comp_source_time_function
integer, dimension(NSOURCES) :: idomain
integer, dimension(NGATHER_SOURCES,0:NPROC-1) :: idomain_all
-! **************
-
-! get the base pathname for output files
+ ! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-! read all the sources
- call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,NSOURCES)
+ ! read all the sources
+ call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,NSOURCES)
-! convert the half duration for triangle STF to the one for gaussian STF
- hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
+ ! checks half-durations
+ do isource = 1, NSOURCES
+ ! null half-duration indicates a Heaviside
+ ! replace with very short error function
+ if(hdur(isource) < 5. * DT) hdur(isource) = 5. * DT
+ enddo
+
+ ! convert the half duration for triangle STF to the one for gaussian STF
+ !hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
-! define t0 as the earliest start time
- t0 = - 1.5d0 * minval(t_cmt-hdur)
+ ! define t0 as the earliest start time
+ !t0 = - 1.5d0 * minval(t_cmt-hdur)
-! define topology of the control element
+ ! define topology of the control element
call usual_hex_nodes(iaddx,iaddy,iaddz)
-! get MPI starting time
+ ! get MPI starting time
time_start = wtime()
-! loop on all the sources
+ ! loop on all the sources
do isource = 1,NSOURCES
-!
-! r -> z, theta -> -y, phi -> x
-!
-! Mrr = Mzz
-! Mtt = Myy
-! Mpp = Mxx
-! Mrt = -Myz
-! Mrp = Mxz
-! Mtp = -Mxy
+ !
+ ! r -> z, theta -> -y, phi -> x
+ !
+ ! Mrr = Mzz
+ ! Mtt = Myy
+ ! Mpp = Mxx
+ ! Mrt = -Myz
+ ! Mrp = Mxz
+ ! Mtp = -Mxy
-! get the moment tensor
+ ! get the moment tensor
Mzz(isource) = + moment_tensor(1,isource)
Mxx(isource) = + moment_tensor(3,isource)
Myy(isource) = + moment_tensor(2,isource)
@@ -189,22 +194,21 @@
Myz(isource) = - moment_tensor(4,isource)
Mxy(isource) = - moment_tensor(6,isource)
+ ! gets UTM x,y
call utm_geo(long(isource),lat(isource),utm_x_source(isource),utm_y_source(isource), &
- UTM_PROJECTION_ZONE,ILONGLAT2UTM,.true.)
+ UTM_PROJECTION_ZONE,ILONGLAT2UTM,SUPPRESS_UTM_PROJECTION)
+
-! orientation consistent with the UTM projection
-
-! East
+ ! orientation consistent with the UTM projection
+ ! East
nu_source(1,1,isource) = 1.d0
nu_source(1,2,isource) = 0.d0
nu_source(1,3,isource) = 0.d0
-
-! North
+ ! North
nu_source(2,1,isource) = 0.d0
nu_source(2,2,isource) = 1.d0
nu_source(2,3,isource) = 0.d0
-
-! Vertical
+ ! Vertical
nu_source(3,1,isource) = 0.d0
nu_source(3,2,isource) = 0.d0
nu_source(3,3,isource) = 1.d0
@@ -212,10 +216,9 @@
x_target_source = utm_x_source(isource)
y_target_source = utm_y_source(isource)
z_target_source = depth(isource)
-! if (myrank == 0) write(IOVTK,*) x_target_source, y_target_source, z_target_source
-! set distance to huge initial value
+ ! set distance to huge initial value
distmin = HUGEVAL
ispec_selected_source(isource) = 0
@@ -223,7 +226,7 @@
do ispec=1,NSPEC_AB
-! define the interval in which we look for points
+ ! define the interval in which we look for points
if(USE_FORCE_POINT_SOURCE) then
imin = 1
imax = NGLLX
@@ -235,8 +238,8 @@
kmax = NGLLZ
else
-! loop only on points inside the element
-! exclude edges to ensure this point is not shared with other elements
+ ! loop only on points inside the element
+ ! exclude edges to ensure this point is not shared with other elements
imin = 2
imax = NGLLX - 1
@@ -259,7 +262,7 @@
endif
endif
-! keep this point if it is closer to the source
+ ! keep this point if it is closer to the source
dist=dsqrt((x_target_source-dble(xstore(iglob)))**2 &
+(y_target_source-dble(ystore(iglob)))**2 &
+(z_target_source-dble(zstore(iglob)))**2)
@@ -270,7 +273,7 @@
iy_initial_guess_source = j
iz_initial_guess_source = k
-! store xi,eta,gamma and x,y,z of point found
+ ! store xi,eta,gamma and x,y,z of point found
xi_source(isource) = dble(ix_initial_guess_source)
eta_source(isource) = dble(iy_initial_guess_source)
gamma_source(isource) = dble(iz_initial_guess_source)
@@ -278,7 +281,7 @@
y_found_source(isource) = ystore(iglob)
z_found_source(isource) = zstore(iglob)
-! compute final distance between asked and found (converted to km)
+ ! compute final distance between asked and found (converted to km)
final_distance_source(isource) = dsqrt((x_target_source-x_found_source(isource))**2 + &
(y_target_source-y_found_source(isource))**2 + (z_target_source-z_found_source(isource))**2)
@@ -288,7 +291,7 @@
enddo
enddo
-! end of loop on all the elements in current slice
+ ! end of loop on all the elements in current slice
enddo
if (ispec_selected_source(isource) == 0) then
@@ -304,7 +307,7 @@
idomain(isource) = 0
endif
-! get normal to the face of the hexaedra if receiver is on the surface
+ ! get normal to the face of the hexaedra if receiver is on the surface
if ((.not. SOURCES_CAN_BE_BURIED_EXT_MESH) .and. &
.not. (ispec_selected_source(isource) == 0)) then
pt0_ix = -1
@@ -316,7 +319,7 @@
pt2_ix = -1
pt2_iy = -1
pt2_iz = -1
-! we get two vectors of the face (three points) to compute the normal
+ ! we get two vectors of the face (three points) to compute the normal
if (xi_source(isource) == 1 .and. &
iglob_is_surface_external_mesh(ibool(1,2,2,ispec_selected_source(isource)))) then
pt0_ix = 1
@@ -409,32 +412,30 @@
v_vector(3) = zstore(ibool(pt2_ix,pt2_iy,pt2_iz,ispec_selected_source(isource))) &
- zstore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_source(isource)))
-! cross product
+ ! cross product
w_vector(1) = u_vector(2)*v_vector(3) - u_vector(3)*v_vector(2)
w_vector(2) = u_vector(3)*v_vector(1) - u_vector(1)*v_vector(3)
w_vector(3) = u_vector(1)*v_vector(2) - u_vector(2)*v_vector(1)
-! normalize vector w
+ ! normalize vector w
w_vector(:) = w_vector(:)/sqrt(w_vector(1)**2+w_vector(2)**2+w_vector(3)**2)
-! build the two other vectors for a direct base: we normalize u, and v=w^u
+ ! build the two other vectors for a direct base: we normalize u, and v=w^u
u_vector(:) = u_vector(:)/sqrt(u_vector(1)**2+u_vector(2)**2+u_vector(3)**2)
v_vector(1) = w_vector(2)*u_vector(3) - w_vector(3)*u_vector(2)
v_vector(2) = w_vector(3)*u_vector(1) - w_vector(1)*u_vector(3)
v_vector(3) = w_vector(1)*u_vector(2) - w_vector(2)*u_vector(1)
-! build rotation matrice nu for seismograms
-! East (u)
+ ! build rotation matrice nu for seismograms
+ ! East (u)
nu_source(1,1,isource) = u_vector(1)
nu_source(1,2,isource) = v_vector(1)
nu_source(1,3,isource) = w_vector(1)
-
-! North (v)
+ ! North (v)
nu_source(2,1,isource) = u_vector(2)
nu_source(2,2,isource) = v_vector(2)
nu_source(2,3,isource) = w_vector(2)
-
-! Vertical (w)
+ ! Vertical (w)
nu_source(3,1,isource) = u_vector(3)
nu_source(3,2,isource) = v_vector(3)
nu_source(3,3,isource) = w_vector(3)
@@ -447,13 +448,12 @@
if(.not. USE_FORCE_POINT_SOURCE) then
-! use initial guess in xi, eta and gamma
+ ! use initial guess in xi, eta and gamma
xi = xigll(ix_initial_guess_source)
eta = yigll(iy_initial_guess_source)
gamma = zigll(iz_initial_guess_source)
-! define coordinates of the control points of the element
-
+ ! define coordinates of the control points of the element
do ia=1,NGNOD
if(iaddx(ia) == 0) then
@@ -493,30 +493,30 @@
enddo
-! iterate to solve the non linear system
+ ! iterate to solve the non linear system
do iter_loop = 1,NUM_ITER
-! recompute jacobian for the new point
+ ! recompute jacobian for the new point
call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
-! compute distance to target location
+ ! compute distance to target location
dx = - (x - x_target_source)
dy = - (y - y_target_source)
dz = - (z - z_target_source)
-! compute increments
+ ! compute increments
dxi = xix*dx + xiy*dy + xiz*dz
deta = etax*dx + etay*dy + etaz*dz
dgamma = gammax*dx + gammay*dy + gammaz*dz
-! update values
+ ! update values
xi = xi + dxi
eta = eta + deta
gamma = gamma + dgamma
-! impose that we stay in that element
-! (useful if user gives a source outside the mesh for instance)
+ ! impose that we stay in that element
+ ! (useful if user gives a source outside the mesh for instance)
if (xi > 1.d0) xi = 1.d0
if (xi < -1.d0) xi = -1.d0
if (eta > 1.d0) eta = 1.d0
@@ -526,12 +526,12 @@
enddo
-! compute final coordinates of point found
+ ! compute final coordinates of point found
call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
-! store xi,eta,gamma and x,y,z of point found
-! note: xi/eta/gamma will be in range [-1,1]
+ ! store xi,eta,gamma and x,y,z of point found
+ ! note: xi/eta/gamma will be in range [-1,1]
xi_source(isource) = xi
eta_source(isource) = eta
gamma_source(isource) = gamma
@@ -539,16 +539,16 @@
y_found_source(isource) = y
z_found_source(isource) = z
-! compute final distance between asked and found (converted to km)
+ ! compute final distance between asked and found (converted to km)
final_distance_source(isource) = dsqrt((x_target_source-x_found_source(isource))**2 + &
(y_target_source-y_found_source(isource))**2 + (z_target_source-z_found_source(isource))**2)
endif ! of if (.not. USE_FORCE_POINT_SOURCE)
-! end of loop on all the sources
+ ! end of loop on all the sources
enddo
-! now gather information from all the nodes
+ ! now gather information from all the nodes
ngather = NSOURCES/NGATHER_SOURCES
if (mod(NSOURCES,NGATHER_SOURCES)/= 0) ngather = ngather+1
do ig = 1, ngather
@@ -560,7 +560,6 @@
! avoids warnings about temporary creations of arrays for function call by compiler
allocate(tmp_i_local(ng),tmp_i_all_local(ng,0:NPROC-1))
- !call gather_all_i(ispec_selected_source(ns:ne),ng,ispec_selected_source_all(1:ng,:),ng,NPROC)
tmp_i_local(:) = ispec_selected_source(ns:ne)
call gather_all_i(tmp_i_local,ng,tmp_i_all_local,ng,NPROC)
ispec_selected_source_all(1:ng,:) = tmp_i_all_local(:,:)
@@ -573,44 +572,35 @@
deallocate(tmp_i_local,tmp_i_all_local)
! avoids warnings about temporary creations of arrays for function call by compiler
- allocate(tmp_local(ng),tmp_all_local(ng,0:NPROC-1))
-
- !call gather_all_dp(xi_source(ns:ne),ng,xi_source_all(1:ng,:),ng,NPROC)
+ allocate(tmp_local(ng),tmp_all_local(ng,0:NPROC-1))
tmp_local(:) = xi_source(ns:ne)
call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
xi_source_all(1:ng,:) = tmp_all_local(:,:)
- !call gather_all_dp(eta_source(ns:ne),ng,eta_source_all(1:ng,:),ng,NPROC)
tmp_local(:) = eta_source(ns:ne)
call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
eta_source_all(1:ng,:) = tmp_all_local(:,:)
- !call gather_all_dp(gamma_source(ns:ne),ng,gamma_source_all(1:ng,:),ng,NPROC)
tmp_local(:) = gamma_source(ns:ne)
call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
gamma_source_all(1:ng,:) = tmp_all_local(:,:)
- !call gather_all_dp(final_distance_source(ns:ne),ng,final_distance_source_all(1:ng,:),ng,NPROC)
tmp_local(:) = final_distance_source(ns:ne)
call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
final_distance_source_all(1:ng,:) = tmp_all_local(:,:)
- !call gather_all_dp(x_found_source(ns:ne),ng,x_found_source_all(1:ng,:),ng,NPROC)
tmp_local(:) = x_found_source(ns:ne)
call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
x_found_source_all(1:ng,:) = tmp_all_local(:,:)
- !call gather_all_dp(y_found_source(ns:ne),ng,y_found_source_all(1:ng,:),ng,NPROC)
tmp_local(:) = y_found_source(ns:ne)
call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
y_found_source_all(1:ng,:) = tmp_all_local(:,:)
- !call gather_all_dp(z_found_source(ns:ne),ng,z_found_source_all(1:ng,:),ng,NPROC)
tmp_local(:) = z_found_source(ns:ne)
call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
z_found_source_all(1:ng,:) = tmp_all_local(:,:)
- !call gather_all_dp(nu_source(:,:,ns:ne),3*3*ng,nu_source_all(:,:,1:ng,:),3*3*ng,NPROC)
do i=1,3
do j=1,3
tmp_local(:) = nu_source(i,j,ns:ne)
@@ -620,17 +610,17 @@
enddo
deallocate(tmp_local,tmp_all_local)
-! this is executed by main process only
+ ! this is executed by main process only
if(myrank == 0) then
-! check that the gather operation went well
+ ! check that the gather operation went well
if(any(ispec_selected_source_all(1:ng,:) == -1)) call exit_MPI(myrank,'gather operation failed for source')
-! loop on all the sources
+ ! loop on all the sources
do is = 1,ng
isource = ns + is - 1
-! loop on all the results to determine the best slice
+ ! loop on all the results to determine the best slice
distmin = HUGEVAL
do iprocloop = 0,NPROC-1
if(final_distance_source_all(is,iprocloop) < distmin) then
@@ -689,7 +679,7 @@
write(IMAIN,*) 'gamma coordinate of source in that element: ',gamma_source(isource)
endif
-! add message if source is a Heaviside
+ ! add message if source is a Heaviside
if(hdur(isource) < 5.*DT) then
write(IMAIN,*)
write(IMAIN,*) 'Source time function is a Heaviside, convolve later'
@@ -706,24 +696,34 @@
write(IMAIN,*) ' latitude: ',lat(isource)
write(IMAIN,*) ' longitude: ',long(isource)
write(IMAIN,*)
- write(IMAIN,*) ' UTM x: ',utm_x_source(isource)
- write(IMAIN,*) ' UTM y: ',utm_y_source(isource)
- write(IMAIN,*) ' depth: ',depth(isource),' km'
+ if( SUPPRESS_UTM_PROJECTION ) then
+ write(IMAIN,*) ' x: ',utm_x_source(isource)
+ write(IMAIN,*) ' y: ',utm_y_source(isource)
+ else
+ write(IMAIN,*) ' UTM x: ',utm_x_source(isource)
+ write(IMAIN,*) ' UTM y: ',utm_y_source(isource)
+ endif
+ write(IMAIN,*) ' z depth: ',depth(isource)
if(TOPOGRAPHY) write(IMAIN,*) 'topo elevation: ',elevation(isource),' m'
write(IMAIN,*)
write(IMAIN,*) 'position of the source that will be used:'
write(IMAIN,*)
- write(IMAIN,*) ' UTM x: ',x_found_source(isource)
- write(IMAIN,*) ' UTM y: ',y_found_source(isource)
+ if( SUPPRESS_UTM_PROJECTION ) then
+ write(IMAIN,*) ' x: ',x_found_source(isource)
+ write(IMAIN,*) ' y: ',y_found_source(isource)
+ else
+ write(IMAIN,*) ' UTM x: ',x_found_source(isource)
+ write(IMAIN,*) ' UTM y: ',y_found_source(isource)
+ endif
write(IMAIN,*) ' depth: ',dabs(z_found_source(isource) - elevation(isource))/1000.,' km'
write(IMAIN,*)
-! display error in location estimate
+ ! display error in location estimate
write(IMAIN,*) 'error in location of the source: ',sngl(final_distance_source(isource)),' m'
-! add warning if estimate is poor
-! (usually means source outside the mesh given by the user)
+ ! add warning if estimate is poor
+ ! (usually means source outside the mesh given by the user)
if(final_distance_source(isource) > 3000.d0) then
write(IMAIN,*)
write(IMAIN,*) '*****************************************************'
@@ -736,28 +736,8 @@
endif ! end of detailed output to locate source
if(PRINT_SOURCE_TIME_FUNCTION) then
-
write(IMAIN,*)
write(IMAIN,*) 'printing the source-time function'
-
-! print the source-time function
- if(NSOURCES == 1) then
- plot_file = '/plot_source_time_function.txt'
- else
- if(isource < 10) then
- write(plot_file,"('/plot_source_time_function',i1,'.txt')") isource
- else
- write(plot_file,"('/plot_source_time_function',i2,'.txt')") isource
- endif
- endif
- open(unit=27,file=trim(OUTPUT_FILES)//plot_file,status='unknown')
-
- do it=1,NSTEP
- time_source = dble(it-1)*DT
- write(27,*) sngl(time_source-t0),sngl(comp_source_time_function(time_source-t0-t_cmt(isource),hdur_gaussian(isource)))
- enddo
- close(27)
-
endif
! checks CMTSOLUTION format for acoustic case
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -440,6 +440,28 @@
!
!----
!
+!
+!
+! subroutine min_all_all_dp(sendbuf, recvbuf)
+!
+! implicit none
+!
+!! standard include of the MPI library
+! include 'mpif.h'
+! include "constants.h"
+! include "precision.h"
+!
+! double precision :: sendbuf, recvbuf
+! integer ier
+!
+! call MPI_ALLREDUCE(sendbuf,recvbuf,1,MPI_DOUBLE_PRECISION, &
+! MPI_MIN,MPI_COMM_WORLD,ier)
+!
+! end subroutine min_all_all_dp
+!
+!
+!----
+!
subroutine max_all_i(sendbuf, recvbuf)
@@ -485,6 +507,29 @@
!----
!
+
+ subroutine max_all_all_dp(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ double precision :: sendbuf, recvbuf
+ integer ier
+
+ call MPI_ALLREDUCE(sendbuf,recvbuf,1,MPI_DOUBLE_PRECISION, &
+ MPI_MAX,MPI_COMM_WORLD,ier)
+
+ end subroutine max_all_all_dp
+
+
+!
+!----
+!
+
subroutine min_all_i(sendbuf, recvbuf)
implicit none
@@ -527,6 +572,27 @@
!----
!
+ subroutine sum_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+ integer ier
+
+ call MPI_REDUCE(sendbuf,recvbuf,1,CUSTOM_MPI_TYPE, &
+ MPI_SUM,0,MPI_COMM_WORLD,ier)
+
+ end subroutine sum_all_cr
+
+!
+!----
+!
+
subroutine sum_all_i(sendbuf, recvbuf)
implicit none
Added: seismo/3D/SPECFEM3D_SESAME/trunk/param_reader.c
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/param_reader.c (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/param_reader.c 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,177 @@
+/*
+ !=====================================================================
+ !
+ ! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+ ! --------------------------------------------------
+ !
+ ! Main authors: Dimitri Komatitsch and Jeroen Tromp
+ ! Seismological Laboratory, California Institute of Technology, USA
+ ! and University of Pau / CNRS / INRIA, France
+ ! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+ ! February 2008
+ !
+ ! This program is free software; you can redistribute it and/or modify
+ ! it under the terms of the GNU General Public License as published by
+ ! the Free Software Foundation; either version 2 of the License, or
+ ! (at your option) any later version.
+ !
+ ! This program is distributed in the hope that it will be useful,
+ ! but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ! GNU General Public License for more details.
+ !
+ ! You should have received a copy of the GNU General Public License along
+ ! with this program; if not, write to the Free Software Foundation, Inc.,
+ ! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ !
+ !=====================================================================
+ */
+
+/*
+
+ by Dennis McRitchie
+
+ January 7, 2010 - par_file parsing
+ ..
+ You'll notice that the heart of the parser is a complex regular
+ expression that is compiled within the C code, and then used to split
+ the lines appropriately. It does all the heavy lifting. I don't know of
+ any way to do this in Fortran. I believe that to accomplish this in
+ Fortran, you'd have to write a lot of procedural string manipulation
+ code, for which Fortran is not very well suited.
+
+ But Fortran-C mixes are pretty common these days, so I would not expect
+ any problems on that account. There are no wrapper functions used: just
+ the C routine called directly from a Fortran routine. Also, regarding
+ the use of C, I assumed this would not be a problem since there are
+ already six C files that make up part of the build (though they all are
+ related to the pyre-framework).
+ ..
+ */
+
+#include <stdlib.h>
+#include <stdio.h>
+#define __USE_GNU
+#include <string.h>
+#include <regex.h>
+
+#define LINE_MAX 255
+
+FILE * fd;
+
+void param_open_(char * filename, int * length, int * ierr)
+{
+ char * fncopy;
+ char * blank;
+
+ // Trim the file name.
+ fncopy = strndup(filename, *length);
+ blank = strchr(fncopy, ' ');
+ if (blank != NULL) {
+ fncopy[blank - fncopy] = '\0';
+ }
+ if ((fd = fopen(fncopy, "r")) == NULL) {
+ printf("Can't open '%s'\n", fncopy);
+ *ierr = 1;
+ return;
+ }
+ free(fncopy);
+}
+
+void param_close_()
+{
+ fclose(fd);
+}
+
+void param_read_(char * string_read, int * string_read_len, char * name, int * name_len, int * ierr)
+{
+ char * namecopy;
+ char * blank;
+ char * namecopy2;
+ int status;
+ regex_t compiled_pattern;
+ char line[LINE_MAX];
+ int regret;
+ regmatch_t parameter[3];
+ char * keyword;
+ char * value;
+
+ // Trim the keyword name we're looking for.
+ namecopy = strndup(name, *name_len);
+ blank = strchr(namecopy, ' ');
+ if (blank != NULL) {
+ namecopy[blank - namecopy] = '\0';
+ }
+ // Then get rid of any dot-terminated prefix.
+ namecopy2 = strchr(namecopy, '.');
+ if (namecopy2 != NULL) {
+ namecopy2 += 1;
+ } else {
+ namecopy2 = namecopy;
+ }
+ /* Regular expression for parsing lines from param file.
+ ** Good luck reading this regular expression. Basically, the lines of
+ ** the parameter file should be of the form 'parameter = value'. Blank
+ ** lines, lines containing only white space and lines whose first non-
+ ** whitespace character is '#' are ignored. White space is generally
+ ** ignored. As you will see later in the code, if both parameter and
+ ** value are not specified the line is ignored.
+ */
+ char pattern[] = "^[ \t]*([^# \t]*)[ \t]*=[ \t]*([^# \t]*)[ \t]*(#.*){0,1}$";
+
+ // Compile the regular expression.
+ status = regcomp(&compiled_pattern, pattern, REG_EXTENDED);
+ if (status != 0) {
+ printf("regcomp returned error %d\n", status);
+ }
+ // Position the open file to the beginning.
+ if (fseek(fd, 0, SEEK_SET) != 0) {
+ printf("Can't seek to begining of parameter file\n");
+ *ierr = 1;
+ return;
+ }
+ // Read every line in the file.
+ while (fgets(line, LINE_MAX, fd) != NULL) {
+ // Get rid of the ending newline.
+ int linelen = strlen(line);
+ if (line[linelen-1] == '\n') {
+ line[linelen-1] = '\0';
+ }
+ /* Test if line matches the regular expression pattern, if so
+ ** return position of keyword and value */
+ regret = regexec(&compiled_pattern, line, 3, parameter, 0);
+ // If no match, check the next line.
+ if (regret == REG_NOMATCH) {
+ continue;
+ }
+ // If any error, bail out with an error message.
+ if(regret != 0) {
+ printf("regexec returned error %d\n", regret);
+ *ierr = 1;
+ return;
+ }
+ // printf("Line read = %s\n", line);
+ // If we have a match, extract the keyword from the line.
+ keyword = strndup(line+parameter[1].rm_so, parameter[1].rm_eo-parameter[1].rm_so);
+ // If the keyword is not the one we're looking for, check the next line.
+ if (strcmp(keyword, namecopy2) != 0) {
+ free(keyword);
+ continue;
+ }
+ free(keyword);
+ // If it matches, extract the value from the line.
+ value = strndup(line+parameter[2].rm_so, parameter[2].rm_eo-parameter[2].rm_so);
+ // Clear out the return string with blanks, copy the value into it, and return.
+ memset(string_read, ' ', *string_read_len);
+ strncpy(string_read, value, strlen(value));
+ free(value);
+ free(namecopy);
+ *ierr = 0;
+ return;
+ }
+ // If no keyword matches, print out error and die.
+ printf("No match in parameter file for keyword %s\n", namecopy);
+ free(namecopy);
+ *ierr = 1;
+ return;
+}
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -31,15 +31,20 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
+ use specfem_par_movie
+
implicit none
-
- double precision :: scale_factor
- real(kind=CUSTOM_REAL):: vs_val
- integer :: i,j,k,ispec
- integer :: iattenuation,iselected
-
+ character(len=256) :: plot_file
-! user info
+ ! flag for any movie simulation
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP .or. &
+ MOVIE_SURFACE .or. CREATE_SHAKEMAP .or. MOVIE_VOLUME .or. PNM_GIF_IMAGE ) then
+ MOVIE_SIMULATION = .true.
+ else
+ MOVIE_SIMULATION = .false.
+ endif
+
+ ! user info
if(myrank == 0) then
write(IMAIN,*)
@@ -96,12 +101,121 @@
write(IMAIN,*) 'no poroelastic simulation'
endif
write(IMAIN,*)
+
+ write(IMAIN,*)
+ if(MOVIE_SIMULATION) then
+ write(IMAIN,*) 'incorporating movie simulation'
+ else
+ write(IMAIN,*) 'no movie simulation'
+ endif
+ write(IMAIN,*)
+
endif
-! synchronize all the processes before assembling the mass matrix
-! to make sure all the nodes have finished to read their databases
+ ! synchronize all the processes before assembling the mass matrix
+ ! to make sure all the nodes have finished to read their databases
call sync_all()
+ ! sets up mass matrices
+ call prepare_timerun_mass_matrices()
+
+
+ ! initialize acoustic arrays to zero
+ if( ACOUSTIC_SIMULATION ) then
+ potential_acoustic(:) = 0._CUSTOM_REAL
+ potential_dot_acoustic(:) = 0._CUSTOM_REAL
+ potential_dot_dot_acoustic(:) = 0._CUSTOM_REAL
+ ! put negligible initial value to avoid very slow underflow trapping
+ if(FIX_UNDERFLOW_PROBLEM) potential_dot_dot_acoustic(:) = VERYSMALLVAL
+ endif
+
+ ! initialize elastic arrays to zero/verysmallvall
+ if( ELASTIC_SIMULATION ) then
+ displ(:,:) = 0._CUSTOM_REAL
+ veloc(:,:) = 0._CUSTOM_REAL
+ accel(:,:) = 0._CUSTOM_REAL
+ ! put negligible initial value to avoid very slow underflow trapping
+ if(FIX_UNDERFLOW_PROBLEM) displ(:,:) = VERYSMALLVAL
+ endif
+
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ deltat = sngl(DT)
+ else
+ deltat = DT
+ endif
+ deltatover2 = deltat/2._CUSTOM_REAL
+ deltatsqover2 = deltat*deltat/2._CUSTOM_REAL
+
+ ! seismograms
+ if (nrec_local > 0) then
+ ! allocate seismogram array
+ allocate(seismograms_d(NDIM,nrec_local,NSTEP))
+ allocate(seismograms_v(NDIM,nrec_local,NSTEP))
+ allocate(seismograms_a(NDIM,nrec_local,NSTEP))
+
+ ! initialize seismograms
+ seismograms_d(:,:,:) = 0._CUSTOM_REAL
+ seismograms_v(:,:,:) = 0._CUSTOM_REAL
+ seismograms_a(:,:,:) = 0._CUSTOM_REAL
+ endif
+
+ ! prepares attenuation arrays
+ call prepare_timerun_attenuation()
+
+ ! initializes PML arrays
+ if( ABSORBING_CONDITIONS ) then
+ if (SIMULATION_TYPE /= 1 .and. ABSORB_USE_PML ) then
+ write(IMAIN,*) 'NOTE: adjoint simulations and PML not supported yet...'
+ else
+ if( ABSORB_USE_PML ) then
+ call PML_initialize()
+ endif
+ endif
+ endif
+
+ ! opens source time function file
+ if(PRINT_SOURCE_TIME_FUNCTION .and. myrank == 0) then
+ ! print the source-time function
+ if(NSOURCES == 1) then
+ plot_file = '/plot_source_time_function.txt'
+ else
+ if(NSOURCES < 10) then
+ write(plot_file,"('/plot_source_time_function',i1,'.txt')") NSOURCES
+ else
+ write(plot_file,"('/plot_source_time_function',i2,'.txt')") NSOURCES
+ endif
+ endif
+ open(unit=IOSTF,file=trim(OUTPUT_FILES)//plot_file,status='unknown')
+ endif
+
+ ! user output
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' time step: ',sngl(DT),' s'
+ write(IMAIN,*) 'number of time steps: ',NSTEP
+ write(IMAIN,*) 'total simulated time: ',sngl(NSTEP*DT),' seconds'
+ write(IMAIN,*)
+ endif
+
+ ! prepares ADJOINT simulations
+ call prepare_timerun_adjoint()
+
+ end subroutine prepare_timerun
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_timerun_mass_matrices()
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ implicit none
+
! the mass matrix needs to be assembled with MPI here once and for all
if(ACOUSTIC_SIMULATION) then
call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass_acoustic, &
@@ -135,8 +249,8 @@
if(POROELASTIC_SIMULATION) then
- stop 'poroelastic simulation not implemented yet'
-
+ stop 'poroelastic simulation not implemented yet'
+ ! but would be something like this...
call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass_solid_poroelastic, &
num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
@@ -147,7 +261,7 @@
nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
my_neighbours_ext_mesh)
- ! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ ! fills mass matrix with fictitious non-zero values to make sure it can be inverted globally
where(rmass_solid_poroelastic <= 0._CUSTOM_REAL) rmass_solid_poroelastic = 1._CUSTOM_REAL
where(rmass_fluid_poroelastic <= 0._CUSTOM_REAL) rmass_fluid_poroelastic = 1._CUSTOM_REAL
rmass_solid_poroelastic(:) = 1._CUSTOM_REAL / rmass_solid_poroelastic(:)
@@ -157,81 +271,27 @@
if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix'
-! initialize acoustic arrays to zero
- if( ACOUSTIC_SIMULATION ) then
- potential_acoustic(:) = 0._CUSTOM_REAL
- potential_dot_acoustic(:) = 0._CUSTOM_REAL
- potential_dot_dot_acoustic(:) = 0._CUSTOM_REAL
- ! put negligible initial value to avoid very slow underflow trapping
- if(FIX_UNDERFLOW_PROBLEM) potential_dot_dot_acoustic(:) = VERYSMALLVAL
- endif
-
-! initialize elastic arrays to zero/verysmallvall
- if( ELASTIC_SIMULATION ) then
- displ(:,:) = 0._CUSTOM_REAL
- veloc(:,:) = 0._CUSTOM_REAL
- accel(:,:) = 0._CUSTOM_REAL
- ! put negligible initial value to avoid very slow underflow trapping
- if(FIX_UNDERFLOW_PROBLEM) displ(:,:) = VERYSMALLVAL
- endif
- !! DK DK array not created yet for CUBIT
- ! if (SIMULATION_TYPE == 3) then ! kernel calculation, read in last frame
- ! open(unit=27,file=trim(prname)//'save_forward_arrays.bin',status='old',action='read',form='unformatted')
- ! read(27) b_displ
- ! read(27) b_veloc
- ! read(27) b_accel
- ! rho_kl(:,:,:,:) = 0._CUSTOM_REAL
- ! mu_kl(:,:,:,:) = 0._CUSTOM_REAL
- ! kappa_kl(:,:,:,:) = 0._CUSTOM_REAL
- ! endif
+ end subroutine prepare_timerun_mass_matrices
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- deltat = sngl(DT)
- else
- deltat = DT
- endif
- deltatover2 = deltat/2.
- deltatsqover2 = deltat*deltat/2.
- ! if (SIMULATION_TYPE == 3) then
- ! if(CUSTOM_REAL == SIZE_REAL) then
- ! b_deltat = - sngl(DT)
- ! else
- ! b_deltat = - DT
- ! endif
- ! b_deltatover2 = b_deltat/2.
- ! b_deltatsqover2 = b_deltat*b_deltat/2.
- ! endif
+!
+!-------------------------------------------------------------------------------------------------
+!
-! seismograms
- if (nrec_local > 0) then
- ! allocate seismogram array
- allocate(seismograms_d(NDIM,nrec_local,NSTEP))
- allocate(seismograms_v(NDIM,nrec_local,NSTEP))
- allocate(seismograms_a(NDIM,nrec_local,NSTEP))
-
- ! initialize seismograms
- seismograms_d(:,:,:) = 0._CUSTOM_REAL
- seismograms_v(:,:,:) = 0._CUSTOM_REAL
- seismograms_a(:,:,:) = 0._CUSTOM_REAL
-
- ! if (SIMULATION_TYPE == 2) then
- ! ! allocate Frechet derivatives array
- ! allocate(Mxx_der(nrec_local),Myy_der(nrec_local),Mzz_der(nrec_local),Mxy_der(nrec_local), &
- ! Mxz_der(nrec_local),Myz_der(nrec_local), sloc_der(NDIM,nrec_local))
- ! Mxx_der = 0._CUSTOM_REAL
- ! Myy_der = 0._CUSTOM_REAL
- ! Mzz_der = 0._CUSTOM_REAL
- ! Mxy_der = 0._CUSTOM_REAL
- ! Mxz_der = 0._CUSTOM_REAL
- ! Myz_der = 0._CUSTOM_REAL
- ! sloc_der = 0._CUSTOM_REAL
- ! allocate(seismograms_eps(NDIM,NDIM,nrec_local,NSTEP))
- ! seismograms_eps(:,:,:,:) = 0._CUSTOM_REAL
- ! endif
- endif
+ subroutine prepare_timerun_attenuation()
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ implicit none
+
+ ! local parameters
+ double precision :: scale_factor
+ real(kind=CUSTOM_REAL):: vs_val
+ integer :: i,j,k,ispec
+ integer :: iattenuation,iselected
+
! if attenuation is on, shift PREM to right frequency
! rescale mu in PREM to average frequency for attenuation
if(ATTENUATION) then
@@ -285,20 +345,16 @@
enddo
! precompute Runge-Kutta coefficients if attenuation
- tauinv(:,:) = - 1. / tau_sigma(:,:)
- factor_common(:,:) = 2. * beta(:,:) * tauinv(:,:)
- alphaval(:,:) = 1 + deltat*tauinv(:,:) + deltat**2*tauinv(:,:)**2 / 2. + &
- deltat**3*tauinv(:,:)**3 / 6. + deltat**4*tauinv(:,:)**4 / 24.
- betaval(:,:) = deltat / 2. + deltat**2*tauinv(:,:) / 3. + deltat**3*tauinv(:,:)**2 / 8. + deltat**4*tauinv(:,:)**3 / 24.
- gammaval(:,:) = deltat / 2. + deltat**2*tauinv(:,:) / 6. + deltat**3*tauinv(:,:)**2 / 24.
- !if (SIMULATION_TYPE == 3) then
- ! b_alphaval(:,:) = 1 + b_deltat*tauinv(:,:) + b_deltat**2*tauinv(:,:)**2 / 2. + &
- ! b_deltat**3*tauinv(:,:)**3 / 6. + b_deltat**4*tauinv(:,:)**4 / 24.
- ! b_betaval(:,:) = b_deltat / 2. + b_deltat**2*tauinv(:,:) / 3. + &
- ! b_deltat**3*tauinv(:,:)**2 / 8. + b_deltat**4*tauinv(:,:)**3 / 24.
- ! b_gammaval(:,:) = b_deltat / 2. + b_deltat**2*tauinv(:,:) / 6. + &
- ! b_deltat**3*tauinv(:,:)**2 / 24.
- !endif
+ tauinv(:,:) = - 1._CUSTOM_REAL / tau_sigma(:,:)
+ factor_common(:,:) = 2._CUSTOM_REAL * beta(:,:) * tauinv(:,:)
+ alphaval(:,:) = 1 + deltat*tauinv(:,:) + deltat**2*tauinv(:,:)**2 / 2._CUSTOM_REAL &
+ + deltat**3*tauinv(:,:)**3 / 6._CUSTOM_REAL &
+ + deltat**4*tauinv(:,:)**4 / 24._CUSTOM_REAL
+ betaval(:,:) = deltat / 2._CUSTOM_REAL + deltat**2*tauinv(:,:) / 3._CUSTOM_REAL &
+ + deltat**3*tauinv(:,:)**2 / 8._CUSTOM_REAL &
+ + deltat**4*tauinv(:,:)**3 / 24._CUSTOM_REAL
+ gammaval(:,:) = deltat / 2._CUSTOM_REAL + deltat**2*tauinv(:,:) / 6._CUSTOM_REAL &
+ + deltat**3*tauinv(:,:)**2 / 24._CUSTOM_REAL
endif
@@ -339,47 +395,197 @@
R_xz(:,:,:,:,:) = VERYSMALLVAL
R_yz(:,:,:,:,:) = VERYSMALLVAL
endif
+ endif
- !! DK DK array not created yet for CUBIT
- ! if (SIMULATION_TYPE == 3) then
- ! read(27) b_R_xx
- ! read(27) b_R_yy
- ! read(27) b_R_xy
- ! read(27) b_R_xz
- ! read(27) b_R_yz
- ! read(27) b_epsilondev_xx
- ! read(27) b_epsilondev_yy
- ! read(27) b_epsilondev_xy
- ! read(27) b_epsilondev_xz
- ! read(27) b_epsilondev_yz
- ! endif
- ! close(27)
+ end subroutine prepare_timerun_attenuation
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_timerun_adjoint()
+
+! prepares adjoint simulations
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ implicit none
+
+ integer :: ier
+
+! seismograms
+ if (nrec_local > 0 .and. SIMULATION_TYPE == 2 ) then
+ ! allocate Frechet derivatives array
+ allocate(Mxx_der(nrec_local),Myy_der(nrec_local), &
+ Mzz_der(nrec_local),Mxy_der(nrec_local), &
+ Mxz_der(nrec_local),Myz_der(nrec_local), &
+ sloc_der(NDIM,nrec_local))
+ Mxx_der = 0._CUSTOM_REAL
+ Myy_der = 0._CUSTOM_REAL
+ Mzz_der = 0._CUSTOM_REAL
+ Mxy_der = 0._CUSTOM_REAL
+ Mxz_der = 0._CUSTOM_REAL
+ Myz_der = 0._CUSTOM_REAL
+ sloc_der = 0._CUSTOM_REAL
+
+ allocate(seismograms_eps(NDIM,NDIM,nrec_local,NSTEP))
+ seismograms_eps(:,:,:,:) = 0._CUSTOM_REAL
endif
-! initialize Moho boundary index
-! if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
-! ispec2D_moho_top = 0
-! ispec2D_moho_bot = 0
-! k_top = 1
-! k_bot = NGLLZ
-! endif
+! timing
+ if (SIMULATION_TYPE == 3) then
+
+ ! backward/reconstructed wavefields: time stepping is in time-reversed sense
+ ! (negative time increments)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ b_deltat = - sngl(DT)
+ else
+ b_deltat = - DT
+ endif
+ b_deltatover2 = b_deltat/2._CUSTOM_REAL
+ b_deltatsqover2 = b_deltat*b_deltat/2._CUSTOM_REAL
+
+ endif
- ! initializes PML arrays
- if( ABSORBING_CONDITIONS ) then
- if( ABSORB_USE_PML ) then
- call PML_initialize()
+! attenuation backward memories
+ if( ATTENUATION .and. SIMULATION_TYPE == 3 ) then
+ ! precompute Runge-Kutta coefficients if attenuation
+ b_alphaval(:,:) = 1 + b_deltat*tauinv(:,:) + b_deltat**2*tauinv(:,:)**2 / 2._CUSTOM_REAL &
+ + b_deltat**3*tauinv(:,:)**3 / 6._CUSTOM_REAL &
+ + b_deltat**4*tauinv(:,:)**4 / 24._CUSTOM_REAL
+ b_betaval(:,:) = b_deltat / 2._CUSTOM_REAL + b_deltat**2*tauinv(:,:) / 3._CUSTOM_REAL &
+ + b_deltat**3*tauinv(:,:)**2 / 8._CUSTOM_REAL &
+ + b_deltat**4*tauinv(:,:)**3 / 24._CUSTOM_REAL
+ b_gammaval(:,:) = b_deltat / 2._CUSTOM_REAL + b_deltat**2*tauinv(:,:) / 6._CUSTOM_REAL &
+ + b_deltat**3*tauinv(:,:)**2 / 24._CUSTOM_REAL
+ endif
+
+! kernel calculation, reads in last frame
+ if (SIMULATION_TYPE == 3) then
+ ! reads in wavefields
+ open(unit=27,file=trim(prname)//'save_forward_arrays.bin',status='old',&
+ action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: opening save_forward_arrays'
+ print*,'path: ',trim(prname)//'save_forward_arrays.bin'
+ call exit_mpi(myrank,'error open file save_forward_arrays.bin')
endif
+
+ if( ACOUSTIC_SIMULATION ) then
+ read(27) b_potential_acoustic
+ read(27) b_potential_dot_acoustic
+ read(27) b_potential_dot_dot_acoustic
+ endif
+
+ ! elastic wavefields
+ if( ELASTIC_SIMULATION ) then
+ read(27) b_displ
+ read(27) b_veloc
+ read(27) b_accel
+ endif
+
+ ! memory variables if attenuation
+ if( ATTENUATION ) then
+ read(27) b_R_xx
+ read(27) b_R_yy
+ read(27) b_R_xy
+ read(27) b_R_xz
+ read(27) b_R_yz
+ read(27) b_epsilondev_xx
+ read(27) b_epsilondev_yy
+ read(27) b_epsilondev_xy
+ read(27) b_epsilondev_xz
+ read(27) b_epsilondev_yz
+ endif
+
+ close(27)
endif
-
-! user output
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) ' time step: ',sngl(DT),' s'
- write(IMAIN,*) 'number of time steps: ',NSTEP
- write(IMAIN,*) 'total simulated time: ',sngl(NSTEP*DT),' seconds'
- write(IMAIN,*)
+
+! initializes adjoint kernels
+ if (SIMULATION_TYPE == 3) then
+ ! elastic domain
+ if( ELASTIC_SIMULATION ) then
+ rho_kl(:,:,:,:) = 0._CUSTOM_REAL
+ mu_kl(:,:,:,:) = 0._CUSTOM_REAL
+ kappa_kl(:,:,:,:) = 0._CUSTOM_REAL
+ endif
+
+ ! acoustic domain
+ if( ACOUSTIC_SIMULATION ) then
+ rho_ac_kl(:,:,:,:) = 0._CUSTOM_REAL
+ kappa_ac_kl(:,:,:,:) = 0._CUSTOM_REAL
+ endif
endif
+! initialize Moho boundary index
+ if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+ ispec2D_moho_top = 0
+ ispec2D_moho_bot = 0
+ endif
+
+! stacey absorbing fields will be reconstructed for adjoint simulations
+! using snapshot files of wavefields
+ if( ABSORBING_CONDITIONS ) then
+
+ ! opens absorbing wavefield saved/to-be-saved by forward simulations
+ if( num_abs_boundary_faces > 0 .and. (SIMULATION_TYPE == 3 .or. &
+ (SIMULATION_TYPE == 1 .and. SAVE_FORWARD)) ) then
- end subroutine
\ No newline at end of file
+ b_num_abs_boundary_faces = num_abs_boundary_faces
+
+ ! elastic domains
+ if( ELASTIC_SIMULATION) then
+ ! allocates wavefield
+ allocate(b_absorb_field(NDIM,NGLLSQUARE,b_num_abs_boundary_faces))
+
+ b_reclen_field = CUSTOM_REAL * (NDIM * NGLLSQUARE * num_abs_boundary_faces)
+
+ if (SIMULATION_TYPE == 3) then
+ ! opens existing files
+ open(unit=IOABS,file=trim(prname)//'absorb_field.bin',status='old',&
+ action='read',form='unformatted',access='direct', &
+ recl=b_reclen_field+2*sizeof(b_reclen_field) )
+ else
+ ! opens new file
+ open(unit=IOABS,file=trim(prname)//'absorb_field.bin',status='unknown',&
+ form='unformatted',access='direct',&
+ recl=b_reclen_field+2*sizeof(b_reclen_field) )
+ endif
+ endif
+
+ ! acoustic domains
+ if( ACOUSTIC_SIMULATION) then
+ ! allocates wavefield
+ allocate(b_absorb_potential(NGLLSQUARE,b_num_abs_boundary_faces))
+
+ b_reclen_potential = CUSTOM_REAL * (NGLLSQUARE * num_abs_boundary_faces)
+
+ if (SIMULATION_TYPE == 3) then
+ ! opens existing files
+ open(unit=IOABS_AC,file=trim(prname)//'absorb_potential.bin',status='old',&
+ action='read',form='unformatted',access='direct', &
+ recl=b_reclen_potential+2*sizeof(b_reclen_potential) )
+ else
+ ! opens new file
+ open(unit=IOABS_AC,file=trim(prname)//'absorb_potential.bin',status='unknown',&
+ form='unformatted',access='direct',&
+ recl=b_reclen_potential+2*sizeof(b_reclen_potential) )
+ endif
+ endif
+
+ else
+ ! dummy array
+ b_num_abs_boundary_faces = 1
+ if( ELASTIC_SIMULATION ) &
+ allocate(b_absorb_field(NDIM,NGLLSQUARE,b_num_abs_boundary_faces))
+
+ if( ACOUSTIC_SIMULATION ) &
+ allocate(b_absorb_potential(NGLLSQUARE,b_num_abs_boundary_faces))
+
+ endif
+ endif
+
+ end subroutine prepare_timerun_adjoint
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -34,15 +34,30 @@
implicit none
integer :: i,j,k,ispec,iglob
- integer :: iinterface
+ integer :: iinterface,ier
+ real(kind=CUSTOM_REAL):: minl,maxl,min_all,max_all
! start reading the databasesa
! info about external mesh simulation
call create_name_database(prname,myrank,LOCAL_PATH)
- open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
+ open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',&
+ action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: could not open database '
+ print*,'path: ',prname(1:len_trim(prname))//'external_mesh.bin'
+ call exit_mpi(myrank,'error opening database')
+ endif
+
read(27) NSPEC_AB
read(27) NGLOB_AB
+
+ read(27) ibool
+
+ read(27) xstore
+ read(27) ystore
+ read(27) zstore
+
read(27) xix
read(27) xiy
read(27) xiz
@@ -54,12 +69,6 @@
read(27) gammaz
read(27) jacobian
- read(27) ibool
-
- read(27) xstore
- read(27) ystore
- read(27) zstore
-
read(27) kappastore
read(27) mustore
@@ -137,7 +146,7 @@
call any_all_l( ANY(ispec_is_poroelastic), POROELASTIC_SIMULATION )
if( POROELASTIC_SIMULATION ) then
- stop 'not implemented yet '
+ stop 'not implemented yet: read rmass_solid_poroelastic .. '
allocate(rmass_solid_poroelastic(NGLOB_AB))
allocate(rmass_fluid_poroelastic(NGLOB_AB))
@@ -266,37 +275,95 @@
enddo
enddo
enddo
- deallocate( iglob_is_inner )
-
-! counts inner and outer elements
-! nspec_inner = 0
-! nspec_outer = 0
-! do ispec = 1, NSPEC_AB
-! if( ispec_is_inner_ext_mesh(ispec) .eqv. .true. ) then
-! nspec_inner = nspec_inner + 1
-! else
-! nspec_outer = nspec_outer + 1
-! endif
-! enddo
+ deallocate( iglob_is_inner )
-! stores indices of inner and outer elements for faster(?) compute_forces_with_Deville routine
-! if( nspec_inner > 0 ) allocate( spec_inner(nspec_inner))
-! if( nspec_outer > 0 ) allocate( spec_outer(nspec_outer))
-! nspec_inner = 0
-! nspec_outer = 0
-! do ispec = 1, NSPEC_AB
-! if( ispec_is_inner_ext_mesh(ispec) .eqv. .true. ) then
-! nspec_inner = nspec_inner + 1
-! spec_inner(nspec_inner) = ispec
-! else
-! nspec_outer = nspec_outer + 1
-! spec_outer(nspec_outer) = ispec
-! endif
-! enddo
- !print *,'rank ',myrank,' inner spec: ',nspec_inner
- !print *,'rank ',myrank,' outer spec: ',nspec_outer
+! sets up elements for loops in acoustic simulations
+ if( ACOUSTIC_SIMULATION ) then
+ ! counts inner and outer elements
+ nspec_inner_acoustic = 0
+ nspec_outer_acoustic = 0
+ do ispec = 1, NSPEC_AB
+ if( ispec_is_acoustic(ispec) ) then
+ if( ispec_is_inner(ispec) .eqv. .true. ) then
+ nspec_inner_acoustic = nspec_inner_acoustic + 1
+ else
+ nspec_outer_acoustic = nspec_outer_acoustic + 1
+ endif
+ endif
+ enddo
+
+ ! stores indices of inner and outer elements for faster(?) computation
+ num_phase_ispec_acoustic = max(nspec_inner_acoustic,nspec_outer_acoustic)
+ allocate( phase_ispec_inner_acoustic(num_phase_ispec_acoustic,2))
+ nspec_inner_acoustic = 0
+ nspec_outer_acoustic = 0
+ do ispec = 1, NSPEC_AB
+ if( ispec_is_acoustic(ispec) ) then
+ if( ispec_is_inner(ispec) .eqv. .true. ) then
+ nspec_inner_acoustic = nspec_inner_acoustic + 1
+ phase_ispec_inner_acoustic(nspec_inner_acoustic,2) = ispec
+ else
+ nspec_outer_acoustic = nspec_outer_acoustic + 1
+ phase_ispec_inner_acoustic(nspec_outer_acoustic,1) = ispec
+ endif
+ endif
+ enddo
+ !print *,'rank ',myrank,' acoustic inner spec: ',nspec_inner_acoustic
+ !print *,'rank ',myrank,' acoustic outer spec: ',nspec_outer_acoustic
+ endif
-
+! sets up elements for loops in acoustic simulations
+ if( ELASTIC_SIMULATION ) then
+ ! counts inner and outer elements
+ nspec_inner_elastic = 0
+ nspec_outer_elastic = 0
+ do ispec = 1, NSPEC_AB
+ if( ispec_is_elastic(ispec) ) then
+ if( ispec_is_inner(ispec) .eqv. .true. ) then
+ nspec_inner_elastic = nspec_inner_elastic + 1
+ else
+ nspec_outer_elastic = nspec_outer_elastic + 1
+ endif
+ endif
+ enddo
+
+ ! stores indices of inner and outer elements for faster(?) computation
+ num_phase_ispec_elastic = max(nspec_inner_elastic,nspec_outer_elastic)
+ allocate( phase_ispec_inner_elastic(num_phase_ispec_elastic,2))
+ nspec_inner_elastic = 0
+ nspec_outer_elastic = 0
+ do ispec = 1, NSPEC_AB
+ if( ispec_is_elastic(ispec) ) then
+ if( ispec_is_inner(ispec) .eqv. .true. ) then
+ nspec_inner_elastic = nspec_inner_elastic + 1
+ phase_ispec_inner_elastic(nspec_inner_elastic,2) = ispec
+ else
+ nspec_outer_elastic = nspec_outer_elastic + 1
+ phase_ispec_inner_elastic(nspec_outer_elastic,1) = ispec
+ endif
+ endif
+ enddo
+ !print *,'rank ',myrank,' elastic inner spec: ',nspec_inner_elastic
+ !print *,'rank ',myrank,' elastic outer spec: ',nspec_outer_elastic
+ endif
+
+
+
+! gets model dimensions
+ minl = minval( xstore )
+ maxl = maxval( xstore )
+ call min_all_all_cr(minl,min_all)
+ call max_all_all_cr(maxl,max_all)
+ LATITUDE_MIN = min_all
+ LATITUDE_MAX = max_all
+
+ minl = minval( ystore )
+ maxl = maxval( ystore )
+ call min_all_all_cr(minl,min_all)
+ call max_all_all_cr(maxl,max_all)
+ LONGITUDE_MIN = min_all
+ LONGITUDE_MAX = max_all
+
! check courant criteria on mesh
if( ELASTIC_SIMULATION ) then
call check_mesh_resolution(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, &
@@ -311,4 +378,169 @@
deallocate(rho_vp,rho_vs)
endif
- end subroutine
\ No newline at end of file
+! reads adjoint parameters
+ call read_mesh_databases_adjoint()
+
+ end subroutine read_mesh_databases
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_mesh_databases_adjoint()
+
+! reads in moho meshes
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_poroelastic
+ implicit none
+
+ integer :: ier
+
+! allocates adjoint arrays for elastic simulations
+ if( ELASTIC_SIMULATION .and. SIMULATION_TYPE == 3 ) then
+ ! backward displacement,velocity,acceleration fields
+ allocate(b_displ(NDIM,NGLOB_ADJOINT))
+ allocate(b_veloc(NDIM,NGLOB_ADJOINT))
+ allocate(b_accel(NDIM,NGLOB_ADJOINT))
+
+ ! adjoint kernels
+
+ ! primary, isotropic kernels
+ ! density kernel
+ allocate(rho_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ ! shear modulus kernel
+ allocate(mu_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ ! compressional modulus kernel
+ allocate(kappa_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+
+ ! derived kernels
+ ! density prime kernel
+ allocate(rhop_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ ! vp kernel
+ allocate(alpha_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ ! vs kernel
+ allocate(beta_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+
+ ! MPI handling
+ allocate(b_request_send_vector_ext_mesh(num_interfaces_ext_mesh))
+ allocate(b_request_recv_vector_ext_mesh(num_interfaces_ext_mesh))
+ allocate(b_buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(b_buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+
+ endif
+
+! allocates adjoint arrays for acoustic simulations
+ if( ACOUSTIC_SIMULATION .and. SIMULATION_TYPE == 3 ) then
+ ! backward potentials
+ allocate(b_potential_acoustic(NGLOB_ADJOINT))
+ allocate(b_potential_dot_acoustic(NGLOB_ADJOINT))
+ allocate(b_potential_dot_dot_acoustic(NGLOB_ADJOINT))
+
+ ! kernels
+ allocate(rho_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ allocate(rhop_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ allocate(kappa_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ allocate(alpha_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+
+ ! MPI handling
+ allocate(b_request_send_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(b_request_recv_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(b_buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(b_buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+
+ endif
+
+! allocates attenuation solids
+ if( ATTENUATION .and. SIMULATION_TYPE == 3 ) then
+ allocate(b_R_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS), &
+ b_R_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS), &
+ b_R_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS), &
+ b_R_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS), &
+ b_R_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS) )
+
+ allocate(b_epsilondev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL), &
+ b_epsilondev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL), &
+ b_epsilondev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL), &
+ b_epsilondev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL), &
+ b_epsilondev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL) )
+ endif
+
+! ADJOINT moho
+! moho boundary
+ if( ELASTIC_SIMULATION ) then
+ allocate( is_moho_top(NSPEC_BOUN),is_moho_bot(NSPEC_BOUN) )
+
+ if( SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3 ) then
+
+ ! boundary elements
+ !open(unit=27,file=prname(1:len_trim(prname))//'ibelm_moho.bin',status='unknown',form='unformatted')
+ open(unit=27,file=prname(1:len_trim(prname))//'ibelm_moho.bin',status='old',&
+ form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: could not open ibelm_moho '
+ print*,'path: ',prname(1:len_trim(prname))//'ibelm_moho.bin'
+ call exit_mpi(myrank,'error opening ibelm_moho')
+ endif
+
+ read(27) NSPEC2D_MOHO
+
+ ! allocates arrays for moho mesh
+ allocate(ibelm_moho_bot(NSPEC2D_MOHO))
+ allocate(ibelm_moho_top(NSPEC2D_MOHO))
+ allocate(normal_moho_top(NDIM,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(normal_moho_bot(NDIM,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(ijk_moho_bot(3,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(ijk_moho_top(3,NGLLSQUARE,NSPEC2D_MOHO))
+
+ read(27) ibelm_moho_top
+ read(27) ibelm_moho_bot
+ read(27) ijk_moho_top
+ read(27) ijk_moho_bot
+
+ close(27)
+
+ ! normals
+ open(unit=27,file=prname(1:len_trim(prname))//'normal_moho.bin',status='old',&
+ form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: could not open normal_moho '
+ print*,'path: ',prname(1:len_trim(prname))//'normal_moho.bin'
+ call exit_mpi(myrank,'error opening normal_moho')
+ endif
+
+ read(27) normal_moho_top
+ read(27) normal_moho_bot
+ close(27)
+
+ ! flags
+ open(unit=27,file=prname(1:len_trim(prname))//'is_moho.bin',status='old',&
+ form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: could not open is_moho '
+ print*,'path: ',prname(1:len_trim(prname))//'is_moho.bin'
+ call exit_mpi(myrank,'error opening is_moho')
+ endif
+
+ read(27) is_moho_top
+ read(27) is_moho_bot
+
+ close(27)
+
+ ! moho kernel
+ allocate( moho_kl(NGLLSQUARE,NSPEC2D_MOHO) )
+ moho_kl = 0._CUSTOM_REAL
+
+ else
+ NSPEC2D_MOHO = 1
+ endif
+
+ allocate( dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO), &
+ dsdx_bot(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO), &
+ b_dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO), &
+ b_dsdx_bot(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO) )
+ endif
+
+ end subroutine read_mesh_databases_adjoint
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_parameter_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_parameter_file.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_parameter_file.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -23,21 +23,20 @@
!
!=====================================================================
- subroutine read_parameter_file( &
- NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
- UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
- ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
- OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
- MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
- SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION,NTSTEP_BETWEEN_OUTPUT_INFO, &
- SIMULATION_TYPE,SAVE_FORWARD)
+ subroutine read_parameter_file( NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
+ OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
+ MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
+ SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION,NTSTEP_BETWEEN_OUTPUT_INFO, &
+ SIMULATION_TYPE,SAVE_FORWARD )
implicit none
include "constants.h"
- integer NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,SIMULATION_TYPE
+ integer NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,SIMULATION_TYPE
integer NSOURCES,NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO,UTM_PROJECTION_ZONE
double precision DT,HDUR_MOVIE
@@ -49,41 +48,30 @@
character(len=256) LOCAL_PATH,CMTSOLUTION
! local variables
- integer ios,icounter,isource,idummy
-
- double precision hdur,minval_hdur
-
- character(len=256) dummystring
-
+ integer ::ios,icounter,isource,idummy
+ double precision :: hdur,minval_hdur
+ character(len=256) :: dummystring
integer, external :: err_occurred
- open(unit=IIN,file='DATA/Par_file',status='old',action='read')
+ ! opens file DATA/Par_file
+ call open_parameter_file()
+ ! reads in parameters
call read_value_integer(SIMULATION_TYPE, 'solver.SIMULATION_TYPE')
if(err_occurred() /= 0) return
call read_value_logical(SAVE_FORWARD, 'solver.SAVE_FORWARD')
if(err_occurred() /= 0) return
-
call read_value_integer(UTM_PROJECTION_ZONE, 'mesher.UTM_PROJECTION_ZONE')
if(err_occurred() /= 0) return
call read_value_logical(SUPPRESS_UTM_PROJECTION, 'mesher.SUPPRESS_UTM_PROJECTION')
if(err_occurred() /= 0) return
-
- call read_value_integer(NPROC_XI, 'mesher.NPROC_XI')
+ ! total number of processors
+ call read_value_integer(NPROC, 'mesher.NPROC')
if(err_occurred() /= 0) return
- call read_value_integer(NPROC_ETA, 'mesher.NPROC_ETA')
- if(err_occurred() /= 0) return
-
-! total number of processors in each of the six chunks
-! it is later (generate_parameters.f90 & specfem3D.f90 set to sizeprocs.
-! This will have to be fixed
- NPROC = NPROC_XI * NPROC_ETA
-
call read_value_integer(NSTEP, 'solver.NSTEP')
if(err_occurred() /= 0) return
call read_value_double_precision(DT, 'solver.DT')
if(err_occurred() /= 0) return
-
call read_value_logical(OCEANS, 'model.OCEANS')
if(err_occurred() /= 0) return
call read_value_logical(TOPOGRAPHY, 'model.TOPOGRAPHY')
@@ -94,26 +82,8 @@
if(err_occurred() /= 0) return
call read_value_logical(ANISOTROPY, 'model.ANISOTROPY')
if(err_occurred() /= 0) return
-
call read_value_logical(ABSORBING_CONDITIONS, 'solver.ABSORBING_CONDITIONS')
if(err_occurred() /= 0) return
-
-! compute the total number of sources in the CMTSOLUTION file
-! there are NLINES_PER_CMTSOLUTION_SOURCE lines per source in that file
- call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
- open(unit=1,file=CMTSOLUTION,iostat=ios,status='old',action='read')
- if(ios /= 0) stop 'error opening CMTSOLUTION file'
- icounter = 0
- do while(ios == 0)
- read(1,"(a)",iostat=ios) dummystring
- if(ios == 0) icounter = icounter + 1
- enddo
- close(1)
- if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) &
- stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
- NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE
- if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
-
call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE')
if(err_occurred() /= 0) return
call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME')
@@ -128,24 +98,54 @@
if(err_occurred() /= 0) return
call read_value_double_precision(HDUR_MOVIE, 'solver.HDUR_MOVIE')
if(err_occurred() /= 0) return
-! Sets HDUR_MOVIE as the minimum period the mesh can resolvel
+ call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES')
+ if(err_occurred() /= 0) return
+ call read_value_string(LOCAL_PATH, 'LOCAL_PATH')
+ if(err_occurred() /= 0) return
+ call read_value_integer(NTSTEP_BETWEEN_OUTPUT_INFO, 'solver.NTSTEP_BETWEEN_OUTPUT_INFO')
+ if(err_occurred() /= 0) return
+ call read_value_integer(NTSTEP_BETWEEN_OUTPUT_SEISMOS, 'solver.NTSTEP_BETWEEN_OUTPUT_SEISMOS')
+ if(err_occurred() /= 0) return
+ call read_value_logical(PRINT_SOURCE_TIME_FUNCTION, 'solver.PRINT_SOURCE_TIME_FUNCTION')
+ if(err_occurred() /= 0) return
-! compute the minimum value of hdur in CMTSOLUTION file
+
+ ! compute the total number of sources in the CMTSOLUTION file
+ ! there are NLINES_PER_CMTSOLUTION_SOURCE lines per source in that file
+ call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
+
+ open(unit=1,file=CMTSOLUTION,iostat=ios,status='old',action='read')
+ if(ios /= 0) stop 'error opening CMTSOLUTION file'
+
+ icounter = 0
+ do while(ios == 0)
+ read(1,"(a)",iostat=ios) dummystring
+ if(ios == 0) icounter = icounter + 1
+ enddo
+ close(1)
+
+ if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) &
+ stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
+
+ NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE
+ if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
+
+ ! compute the minimum value of hdur in CMTSOLUTION file
open(unit=1,file=CMTSOLUTION,status='old',action='read')
minval_hdur = HUGEVAL
do isource = 1,NSOURCES
-! skip other information
+ ! skip other information
do idummy = 1,3
read(1,"(a)") dummystring
enddo
-! read half duration and compute minimum
+ ! read half duration and compute minimum
read(1,"(a)") dummystring
read(dummystring(15:len_trim(dummystring)),*) hdur
minval_hdur = min(minval_hdur,hdur)
-! skip other information
+ ! skip other information
do idummy = 1,9
read(1,"(a)") dummystring
enddo
@@ -154,22 +154,11 @@
close(1)
! one cannot use a Heaviside source for the movies
-! if((MOVIE_SURFACE .or. MOVIE_VOLUME) .and. sqrt(minval_hdur**2 + HDUR_MOVIE**2) < TINYVAL) &
-! stop 'hdur too small for movie creation, movies do not make sense for Heaviside source'
+ if((MOVIE_SURFACE .or. MOVIE_VOLUME) .and. sqrt(minval_hdur**2 + HDUR_MOVIE**2) < TINYVAL) &
+ stop 'hdur too small for movie creation, movies do not make sense for Heaviside source'
- call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES')
- if(err_occurred() /= 0) return
- call read_value_string(LOCAL_PATH, 'LOCAL_PATH')
- if(err_occurred() /= 0) return
- call read_value_integer(NTSTEP_BETWEEN_OUTPUT_INFO, 'solver.NTSTEP_BETWEEN_OUTPUT_INFO')
- if(err_occurred() /= 0) return
- call read_value_integer(NTSTEP_BETWEEN_OUTPUT_SEISMOS, 'solver.NTSTEP_BETWEEN_OUTPUT_SEISMOS')
- if(err_occurred() /= 0) return
- call read_value_logical(PRINT_SOURCE_TIME_FUNCTION, 'solver.PRINT_SOURCE_TIME_FUNCTION')
- if(err_occurred() /= 0) return
-
! close parameter file
- close(IIN)
-
+ call close_parameter_file()
+
end subroutine read_parameter_file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -58,6 +58,4 @@
endif
-
-
- end subroutine
\ No newline at end of file
+ end subroutine read_topography_bathymetry
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_value_parameters.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_value_parameters.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -31,11 +31,12 @@
integer value_to_read
character(len=*) name
- character(len=256) string_read
+ character(len=100) string_read
+ integer ierr
+ common /param_err_common/ ierr
- call unused_string(name)
-
- call read_next_line(string_read)
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
read(string_read,*) value_to_read
end subroutine read_value_integer
@@ -48,11 +49,12 @@
double precision value_to_read
character(len=*) name
- character(len=256) string_read
+ character(len=100) string_read
+ integer ierr
+ common /param_err_common/ ierr
- call unused_string(name)
-
- call read_next_line(string_read)
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
read(string_read,*) value_to_read
end subroutine read_value_double_precision
@@ -65,11 +67,12 @@
logical value_to_read
character(len=*) name
- character(len=256) string_read
+ character(len=100) string_read
+ integer ierr
+ common /param_err_common/ ierr
- call unused_string(name)
-
- call read_next_line(string_read)
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
read(string_read,*) value_to_read
end subroutine read_value_logical
@@ -82,96 +85,204 @@
character(len=*) value_to_read
character(len=*) name
- character(len=256) string_read
+ character(len=100) string_read
+ integer ierr
+ common /param_err_common/ ierr
- call unused_string(name)
-
- call read_next_line(string_read)
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
value_to_read = string_read
end subroutine read_value_string
!--------------------
- subroutine read_next_line(string_read)
+ subroutine open_parameter_file()
- implicit none
+ integer ierr
+ common /param_err_common/ ierr
+ character(len=50) filename
+ filename = 'DATA/Par_file'
- include "constants.h"
+ call param_open(filename, len(filename), ierr);
+ if (ierr .ne. 0) return
- character(len=256) string_read
-
- integer index_equal_sign,ios
-
- do
- read(unit=IIN,fmt="(a256)",iostat=ios) string_read
- if(ios /= 0) stop 'error while reading parameter 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)
- 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))
-
-! 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
-
-!--------------------
-
- subroutine open_parameter_file
-
- include "constants.h"
-
- open(unit=IIN,file='DATA/Par_file',status='old',action='read')
-
end subroutine open_parameter_file
!--------------------
- subroutine close_parameter_file
+ subroutine close_parameter_file()
- include "constants.h"
+ call param_close();
- close(IIN)
-
end subroutine close_parameter_file
!--------------------
integer function err_occurred()
- err_occurred = 0
+ integer ierr
+ common /param_err_common/ ierr
+ err_occurred = ierr
+
end function err_occurred
!--------------------
-! dummy subroutine to avoid warnings about variable not used in other subroutines
- subroutine unused_string(s)
- character(len=*) s
+!
+! unused routines:
+!
- if (len(s) == 1) continue
- end subroutine unused_string
-
+! subroutine read_value_integer(value_to_read, name)
+!
+! implicit none
+!
+! integer value_to_read
+! character(len=*) name
+! character(len=256) string_read
+!
+! call unused_string(name)
+!
+! call read_next_line(string_read)
+! read(string_read,*) value_to_read
+!
+! end subroutine read_value_integer
+!
+!!--------------------
+!
+! subroutine read_value_double_precision(value_to_read, name)
+!
+! implicit none
+!
+! double precision value_to_read
+! character(len=*) name
+! character(len=256) string_read
+!
+! call unused_string(name)
+!
+! call read_next_line(string_read)
+! read(string_read,*) value_to_read
+!
+! end subroutine read_value_double_precision
+!
+!!--------------------
+!
+! subroutine read_value_logical(value_to_read, name)
+!
+! implicit none
+!
+! logical value_to_read
+! character(len=*) name
+! character(len=256) string_read
+!
+! call unused_string(name)
+!
+! call read_next_line(string_read)
+! read(string_read,*) value_to_read
+!
+! end subroutine read_value_logical
+!
+!!--------------------
+!
+! subroutine read_value_string(value_to_read, name)
+!
+! implicit none
+!
+! character(len=*) value_to_read
+! character(len=*) name
+! character(len=256) string_read
+!
+! call unused_string(name)
+!
+! call read_next_line(string_read)
+! value_to_read = string_read
+!
+! end subroutine read_value_string
+!
+!!--------------------
+!
+! subroutine read_next_line(string_read)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! character(len=256) string_read
+!
+! integer index_equal_sign,ios
+!
+! do
+! read(unit=IIN,fmt="(a256)",iostat=ios) string_read
+! if(ios /= 0) stop 'error while reading parameter 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)
+! 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))
+!
+!! 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
+!
+!!--------------------
+!
+! subroutine open_parameter_file
+!
+! include "constants.h"
+!
+! open(unit=IIN,file='DATA/Par_file',status='old',action='read')
+!
+! end subroutine open_parameter_file
+!
+!!--------------------
+!
+! subroutine close_parameter_file
+!
+! include "constants.h"
+!
+! close(IIN)
+!
+! end subroutine close_parameter_file
+!
+!!--------------------
+!
+! integer function err_occurred()
+!
+! err_occurred = 0
+!
+! end function err_occurred
+!
+!!--------------------
+!
+!! dummy subroutine to avoid warnings about variable not used in other subroutines
+! subroutine unused_string(s)
+!
+! character(len=*) s
+!
+! if (len(s) == 1) continue
+!
+! end subroutine unused_string
+!
Added: seismo/3D/SPECFEM3D_SESAME/trunk/save_adjoint_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/save_adjoint_kernels.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/save_adjoint_kernels.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,145 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine save_adjoint_kernels()
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+
+ implicit none
+ integer:: ispec,i,j,k,iglob
+
+ ! finalizes calculation of rhop, beta, alpha kernels
+ do ispec = 1, NSPEC_AB
+
+ ! elastic simulations
+ if( ispec_is_elastic(ispec) ) then
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! isotropic adjoint kernels (see e.g. Tromp et al. 2005)
+
+ ! density kernel
+ ! multiplies with rho
+ rho_kl(i,j,k,ispec) = - rho_vs(i,j,k,ispec)**2 / mustore(i,j,k,ispec) * rho_kl(i,j,k,ispec)
+
+ ! shear modulus kernel
+ mu_kl(i,j,k,ispec) = - mustore(i,j,k,ispec) * mu_kl(i,j,k,ispec)
+
+ ! bulk modulus kernel
+ kappa_kl(i,j,k,ispec) = - kappastore(i,j,k,ispec) * kappa_kl(i,j,k,ispec)
+
+ ! density prime kernel
+ rhop_kl(i,j,k,ispec) = rho_kl(i,j,k,ispec) + kappa_kl(i,j,k,ispec) + mu_kl(i,j,k,ispec)
+
+ ! vs kernel
+ beta_kl(i,j,k,ispec) = 2._CUSTOM_REAL * (mu_kl(i,j,k,ispec) &
+ - 4._CUSTOM_REAL * mustore(i,j,k,ispec) &
+ / (3._CUSTOM_REAL * kappastore(i,j,k,ispec)) * kappa_kl(i,j,k,ispec))
+
+ ! vp kernel
+ alpha_kl(i,j,k,ispec) = 2._CUSTOM_REAL * (1._CUSTOM_REAL &
+ + 4._CUSTOM_REAL * mustore(i,j,k,ispec) &
+ / (3._CUSTOM_REAL * kappastore(i,j,k,ispec))) * kappa_kl(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+
+ endif ! elastic
+
+ ! acoustic simulations
+ if( ispec_is_acoustic(ispec) ) then
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ! rho prime kernel
+ rhop_ac_kl(i,j,k,ispec) = rho_ac_kl(i,j,k,ispec) + kappa_ac_kl(i,j,k,ispec)
+
+ ! vp kernel
+ alpha_ac_kl(i,j,k,ispec) = TWO * kappa_ac_kl(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+
+ endif ! acoustic
+
+
+ enddo
+
+ ! save kernels to binary files
+ if( ELASTIC_SIMULATION ) then
+ open(unit=27,file=prname(1:len_trim(prname))//'rho_kernel.bin',status='unknown',form='unformatted')
+ write(27) rho_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'mu_kernel.bin',status='unknown',form='unformatted')
+ write(27) mu_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'kappa_kernel.bin',status='unknown',form='unformatted')
+ write(27) kappa_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'rhop_kernel.bin',status='unknown',form='unformatted')
+ write(27) rhop_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'beta_kernel.bin',status='unknown',form='unformatted')
+ write(27) beta_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'alpha_kernel.bin',status='unknown',form='unformatted')
+ write(27) alpha_kl
+ close(27)
+
+ if (SAVE_MOHO_MESH) then
+ open(unit=27,file=prname(1:len_trim(prname))//'moho_kernel.bin',status='unknown',form='unformatted')
+ write(27) moho_kl
+ close(27)
+ endif
+
+ endif
+
+
+ ! save kernels to binary files
+ if( ACOUSTIC_SIMULATION ) then
+ open(unit=27,file=prname(1:len_trim(prname))//'rho_acoustic_kernel.bin',status='unknown',form='unformatted')
+ write(27) rho_ac_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'kappa_acoustic_kernel.bin',status='unknown',form='unformatted')
+ write(27) kappa_ac_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'rho_prime_acoustic_kernel.bin',status='unknown',form='unformatted')
+ write(27) rhop_ac_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'alpha_acoustic_kernel.bin',status='unknown',form='unformatted')
+ write(27) alpha_ac_kl
+ close(27)
+
+ endif
+
+ end subroutine save_adjoint_kernels
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -146,6 +146,12 @@
write(IOUT) nspec
write(IOUT) nglob
+ write(IOUT) ibool
+
+ write(IOUT) xstore_dummy
+ write(IOUT) ystore_dummy
+ write(IOUT) zstore_dummy
+
write(IOUT) xixstore
write(IOUT) xiystore
write(IOUT) xizstore
@@ -157,12 +163,6 @@
write(IOUT) gammazstore
write(IOUT) jacobianstore
- write(IOUT) ibool
-
- write(IOUT) xstore_dummy
- write(IOUT) ystore_dummy
- write(IOUT) zstore_dummy
-
write(IOUT) kappastore
write(IOUT) mustore
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -272,10 +272,38 @@
recvbuf = sendbuf
end subroutine max_all_all_cr
+
+!
+!----
+!
+ subroutine max_all_all_dp(sendbuf, recvbuf)
+
+ implicit none
+
+ double precision :: sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine max_all_all_dp
+
+
!
!----
!
+!
+! subroutine min_all_all_dp(sendbuf, recvbuf)
+!
+! implicit none
+!
+! double precision :: sendbuf, recvbuf
+!
+! recvbuf = sendbuf
+!
+! end subroutine min_all_all_dp
+!
+!----
+!
subroutine min_all_cr(sendbuf, recvbuf)
@@ -350,6 +378,21 @@
!----
!
+ subroutine sum_all_cr(sendbuf, recvbuf)
+
+ implicit none
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine sum_all_cr
+
+!
+!----
+!
+
subroutine sum_all_i(sendbuf, recvbuf)
implicit none
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -62,8 +62,5 @@
! create name of database
call create_name_database(prname,myrank,LOCAL_PATH)
- if (ATTENUATION .and. ((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3)) &
- call create_name_database(prname_Q,myrank,LOCAL_PATH_Q)
-
end subroutine
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -260,10 +260,14 @@
! user output
if (myrank == 0) then
- if( PLOT_CROSS_SECTIONS ) write(IMAIN,*) 'movie: cross-sections'
- write(IMAIN,*) 'movie: nfaces_surface_ext_mesh = ',nfaces_surface_ext_mesh
- write(IMAIN,*) 'movie: nfaces_perproc_surface_ext_mesh = ',nfaces_perproc_surface_ext_mesh
- write(IMAIN,*) 'movie: nfaces_surface_glob_ext_mesh = ',nfaces_surface_glob_ext_mesh
+ if( PLOT_CROSS_SECTIONS ) then
+ write(IMAIN,*) 'movie cross-sections:'
+ else
+ write(IMAIN,*) 'movie surface:'
+ endif
+ write(IMAIN,*) ' nfaces_surface_ext_mesh:',nfaces_surface_ext_mesh
+ write(IMAIN,*) ' nfaces_perproc_surface_ext_mesh:',nfaces_perproc_surface_ext_mesh
+ write(IMAIN,*) ' nfaces_surface_glob_ext_mesh:',nfaces_surface_glob_ext_mesh
! updates number of surface elements in an include file for the movies
if( nfaces_surface_glob_ext_mesh > 0 ) then
@@ -283,7 +287,7 @@
endif
- end subroutine
+ end subroutine setup_movie_meshes
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -30,17 +30,6 @@
use specfem_par
implicit none
-! write source and receiver VTK files for Paraview
-! if (myrank == 0) then
-! open(IOVTK,file=trim(OUTPUT_FILES)//'/sr.vtk',status='unknown')
-! write(IOVTK,'(a)') '# vtk DataFile Version 2.0'
-! write(IOVTK,'(a)') 'Source and Receiver VTK file'
-! write(IOVTK,'(a)') 'ASCII'
-! write(IOVTK,'(a)') 'DATASET POLYDATA'
-! ! LQY -- cannot figure out NSOURCES+nrec at this point
-! write(IOVTK, '(a,i6,a)') 'POINTS ', 2, ' float'
-! endif
-
! locates sources and determines simulation start time t0
call setup_sources()
@@ -77,9 +66,12 @@
use specfem_par
use specfem_par_acoustic
use specfem_par_elastic
+ use specfem_par_movie
implicit none
+ double precision :: t0_ac
integer :: yr,jda,ho,mi
+ integer :: isource,ispec
! allocate arrays for source
allocate(islice_selected_source(NSOURCES))
@@ -106,11 +98,11 @@
! xi_source, eta_source & gamma_source
call locate_source(ibool,NSOURCES,myrank,NSPEC_AB,NGLOB_AB, &
xstore,ystore,zstore,xigll,yigll,zigll,NPROC, &
- sec,t_cmt,yr,jda,ho,mi,utm_x_source,utm_y_source, &
- NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ t_cmt,yr,jda,ho,mi,utm_x_source,utm_y_source, &
+ DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
islice_selected_source,ispec_selected_source, &
xi_source,eta_source,gamma_source, &
- TOPOGRAPHY,UTM_PROJECTION_ZONE, &
+ TOPOGRAPHY,UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
PRINT_SOURCE_TIME_FUNCTION, &
nu_source,iglob_is_surface_external_mesh,ispec_is_surface_external_mesh,&
ispec_is_acoustic,ispec_is_elastic)
@@ -119,21 +111,38 @@
! filter source time function by Gaussian with hdur = HDUR_MOVIE when outputing movies or shakemaps
if (MOVIE_SURFACE .or. MOVIE_VOLUME .or. CREATE_SHAKEMAP) then
- hdur = sqrt(hdur**2 + HDUR_MOVIE**2)
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'Each source is being convolved with HDUR_MOVIE = ',HDUR_MOVIE
- write(IMAIN,*)
- endif
+ hdur = sqrt(hdur**2 + HDUR_MOVIE**2)
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Each source is being convolved with HDUR_MOVIE = ',HDUR_MOVIE
+ write(IMAIN,*)
+ endif
endif
-
-! convert the half duration for triangle STF to the one for gaussian STF
+
+ ! convert the half duration for triangle STF to the one for gaussian STF
hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
-! define t0 as the earliest start time
- t0 = - 1.5d0 * minval(t_cmt-hdur)
+ ! define t0 as the earliest start time
+ t0 = - 1.5d0 * minval(t_cmt-hdur)
-! checks if source is in an acoustic element and exactly on the free surface because pressure is zero there
+ ! uses an earlier start time if source is acoustic with a gaussian source time function
+ t0_ac = 0.0d0
+ do isource = 1,NSOURCES
+ if( myrank == islice_selected_source(isource) ) then
+ ispec = ispec_selected_source(isource)
+ if( ispec_is_acoustic(ispec) ) then
+ t0_ac = - 3.0d0 * ( t_cmt(isource) - hdur(isource) )
+ if( t0_ac > t0 ) t0 = t0_ac
+ endif
+ endif
+ enddo
+
+ ! passes maximum value to all processes
+ ! note: t0 is defined positive and will be subtracted from simulation time (it-1)*DT
+ t0_ac = t0
+ call max_all_all_dp(t0_ac,t0)
+
+ ! checks if source is in an acoustic element and exactly on the free surface because pressure is zero there
call setup_sources_check_acoustic()
end subroutine setup_sources
@@ -249,124 +258,31 @@
!-------------------------------------------------------------------------------------------------
!
-
-subroutine setup_sources_precompute_arrays()
-
- use specfem_par
- use specfem_par_elastic
- use specfem_par_acoustic
- implicit none
-
- integer :: isource,ispec
- real(kind=CUSTOM_REAL) :: factor_source
-
-! forward simulations
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- allocate(sourcearray(NDIM,NGLLX,NGLLY,NGLLZ))
- allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ))
-
- ! compute source arrays
- do isource = 1,NSOURCES
-
- ! check that the source slice number is okay
- if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROC-1) &
- call exit_MPI(myrank,'something is wrong with the source slice number')
-
- ! compute source arrays in source slice
- if(myrank == islice_selected_source(isource)) then
-
- ispec = ispec_selected_source(isource)
-
- ! elastic moment tensor source
- if( ispec_is_elastic(ispec) ) then
- call compute_arrays_source(ispec, &
- xi_source(isource),eta_source(isource),gamma_source(isource),sourcearray, &
- Mxx(isource),Myy(isource),Mzz(isource),Mxy(isource),Mxz(isource),Myz(isource), &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- xigll,yigll,zigll,NSPEC_AB)
- endif
-
- ! acoustic case
- if( ispec_is_acoustic(ispec) ) then
- ! scalar moment of moment tensor values read in from CMTSOLUTION
- ! note: M0 by Dahlen and Tromp, eq. 5.91
- factor_source = 1.0/sqrt(2.0) * sqrt( Mxx(isource)**2 + Myy(isource)**2 + Mzz(isource)**2 &
- + 2*( Myz(isource)**2 + Mxz(isource)**2 + Mxy(isource)**2 ) )
-
- ! scales source such that it would be equivalent to explosion source moment tensor,
- ! where Mxx=Myy=Mzz, others Mxy,.. = zero, in equivalent elastic media
- ! (and getting rid of 1/sqrt(2) factor from scalar moment tensor definition above)
- factor_source = factor_source * sqrt(2.0) / sqrt(3.0)
-
- ! source array interpolated on all element gll points
- call compute_arrays_source_acoustic(xi_source(isource),eta_source(isource),gamma_source(isource),&
- sourcearray,xigll,yigll,zigll,factor_source)
- endif
-
- ! stores source excitations
- sourcearrays(isource,:,:,:,:) = sourcearray(:,:,:,:)
-
- endif
- enddo
- endif
-
- ! adjoint simulations
- ! if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- ! nadj_rec_local = 0
- ! do irec = 1,nrec
- ! if(myrank == islice_selected_rec(irec))then
- !! check that the source slice number is okay
- ! if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROC-1) &
- ! call exit_MPI(myrank,'something is wrong with the source slice number in adjoint simulation')
- ! nadj_rec_local = nadj_rec_local + 1
- ! endif
- ! enddo
- ! allocate(adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
- ! if (nadj_rec_local > 0) allocate(adj_sourcearrays(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
- ! irec_local = 0
- ! do irec = 1, nrec
- !! compute only adjoint source arrays in the local slice
- ! if(myrank == islice_selected_rec(irec)) then
- ! irec_local = irec_local + 1
- ! adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
- ! call compute_arrays_adjoint_source(myrank, adj_source_file, &
- ! xi_receiver(irec), eta_receiver(irec), gamma_receiver(irec), &
- ! adj_sourcearray, xigll,yigll,zigll,NSTEP)
- !
- ! adj_sourcearrays(irec_local,:,:,:,:,:) = adj_sourcearray(:,:,:,:,:)
- !
- ! endif
- ! enddo
- ! endif
-
-end subroutine setup_sources_precompute_arrays
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
subroutine setup_receivers()
use specfem_par
use specfem_par_acoustic
implicit none
- integer :: irec,isource,ios
+ integer :: irec,isource !,ios
! reads in station file
if (SIMULATION_TYPE == 1) then
call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS')
+ call get_value_string(filtered_rec_filename, 'solver.STATIONS_FILTERED', 'DATA/STATIONS_FILTERED')
+ call station_filter(myrank,rec_filename,filtered_rec_filename,nrec, &
+ LATITUDE_MIN, LATITUDE_MAX, LONGITUDE_MIN, LONGITUDE_MAX)
-! get total number of stations
- open(unit=IIN,file=rec_filename,iostat=ios,status='old',action='read')
- nrec = 0
- do while(ios == 0)
- read(IIN,"(a)",iostat=ios) dummystring
- if(ios == 0) nrec = nrec + 1
- enddo
- close(IIN)
+ ! get total number of stations
+ !open(unit=IIN,file=rec_filename,iostat=ios,status='old',action='read')
+ !nrec = 0
+ !do while(ios == 0)
+ ! read(IIN,"(a)",iostat=ios) dummystring
+ ! if(ios == 0) nrec = nrec + 1
+ !enddo
+ !close(IIN)
if(nrec < 1) call exit_MPI(myrank,'need at least one receiver')
+ call sync_all()
else
call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS_ADJOINT')
@@ -401,11 +317,11 @@
! locate receivers in the mesh
call locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, &
- xstore,ystore,zstore,xigll,yigll,zigll,rec_filename, &
+ xstore,ystore,zstore,xigll,yigll,zigll,filtered_rec_filename, &
nrec,islice_selected_rec,ispec_selected_rec, &
xi_receiver,eta_receiver,gamma_receiver,station_name,network_name,nu, &
NPROC,utm_x_source(1),utm_y_source(1), &
- TOPOGRAPHY,UTM_PROJECTION_ZONE, &
+ TOPOGRAPHY,UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
iglob_is_surface_external_mesh,ispec_is_surface_external_mesh )
! count number of receivers located in this slice
@@ -516,7 +432,154 @@
!
!-------------------------------------------------------------------------------------------------
!
+
+subroutine setup_sources_precompute_arrays()
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ implicit none
+
+ real(kind=CUSTOM_REAL) :: factor_source
+ real(kind=CUSTOM_REAL) :: junk
+ integer :: isource,ispec
+ integer :: irec,irec_local
+ integer :: icomp,itime,nadj_files_found,nadj_files_found_tot,ier
+ character(len=3),dimension(NDIM) :: comp = (/ "BHN", "BHE", "BHZ" /)
+ character(len=150) :: filename
+
+
+! forward simulations
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ allocate(sourcearray(NDIM,NGLLX,NGLLY,NGLLZ))
+ allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ))
+
+ ! compute source arrays
+ do isource = 1,NSOURCES
+
+ ! check that the source slice number is okay
+ if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROC-1) &
+ call exit_MPI(myrank,'something is wrong with the source slice number')
+
+ ! compute source arrays in source slice
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ ! elastic moment tensor source
+ if( ispec_is_elastic(ispec) ) then
+ call compute_arrays_source(ispec, &
+ xi_source(isource),eta_source(isource),gamma_source(isource),sourcearray, &
+ Mxx(isource),Myy(isource),Mzz(isource),Mxy(isource),Mxz(isource),Myz(isource), &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ xigll,yigll,zigll,NSPEC_AB)
+ endif
+
+ ! acoustic case
+ if( ispec_is_acoustic(ispec) ) then
+ ! scalar moment of moment tensor values read in from CMTSOLUTION
+ ! note: M0 by Dahlen and Tromp, eq. 5.91
+ factor_source = 1.0/sqrt(2.0) * sqrt( Mxx(isource)**2 + Myy(isource)**2 + Mzz(isource)**2 &
+ + 2*( Myz(isource)**2 + Mxz(isource)**2 + Mxy(isource)**2 ) )
+
+ ! scales source such that it would be equivalent to explosion source moment tensor,
+ ! where Mxx=Myy=Mzz, others Mxy,.. = zero, in equivalent elastic media
+ ! (and getting rid of 1/sqrt(2) factor from scalar moment tensor definition above)
+ factor_source = factor_source * sqrt(2.0) / sqrt(3.0)
+
+ ! source array interpolated on all element gll points
+ call compute_arrays_source_acoustic(xi_source(isource),eta_source(isource),gamma_source(isource),&
+ sourcearray,xigll,yigll,zigll,factor_source)
+ endif
+
+ ! stores source excitations
+ sourcearrays(isource,:,:,:,:) = sourcearray(:,:,:,:)
+
+ endif
+ enddo
+ endif
+
+! ADJOINT simulations
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+
+ ! counts local receivers which become adjoint sources
+ nadj_rec_local = 0
+ ! temporary counter to check if any files are found at all
+ nadj_files_found = 0
+ do irec = 1,nrec
+ if( myrank == islice_selected_rec(irec) ) then
+ ! checks that the source slice number is okay
+ if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROC-1) &
+ call exit_MPI(myrank,'something is wrong with the source slice number in adjoint simulation')
+
+ ! updates counter
+ nadj_rec_local = nadj_rec_local + 1
+
+ ! checks **sta**.**net**.**BH**.adj files for correct number of time steps
+ adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+ do icomp = 1,NDIM
+ filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit=IIN,file=trim(filename),status='old',action='read',iostat=ier)
+ if( ier == 0 ) then
+ ! checks length of file
+ itime = 0
+ do while(ier == 0)
+ read(IIN,*,iostat=ier) junk,junk
+ if( ier == 0 ) itime = itime + 1
+ enddo
+ if( itime /= NSTEP) &
+ call exit_MPI(myrank,&
+ 'file '//trim(filename)//' has wrong length, please check with your simulation duration')
+ nadj_files_found = nadj_files_found + 1
+ endif
+ close(IIN)
+ enddo
+ endif
+ enddo
+ ! checks if any adjoint source files found at all
+ call sum_all_i(nadj_files_found,nadj_files_found_tot)
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' ',nadj_files_found_tot,' adjoint component traces found in all slices'
+ if(nadj_files_found_tot == 0) &
+ call exit_MPI(myrank,'no adjoint traces found, please check adjoint sources in directory SEM/')
+ endif
+
+ ! reads in adjoint source traces
+ allocate(adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
+ allocate(adj_sourcearrays(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
+ adj_sourcearrays = 0._CUSTOM_REAL
+ adj_sourcearray = 0._CUSTOM_REAL
+
+ ! pre-computes adjoint source arrays
+ irec_local = 0
+ do irec = 1, nrec
+ ! computes only adjoint source arrays in the local slice
+ if( myrank == islice_selected_rec(irec) ) then
+ irec_local = irec_local + 1
+
+ ! reads in **sta**.**net**.**BH**.adj files
+ adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+
+ call compute_arrays_adjoint_source(myrank, adj_source_file, &
+ xi_receiver(irec), eta_receiver(irec), gamma_receiver(irec), &
+ adj_sourcearray, xigll,yigll,zigll,NSTEP)
+
+ adj_sourcearrays(irec_local,:,:,:,:,:) = adj_sourcearray(:,:,:,:,:)
+
+ endif
+ enddo
+ ! frees temporary array
+ deallocate(adj_sourcearray)
+ endif
+
+end subroutine setup_sources_precompute_arrays
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
subroutine setup_receivers_precompute_intp()
use specfem_par
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -41,33 +41,10 @@
implicit none
-! memory variables and standard linear solids for attenuation
- double precision, dimension(N_SLS) :: tau_mu_dble,tau_sigma_dble,beta_dble
- double precision factor_scale_dble,one_minus_sum_beta_dble
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: tau_mu,tau_sigma,beta
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: factor_scale,one_minus_sum_beta
-
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: tauinv,factor_common, alphaval,betaval,gammaval
-! integer iattenuation
-! double precision scale_factor
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: &
- R_xx,R_yy,R_xy,R_xz,R_yz
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
-
+! attenuation
integer :: NSPEC_ATTENUATION_AB
integer, dimension(:,:,:,:),allocatable :: iflag_attenuation_store
-! ADJOINT
- !real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: b_alphaval, b_betaval, b_gammaval
- !! DK DK array not created yet for CUBIT
- ! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS) :: &
- ! b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz
- ! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL) :: b_epsilondev_xx, &
- ! b_epsilondev_yy,b_epsilondev_xy,b_epsilondev_xz,b_epsilondev_yz
- ! ADJOINT
-
! use integer array to store topography values
integer :: NX_TOPO,NY_TOPO
double precision :: ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
@@ -79,7 +56,7 @@
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: abs_boundary_jacobian2Dw
integer, dimension(:,:,:), allocatable :: abs_boundary_ijk
integer, dimension(:), allocatable :: abs_boundary_ispec
- integer :: num_abs_boundary_faces
+ integer :: num_abs_boundary_faces
! free surface arrays
real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: free_surface_normal
@@ -88,24 +65,6 @@
integer, dimension(:), allocatable :: free_surface_ispec
integer :: num_free_surface_faces
- !real(kind=CUSTOM_REAL) :: nx,ny,nz
-
-!! DK DK array not created yet for CUBIT
-! integer, dimension(NSPEC2D_TOP_VAL) :: ibelm_top
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_VAL) :: normal_top
-
-!! DK DK array not created yet for CUBIT
-! Moho mesh
-! integer,dimension(NSPEC2D_MOHO_BOUN) :: ibelm_moho_top, ibelm_moho_bot
-! real(CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO_BOUN) :: normal_moho
-! integer :: nspec2D_moho
-
-!! DK DK array not created yet for CUBIT
-! buffers for send and receive between faces of the slices and the chunks
-! real(kind=CUSTOM_REAL), dimension(NDIM,NPOIN2DMAX_XY_VAL) :: buffer_send_faces_vector,buffer_received_faces_vector
-
-! -----------------
-
! mesh parameters
integer, dimension(:,:,:,:), allocatable :: ibool
real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore,ystore,zstore
@@ -120,86 +79,43 @@
! additional mass matrix for ocean load
! ocean load mass matrix is always allocated statically even if no oceans
real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
- !logical, dimension(:), allocatable :: updated_dof_ocean_load
- !real(kind=CUSTOM_REAL) additional_term,force_normal_comp
! time scheme
real(kind=CUSTOM_REAL) deltat,deltatover2,deltatsqover2
-! ADJOINT
- !real(kind=CUSTOM_REAL) b_additional_term,b_force_normal_comp
- !! DK DK array not created yet for CUBIT
- ! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT) :: rho_kl, mu_kl, kappa_kl, &
- ! rhop_kl, beta_kl, alpha_kl
- ! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: absorb_xmin, absorb_xmax, &
- ! absorb_ymin, absorb_ymax, absorb_zmin ! for absorbing b.c.
- ! integer reclen_xmin, reclen_xmax, reclen_ymin, reclen_ymax, reclen_zmin
- !real(kind=CUSTOM_REAL) b_deltat, b_deltatover2, b_deltatsqover2
- ! ADJOINT
-
-! integer l
-
-! Moho kernel
-! integer ispec2D_moho_top, ispec2D_moho_bot, k_top, k_bot, ispec_top, ispec_bot, iglob_top, iglob_bot
-!! DK DK array not created yet for CUBIT
-! real(kind=CUSTOM_REAL), dimension(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO_BOUN) :: dsdx_top, dsdx_bot, b_dsdx_top, b_dsdx_bot
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO_BOUN) :: moho_kl
-! real(kind=CUSTOM_REAL) :: kernel_moho_top, kernel_moho_bot
-
-! --------
-
! time loop step
integer :: it
! parameters for the source
- !integer :: isource
integer, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
- !integer :: yr,jda,ho,mi
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: sourcearray
real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
double precision, dimension(:,:,:), allocatable :: nu_source
-!ADJOINT
-! character(len=256) adj_source_file
-! real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearray
-! real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: adj_sourcearrays
-!ADJOINT
- double precision :: sec,stf
double precision, dimension(:), allocatable :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
double precision, dimension(:), allocatable :: xi_source,eta_source,gamma_source
double precision, dimension(:), allocatable :: t_cmt,hdur,hdur_gaussian
double precision, dimension(:), allocatable :: utm_x_source,utm_y_source
double precision, external :: comp_source_time_function
double precision :: t0
-
+ real(kind=CUSTOM_REAL) :: stf_used_total
+ integer :: NSOURCES
+
! receiver information
character(len=256) :: rec_filename,filtered_rec_filename,dummystring
- integer :: nrec,nrec_local,nrec_tot_found !,irec_local,ios
+ integer :: nrec,nrec_local,nrec_tot_found
integer :: nrec_simulation
integer, allocatable, dimension(:) :: islice_selected_rec,ispec_selected_rec,number_receiver_global
double precision, allocatable, dimension(:) :: xi_receiver,eta_receiver,gamma_receiver
double precision, dimension(:,:), allocatable :: hpxir_store,hpetar_store,hpgammar_store
-! double precision :: hlagrange
-! ADJOINT
- !integer :: nadj_rec_local
-! source frechet derivatives
- real(kind=CUSTOM_REAL) :: displ_s(NDIM,NGLLX,NGLLY,NGLLZ), eps_s(NDIM,NDIM), eps_m_s(NDIM), stf_deltat
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: Mxx_der,Myy_der,Mzz_der,Mxy_der,Mxz_der,Myz_der
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: sloc_der
-! ADJOINT
-
! timing information for the stations
double precision, allocatable, dimension(:,:,:) :: nu
character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
! seismograms
- !double precision dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms_d,seismograms_v,seismograms_a
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: seismograms_eps
-! integer i,j,k,ispec,irec,iglob
-
! Gauss-Lobatto-Legendre points of integration and weights
double precision, dimension(NGLLX) :: xigll,wxgll
double precision, dimension(NGLLY) :: yigll,wygll
@@ -223,30 +139,28 @@
! timer MPI
double precision, external :: wtime
double precision :: time_start
- !integer :: ihours,iminutes,iseconds,int_tCPU, &
- ! ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
- ! ihours_total,iminutes_total,iseconds_total,int_t_total
! parameters read from parameter file
- integer :: NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
- integer :: NSOURCES
+ integer :: NPROC_XI,NPROC_ETA
+ integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE
+ integer :: SIMULATION_TYPE
double precision :: DT
- double precision :: LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX,HDUR_MOVIE
+ double precision :: LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX
logical :: TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
- OCEANS,ABSORBING_CONDITIONS,SAVE_FORWARD
- logical :: ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+ OCEANS,ABSORBING_CONDITIONS,ANISOTROPY
+
+ logical :: SAVE_FORWARD,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
- logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
- integer :: NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+ logical :: SUPPRESS_UTM_PROJECTION
+
+ integer :: NTSTEP_BETWEEN_OUTPUT_INFO
character(len=256) OUTPUT_FILES,LOCAL_PATH,prname,prname_Q
! parameters deduced from parameters read from file
integer :: NPROC
-
integer :: NSPEC_AB, NGLOB_AB
! names of the data files for all the processors in MPI
@@ -274,28 +188,54 @@
! MPI partition surfaces
logical, dimension(:), allocatable :: ispec_is_inner
logical, dimension(:), allocatable :: iglob_is_inner
- !integer :: iinterface
! maximum of the norm of the displacement
real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all
integer:: Usolidnorm_index(1)
- ! ADJOINT
- ! real(kind=CUSTOM_REAL) b_Usolidnorm, b_Usolidnorm_all
- ! ADJOINT
-
! maximum speed in velocity model
real(kind=CUSTOM_REAL):: model_speed_max
-
-!daniel
-! integer, dimension(:),allocatable :: spec_inner, spec_outer
-! integer :: nspec_inner,nspec_outer
-
+
!!!! NL NL REGOLITH : regolith layer for asteroid
!!$ double precision, external :: materials_ext_mesh
!!$ logical, dimension(:), allocatable :: ispec_is_regolith
!!$ real(kind=CUSTOM_REAL) :: weight, jacobianl
!!!! NL NL REGOLITH
+
+
+! ADJOINT parameters
+
+ ! time scheme
+ real(kind=CUSTOM_REAL) b_deltat, b_deltatover2, b_deltatsqover2
+
+ ! absorbing stacey wavefield parts
+ integer :: b_num_abs_boundary_faces
+
+ ! Moho mesh
+ real(CUSTOM_REAL), dimension(:,:,:),allocatable :: normal_moho_top
+ real(CUSTOM_REAL), dimension(:,:,:),allocatable :: normal_moho_bot
+ integer,dimension(:,:,:),allocatable :: ijk_moho_top, ijk_moho_bot
+ integer,dimension(:),allocatable :: ibelm_moho_top, ibelm_moho_bot
+ integer :: NSPEC_BOUN,NSPEC2D_MOHO
+ logical, dimension(:),allocatable :: is_moho_top, is_moho_bot
+
+ ! adjoint sources
+ character(len=256) adj_source_file
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: adj_sourcearrays
+ integer :: nadj_rec_local
+ ! adjoint source frechet derivatives
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: Mxx_der,Myy_der,&
+ Mzz_der,Mxy_der,Mxz_der,Myz_der
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: sloc_der
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: seismograms_eps
+
+ ! adjoint elements
+ integer :: NSPEC_ADJOINT, NGLOB_ADJOINT
+
+ ! norm of the backward displacement
+ real(kind=CUSTOM_REAL) b_Usolidnorm, b_Usolidnorm_all
+
end module specfem_par
@@ -306,16 +246,25 @@
! parameter module for elastic solver
- use constants,only: CUSTOM_REAL
+ use constants,only: CUSTOM_REAL,N_SLS,NUM_REGIONS_ATTENUATION
implicit none
+! memory variables and standard linear solids for attenuation
+ double precision, dimension(N_SLS) :: tau_mu_dble,tau_sigma_dble,beta_dble
+ double precision factor_scale_dble,one_minus_sum_beta_dble
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: tau_mu,tau_sigma,beta
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: factor_scale,one_minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: &
+ tauinv,factor_common, alphaval,betaval,gammaval
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: &
+ R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
! displacement, velocity, acceleration
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: displ,veloc,accel
-
- ! ADJOINT
- !! DK DK array not created yet for CUBIT
- ! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_ADJOINT) :: b_displ, b_veloc, b_accel
-
+
! mass matrix
real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
@@ -332,9 +281,46 @@
! material flag
logical, dimension(:), allocatable :: ispec_is_elastic
+ integer, dimension(:,:), allocatable :: phase_ispec_inner_elastic
+ integer :: num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic
logical :: ELASTIC_SIMULATION
+
+! ADJOINT elastic
+
+ ! (backward/reconstructed) wavefields
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_displ, b_veloc, b_accel
+
+ ! backward attenuation arrays
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: &
+ b_alphaval, b_betaval, b_gammaval
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy,b_epsilondev_xz,b_epsilondev_yz
+ integer:: NSPEC_ATT_AND_KERNEL
+
+ ! adjoint kernels
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_kl, mu_kl, kappa_kl, &
+ rhop_kl, beta_kl, alpha_kl
+
+ ! topographic (Moho) kernel
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:),allocatable :: &
+ dsdx_top, dsdx_bot, b_dsdx_top, b_dsdx_bot
+ real(kind=CUSTOM_REAL), dimension(:,:),allocatable :: moho_kl
+ integer :: ispec2D_moho_top,ispec2D_moho_bot
+
+ ! absorbing stacey wavefield parts
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_absorb_field
+ integer :: b_reclen_field
+
+ ! for assembling backward field
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_buffer_send_vector_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_buffer_recv_vector_ext_mesh
+ integer, dimension(:), allocatable :: b_request_send_vector_ext_mesh
+ integer, dimension(:), allocatable :: b_request_recv_vector_ext_mesh
+
end module specfem_par_elastic
!=====================================================================
@@ -348,7 +334,7 @@
! potential
real(kind=CUSTOM_REAL), dimension(:), allocatable :: potential_acoustic, &
- potential_dot_acoustic,potential_dot_dot_acoustic
+ potential_dot_acoustic,potential_dot_dot_acoustic
! density
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore
@@ -365,9 +351,30 @@
! material flag
logical, dimension(:), allocatable :: ispec_is_acoustic
-
+ integer, dimension(:,:), allocatable :: phase_ispec_inner_acoustic
+ integer :: num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic
+
logical :: ACOUSTIC_SIMULATION
+! ADJOINT acoustic
+
+ ! (backward/reconstructed) wavefield potentials
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_potential_acoustic, &
+ b_potential_dot_acoustic,b_potential_dot_dot_acoustic
+ ! kernels
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_ac_kl, kappa_ac_kl, &
+ rhop_ac_kl, alpha_ac_kl
+
+ ! absorbing stacey wavefield parts
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_absorb_potential
+ integer :: b_reclen_potential
+
+ ! for assembling backward field
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_buffer_send_scalar_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_buffer_recv_scalar_ext_mesh
+ integer, dimension(:), allocatable :: b_request_send_scalar_ext_mesh
+ integer, dimension(:), allocatable :: b_request_recv_scalar_ext_mesh
+
end module specfem_par_acoustic
!=====================================================================
@@ -380,7 +387,8 @@
implicit none
! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_solid_poroelastic,rmass_fluid_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_solid_poroelastic,&
+ rmass_fluid_poroelastic
! material flag
logical, dimension(:), allocatable :: ispec_is_poroelastic
@@ -400,18 +408,9 @@
implicit none
-! to save movie frames
- !real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
- ! store_val_x,store_val_y,store_val_z, &
- ! store_val_ux,store_val_uy,store_val_uz, &
- ! store_val_norm_displ,store_val_norm_veloc,store_val_norm_accel
- !real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- ! store_val_x_all,store_val_y_all,store_val_z_all, &
- ! store_val_ux_all,store_val_uy_all,store_val_uz_all
-
! to save full 3D snapshot of velocity (movie volume
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable:: div, curl_x, curl_y, curl_z
- real(kind=CUSTOM_REAL),dimension(:,:,:,:,:),allocatable:: velocity_movie
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable:: div, curl_x, curl_y, curl_z
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable:: velocity_x,velocity_y,velocity_z
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dvxdxl,dvxdyl,&
dvxdzl,dvydxl,dvydyl,dvydzl,dvzdxl,dvzdyl,dvzdzl
@@ -439,8 +438,6 @@
real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
- !integer nmovie_points
-
! for storing surface of external mesh
integer,dimension(:),allocatable :: nfaces_perproc_surface_ext_mesh
integer,dimension(:),allocatable :: faces_surface_offset_ext_mesh
@@ -448,8 +445,16 @@
integer,dimension(:),allocatable :: faces_surface_ext_mesh_ispec
integer :: nfaces_surface_ext_mesh
integer :: nfaces_surface_glob_ext_mesh
-
+ ! face corner indices
integer :: iorderi(NGNOD2D),iorderj(NGNOD2D)
+! movie parameters
+ double precision :: HDUR_MOVIE
+ integer :: NTSTEP_BETWEEN_FRAMES
+ logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ USE_HIGHRES_FOR_MOVIES
+
+ logical :: MOVIE_SIMULATION
+
end module specfem_par_movie
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/write_PNM_GIF_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_PNM_GIF_data.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_PNM_GIF_data.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -498,9 +498,11 @@
j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
- ! gets velocity for iglob
+ ! global point and element indices of gll point in this pixel
iglob = iglob_image_color(i,j)
ispec = ispec_image_color(i,j)
+
+ ! gets velocity for point iglob
call get_iglob_veloc(iglob,ispec,veloc_val)
! data type
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/write_c_binary.c
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_c_binary.c 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_c_binary.c 2010-02-23 02:41:02 UTC (rev 16315)
@@ -29,6 +29,7 @@
#include "config.h"
#include <stdio.h>
+#include <stdlib.h>
#include <unistd.h>
#include <sys/types.h>
#include <sys/stat.h>
Added: seismo/3D/SPECFEM3D_SESAME/trunk/write_movie_output.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_movie_output.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_movie_output.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -0,0 +1,1132 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine write_movie_output()
+
+ use specfem_par
+ use specfem_par_movie
+ implicit none
+
+ ! shakemap creation
+ if (EXTERNAL_MESH_CREATE_SHAKEMAP) then
+ call wmo_create_shakemap_em()
+ endif
+
+ ! movie file creation
+ if(EXTERNAL_MESH_MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ call wmo_create_movie_surface_em()
+ endif
+
+ ! saves MOVIE on the SURFACE
+ if(MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ call wmo_movie_surface_output_o()
+ endif
+
+ ! computes SHAKING INTENSITY MAP
+ if(CREATE_SHAKEMAP) then
+ call wmo_create_shakemap_o()
+ endif
+
+ ! saves MOVIE in full 3D MESH
+ if(MOVIE_VOLUME .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ call wmo_movie_volume_output()
+ endif
+
+ ! creates cross-section GIF image
+ if(PNM_GIF_IMAGE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0 ) then
+ call write_PNM_GIF_create_image()
+ endif
+
+ end subroutine write_movie_output
+
+
+
+!================================================================
+
+ subroutine wmo_create_shakemap_em()
+
+! creation of shapemap file
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_movie
+ implicit none
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: &
+ displ_element,veloc_element,accel_element
+ integer :: ipoin,ispec,iglob,ispec2D
+ integer :: i,j,k
+ logical :: is_done
+
+! initializes arrays for point coordinates
+ if (it == 1) then
+ store_val_ux_external_mesh(:) = -HUGEVAL
+ store_val_uy_external_mesh(:) = -HUGEVAL
+ store_val_uz_external_mesh(:) = -HUGEVAL
+ do ispec2D = 1,nfaces_surface_ext_mesh
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! x,y,z coordinates
+ store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = zstore(iglob)
+ enddo
+ else
+ do ipoin = 1, 4
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! x,y,z coordinates
+ store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = zstore(iglob)
+ enddo
+ endif
+ enddo
+ endif
+
+! stores displacement, velocity and acceleration amplitudes
+ do ispec2D = 1,nfaces_surface_ext_mesh
+ ispec = faces_surface_ext_mesh_ispec(ispec2D)
+
+ if( ispec_is_acoustic(ispec) ) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! accel ?
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic, accel_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ endif
+
+
+ ! high-resolution
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! saves norm of displacement,velocity and acceleration vector
+ if( ispec_is_elastic(ispec) ) then
+ ! norm of displacement
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2))
+ ! norm of velocity
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(veloc(1,iglob)**2 + veloc(2,iglob)**2 + veloc(3,iglob)**2))
+ ! norm of acceleration
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(accel(1,iglob)**2 + accel(2,iglob)**2 + accel(3,iglob)**2))
+ endif
+
+ ! acoustic domains
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ ! norm of displacement
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(displ_element(1,i,j,k)**2 &
+ + displ_element(2,i,j,k)**2 &
+ + displ_element(3,i,j,k)**2))
+ ! norm of velocity
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(veloc_element(1,i,j,k)**2 &
+ + veloc_element(2,i,j,k)**2 &
+ + veloc_element(3,i,j,k)**2))
+ ! norm of acceleration
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(accel_element(1,i,j,k)**2 &
+ + accel_element(2,i,j,k)**2 &
+ + accel_element(3,i,j,k)**2))
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+
+ enddo
+ else
+ ! low-resolution: only corner points outputted
+ do ipoin = 1, 4
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! saves norm of displacement,velocity and acceleration vector
+ if( ispec_is_elastic(ispec) ) then
+ ! norm of displacement
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2))
+ ! norm of velocity
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(veloc(1,iglob)**2 + veloc(2,iglob)**2 + veloc(3,iglob)**2))
+ ! norm of acceleration
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(accel(1,iglob)**2 + accel(2,iglob)**2 + accel(3,iglob)**2))
+ endif
+
+ ! acoustic domains
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ ! norm of displacement
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(displ_element(1,i,j,k)**2 &
+ + displ_element(2,i,j,k)**2 &
+ + displ_element(3,i,j,k)**2))
+ ! norm of velocity
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(veloc_element(1,i,j,k)**2 &
+ + veloc_element(2,i,j,k)**2 &
+ + veloc_element(3,i,j,k)**2))
+ ! norm of acceleration
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(accel_element(1,i,j,k)**2 &
+ + accel_element(2,i,j,k)**2 &
+ + accel_element(3,i,j,k)**2))
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+ enddo
+ endif
+ enddo
+
+! finalizes shakemap: master process collects all info
+ if (it == NSTEP) then
+ if (USE_HIGHRES_FOR_MOVIES) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ else
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+
+! creates shakemap file
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all_external_mesh ! x coordinates
+ write(IOUT) store_val_y_all_external_mesh ! y coordinates
+ write(IOUT) store_val_z_all_external_mesh ! z coordinates
+ write(IOUT) store_val_ux_all_external_mesh ! norm of displacement vector
+ write(IOUT) store_val_uy_all_external_mesh ! norm of velocity vector
+ write(IOUT) store_val_uz_all_external_mesh ! norm of acceleration vector
+ close(IOUT)
+ endif
+ endif
+
+ end subroutine wmo_create_shakemap_em
+
+
+!================================================================
+
+ subroutine wmo_create_movie_surface_em()
+
+! creation of moviedata files
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_movie
+ implicit none
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: veloc_element
+ integer :: ispec2D,ispec,ipoin,iglob,i,j,k
+ logical :: is_done
+
+! initializes arrays for point coordinates
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ do ispec2D = 1,nfaces_surface_ext_mesh
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! x,y,z coordinates
+ store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = zstore(iglob)
+ enddo
+ else
+ do ipoin = 1, 4
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! x,y,z coordinates
+ store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = zstore(iglob)
+ enddo
+ endif
+ enddo
+ endif
+
+! saves surface velocities
+ do ispec2D = 1,nfaces_surface_ext_mesh
+ ispec = faces_surface_ext_mesh_ispec(ispec2D)
+
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ endif
+
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! saves velocity vector
+ if( ispec_is_elastic(ispec) ) then
+ ! velocity x,y,z-components
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(3,iglob)
+ endif
+
+ ! acoustic pressure potential
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(1,i,j,k)
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(2,i,j,k)
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(3,i,j,k)
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+ enddo
+ else
+ do ipoin = 1, 4
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! saves velocity vector
+ if( ispec_is_elastic(ispec) ) then
+ ! velocity x,y,z-components
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(3,iglob)
+ endif
+
+ ! acoustic pressure potential
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(1,i,j,k)
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(2,i,j,k)
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(3,i,j,k)
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+ enddo
+ endif
+ enddo
+
+! master process collects all info
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ! collects locations only once
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ endif
+ ! updates/gathers velocity field (high-res)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ else
+ ! collects locations only once
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+ ! updates/gathers velocity field (low-res)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+
+! file output
+ if(myrank == 0) then
+ write(outputname,"('/moviedata',i6.6)") it
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all_external_mesh ! x coordinate
+ write(IOUT) store_val_y_all_external_mesh ! y coordinate
+ write(IOUT) store_val_z_all_external_mesh ! z coordinate
+ write(IOUT) store_val_ux_all_external_mesh ! velocity x-component
+ write(IOUT) store_val_uy_all_external_mesh ! velocity y-component
+ write(IOUT) store_val_uz_all_external_mesh ! velocity z-component
+ close(IOUT)
+ endif
+
+ end subroutine wmo_create_movie_surface_em
+
+
+!=====================================================================
+
+ subroutine wmo_movie_surface_output_o()
+
+! outputs moviedata files
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_movie
+ implicit none
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: val_element
+ integer :: ispec,ipoin,iglob,i,j,k
+ integer :: imin,imax,jmin,jmax,kmin,kmax,iface,igll,iloc
+ logical :: is_done
+
+ ! initializes arrays for point coordinates
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ ipoin = 0
+ do iface=1,num_free_surface_faces
+ ispec = free_surface_ispec(iface)
+ ! high_resolution
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do igll = 1, NGLLSQUARE
+ ipoin = ipoin + 1
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+ ! coordinates
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ enddo
+ else
+ imin = minval( free_surface_ijk(1,:,iface) )
+ imax = maxval( free_surface_ijk(1,:,iface) )
+ jmin = minval( free_surface_ijk(2,:,iface) )
+ jmax = maxval( free_surface_ijk(2,:,iface) )
+ kmin = minval( free_surface_ijk(3,:,iface) )
+ kmax = maxval( free_surface_ijk(3,:,iface) )
+ do iloc = 1, NGNOD2D
+ ipoin = ipoin + 1
+ ! corner points
+ if( imin == imax ) then
+ iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
+ else if( jmin == jmax ) then
+ iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
+ else
+ iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
+ endif
+ ! coordinates
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ enddo
+ endif
+ enddo
+ endif
+
+
+ ! outputs values at free surface
+ ipoin = 0
+ do iface=1,num_free_surface_faces
+ ispec = free_surface_ispec(iface)
+
+ if( ispec_is_acoustic(ispec) ) then
+ if(SAVE_DISPLACEMENT) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, val_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ else
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, val_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ endif
+ endif
+
+
+ ! high_resolution
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do igll = 1, NGLLSQUARE
+ ipoin = ipoin + 1
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+ ! elastic displacement/velocity
+ if( ispec_is_elastic(ispec) ) then
+ if(SAVE_DISPLACEMENT) then
+ store_val_ux_external_mesh(ipoin) = displ(1,iglob)
+ store_val_uy_external_mesh(ipoin) = displ(2,iglob)
+ store_val_uz_external_mesh(ipoin) = displ(3,iglob)
+ else
+ store_val_ux_external_mesh(ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(ipoin) = veloc(3,iglob)
+ endif
+ endif
+
+ ! acoustic pressure potential
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ store_val_ux_external_mesh(ipoin) = val_element(1,i,j,k)
+ store_val_uy_external_mesh(ipoin) = val_element(2,i,j,k)
+ store_val_uz_external_mesh(ipoin) = val_element(3,i,j,k)
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+
+ enddo
+ else
+ imin = minval( free_surface_ijk(1,:,iface) )
+ imax = maxval( free_surface_ijk(1,:,iface) )
+ jmin = minval( free_surface_ijk(2,:,iface) )
+ jmax = maxval( free_surface_ijk(2,:,iface) )
+ kmin = minval( free_surface_ijk(3,:,iface) )
+ kmax = maxval( free_surface_ijk(3,:,iface) )
+ do iloc = 1, NGNOD2D
+ ipoin = ipoin + 1
+ ! corner points
+ if( imin == imax ) then
+ iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
+ else if( jmin == jmax ) then
+ iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
+ else
+ iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
+ endif
+
+ ! elastic displacement/velocity
+ if( ispec_is_elastic(ispec) ) then
+ if(SAVE_DISPLACEMENT) then
+ store_val_ux_external_mesh(ipoin) = displ(1,iglob)
+ store_val_uy_external_mesh(ipoin) = displ(2,iglob)
+ store_val_uz_external_mesh(ipoin) = displ(3,iglob)
+ else
+ store_val_ux_external_mesh(ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(ipoin) = veloc(3,iglob)
+ endif
+ endif
+
+ ! acoustic pressure potential
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ store_val_ux_external_mesh(ipoin) = val_element(1,i,j,k)
+ store_val_uy_external_mesh(ipoin) = val_element(2,i,j,k)
+ store_val_uz_external_mesh(ipoin) = val_element(3,i,j,k)
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+
+ enddo ! iloc
+ endif
+ enddo ! iface
+
+! master process collects all info
+ if (USE_HIGHRES_FOR_MOVIES) then
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ endif
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ else
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+
+! file output: note that values are only stored on free surface
+ if(myrank == 0) then
+ write(outputname,"('/moviedata',i6.6)") it
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all_external_mesh ! x coordinate
+ write(IOUT) store_val_y_all_external_mesh ! y coordinate
+ write(IOUT) store_val_z_all_external_mesh ! z coordinate
+ write(IOUT) store_val_ux_all_external_mesh ! velocity x-component
+ write(IOUT) store_val_uy_all_external_mesh ! velocity y-component
+ write(IOUT) store_val_uz_all_external_mesh ! velocity z-component
+ close(IOUT)
+ endif
+
+ end subroutine wmo_movie_surface_output_o
+
+
+!=====================================================================
+
+ subroutine wmo_create_shakemap_o()
+
+! outputs shakemap file
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_movie
+
+ implicit none
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: &
+ displ_element,veloc_element,accel_element
+ integer :: ipoin,ispec,iglob
+ integer :: imin,imax,jmin,jmax,kmin,kmax,iface,igll,iloc
+ integer :: i,j,k
+ logical :: is_done
+
+ ! outputs values on free surface
+ ipoin = 0
+ do iface=1,num_free_surface_faces
+ ispec = free_surface_ispec(iface)
+
+ if( ispec_is_acoustic(ispec) ) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! accel ?
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic, accel_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ endif
+
+
+ ! save all points for high resolution, or only four corners for low resolution
+ if(USE_HIGHRES_FOR_MOVIES) then
+ do igll = 1, NGLLSQUARE
+ ipoin = ipoin + 1
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ ! todo: are we only interested in the absolute maximum of horizontal (E,N) components?
+ if( ispec_is_elastic( ispec) ) then
+ ! horizontal displacement
+ store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),&
+ abs(displ(1,iglob)),abs(displ(2,iglob)))
+ ! horizontal velocity
+ store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),&
+ abs(veloc(1,iglob)),abs(veloc(2,iglob)))
+ ! horizontal acceleration
+ store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),&
+ abs(accel(1,iglob)),abs(accel(2,iglob)))
+ endif
+
+ ! acoustic domains
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ ! horizontal displacement
+ store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),&
+ abs(displ_element(1,i,j,k)),abs(displ_element(2,i,j,k)))
+ ! horizontal velocity
+ store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),&
+ abs(veloc_element(1,i,j,k)),abs(veloc_element(2,i,j,k)))
+ ! horizontal acceleration
+ store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),&
+ abs(accel_element(1,i,j,k)),abs(accel_element(2,i,j,k)))
+
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+
+ enddo
+ else
+ imin = minval( free_surface_ijk(1,:,iface) )
+ imax = maxval( free_surface_ijk(1,:,iface) )
+ jmin = minval( free_surface_ijk(2,:,iface) )
+ jmax = maxval( free_surface_ijk(2,:,iface) )
+ kmin = minval( free_surface_ijk(3,:,iface) )
+ kmax = maxval( free_surface_ijk(3,:,iface) )
+ do iloc = 1, NGNOD2D
+ ipoin = ipoin + 1
+ ! corner points
+ if( imin == imax ) then
+ iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
+ else if( jmin == jmax ) then
+ iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
+ else
+ iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
+ endif
+ ! coordinates
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ ! todo: are we only interested in the absolute maximum of horizontal (E,N) components?
+ if( ispec_is_elastic( ispec) ) then
+ store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),&
+ abs(displ(1,iglob)),abs(displ(2,iglob)))
+ store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),&
+ abs(veloc(1,iglob)),abs(veloc(2,iglob)))
+ store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),&
+ abs(accel(1,iglob)),abs(accel(2,iglob)))
+ endif
+
+ ! acoustic domains
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ ! horizontal displacement
+ store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),&
+ abs(displ_element(1,i,j,k)),abs(displ_element(2,i,j,k)))
+ ! horizontal velocity
+ store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),&
+ abs(veloc_element(1,i,j,k)),abs(veloc_element(2,i,j,k)))
+ ! horizontal acceleration
+ store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),&
+ abs(accel_element(1,i,j,k)),abs(accel_element(2,i,j,k)))
+
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+
+ enddo
+ endif ! USE_HIGHRES_FOR_MOVIES
+ enddo
+
+ ! saves shakemap only at the end of the simulation
+ if(it == NSTEP) then
+ if (USE_HIGHRES_FOR_MOVIES) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ else
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+
+ ! creates shakemap file: note that values are only stored on free surface
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all_external_mesh ! x coordinates
+ write(IOUT) store_val_y_all_external_mesh ! y coordinates
+ write(IOUT) store_val_z_all_external_mesh ! z coordinates
+ write(IOUT) store_val_ux_all_external_mesh ! norm of displacement vector
+ write(IOUT) store_val_uy_all_external_mesh ! norm of velocity vector
+ write(IOUT) store_val_uz_all_external_mesh ! norm of acceleration vector
+ close(IOUT)
+ endif
+
+ endif ! NTSTEP
+
+ end subroutine wmo_create_shakemap_o
+
+
+!=====================================================================
+
+ subroutine wmo_movie_volume_output()
+
+! outputs movie files for div, curl and velocity
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_movie
+ implicit none
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: veloc_element
+ integer :: ispec,i,j,k,l,iglob
+
+ ! saves velocity here to avoid static offset on displacement for movies
+ velocity_x(:,:,:,:) = 0._CUSTOM_REAL
+ velocity_y(:,:,:,:) = 0._CUSTOM_REAL
+ velocity_z(:,:,:,:) = 0._CUSTOM_REAL
+
+ if( ACOUSTIC_SIMULATION ) then
+ ! uses div as temporary array to store velocity on all gll points
+ do ispec=1,NSPEC_AB
+ if( .not. ispec_is_acoustic(ispec) ) cycle
+
+ ! calculates velocity
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ velocity_x(:,:,:,ispec) = veloc_element(1,:,:,:)
+ velocity_y(:,:,:,ispec) = veloc_element(2,:,:,:)
+ velocity_z(:,:,:,ispec) = veloc_element(3,:,:,:)
+ enddo
+ endif ! acoustic
+
+ ! saves full snapshot data to local disk
+ if( ELASTIC_SIMULATION ) then
+
+ do ispec=1,NSPEC_AB
+ if( .not. ispec_is_elastic(ispec) ) cycle
+
+ ! calculates divergence and curl of velocity field
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + veloc(1,iglob)*hp1
+ tempy1l = tempy1l + veloc(2,iglob)*hp1
+ tempz1l = tempz1l + veloc(3,iglob)*hp1
+ hp2 = hprime_yy(j,l)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + veloc(1,iglob)*hp2
+ tempy2l = tempy2l + veloc(2,iglob)*hp2
+ tempz2l = tempz2l + veloc(3,iglob)*hp2
+ hp3 = hprime_zz(k,l)
+ iglob = ibool(i,j,l,ispec)
+ tempx3l = tempx3l + veloc(1,iglob)*hp3
+ tempy3l = tempy3l + veloc(2,iglob)*hp3
+ tempz3l = tempz3l + veloc(3,iglob)*hp3
+ enddo
+
+ ! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+ dvxdxl(i,j,k) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ dvxdyl(i,j,k) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ dvxdzl(i,j,k) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ dvydxl(i,j,k) = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ dvydyl(i,j,k) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ dvydzl(i,j,k) = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+
+ dvzdxl(i,j,k) = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ dvzdyl(i,j,k) = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ dvzdzl(i,j,k) = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+
+ enddo
+ enddo
+ enddo
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ! divergence \nabla \cdot \bf{v}
+ div(i,j,k,ispec) = dvxdxl(i,j,k) + dvydyl(i,j,k) + dvzdzl(i,j,k)
+ ! curl
+ curl_x(i,j,k,ispec) = dvzdyl(i,j,k) - dvydzl(i,j,k)
+ curl_y(i,j,k,ispec) = dvxdzl(i,j,k) - dvzdxl(i,j,k)
+ curl_z(i,j,k,ispec) = dvydxl(i,j,k) - dvxdyl(i,j,k)
+ ! velocity field
+ iglob = ibool(i,j,k,ispec)
+ velocity_x(i,j,k,ispec) = veloc(1,iglob)
+ velocity_y(i,j,k,ispec) = veloc(2,iglob)
+ velocity_z(i,j,k,ispec) = veloc(3,iglob)
+ enddo
+ enddo
+ enddo
+ enddo !NSPEC_AB
+
+ write(outputname,"('/proc',i6.6,'_div_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) div
+ close(27)
+ write(outputname,"('/proc',i6.6,'_curl_x_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) curl_x
+ close(27)
+ write(outputname,"('/proc',i6.6,'_curl_y_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) curl_y
+ close(27)
+ write(outputname,"('/proc',i6.6,'_curl_z_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) curl_z
+ close(27)
+
+ !write(outputname,"('veloc_proc',i6.6,'_it',i6.6,'.bin')") myrank,it
+ !open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ !write(27) veloc
+ !close(27)
+
+ endif ! elastic
+
+ if( ACOUSTIC_SIMULATION .or. ELASTIC_SIMULATION ) then
+ write(outputname,"('/proc',i6.6,'_velocity_N_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) velocity_x
+ close(27)
+
+ write(outputname,"('/proc',i6.6,'_velocity_E_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) velocity_y
+ close(27)
+
+ write(outputname,"('/proc',i6.6,'_velocity_Z_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) velocity_z
+ close(27)
+
+ !write(outputname,"('/proc',i6.6,'_veloc_it',i6.6,'.bin')") myrank,it
+ !open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ !write(27) velocity_movie
+ !close(27)
+
+ endif
+
+ end subroutine wmo_movie_volume_output
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90 2010-02-23 00:57:53 UTC (rev 16314)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90 2010-02-23 02:41:02 UTC (rev 16315)
@@ -23,20 +23,243 @@
!
!=====================================================================
+
+ subroutine write_seismograms()
+
+! writes the seismograms with time shift
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: displ_element,veloc_element
+ double precision :: dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
+ integer :: irec_local,irec
+ integer :: iglob,ispec,i,j,k
+ ! adjoint locals
+ real(kind=CUSTOM_REAL),dimension(NDIM,NDIM):: eps_s
+ real(kind=CUSTOM_REAL),dimension(NDIM):: eps_m_s
+ real(kind=CUSTOM_REAL):: stf_deltat
+ double precision :: stf
+
+ do irec_local = 1,nrec_local
+
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+ ! forward simulations
+ if (SIMULATION_TYPE == 1) then
+
+ ! receiver's spectral element
+ ispec = ispec_selected_rec(irec)
+
+ ! elastic wave field
+ if( ispec_is_elastic(ispec) ) then
+ ! interpolates displ/veloc/accel at receiver locations
+ call compute_interpolated_dva(displ,veloc,accel,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+ endif !elastic
+
+ ! acoustic wave field
+ if( ispec_is_acoustic(ispec) ) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+
+ ! interpolates displ/veloc/pressure at receiver locations
+ call compute_interpolated_dva_ac(displ_element,veloc_element,&
+ potential_dot_dot_acoustic,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+ endif ! acoustic
+
+ !adjoint simulations
+ else if (SIMULATION_TYPE == 2) then
+
+ ! adjoint source is placed at receiver
+ ispec = ispec_selected_source(irec)
+
+ ! elastic wave field
+ if( ispec_is_elastic(ispec) ) then
+ ! interpolates displ/veloc/accel at receiver locations
+ call compute_interpolated_dva(displ,veloc,accel,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+
+ ! stores elements displacement field
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ displ_element(:,i,j,k) = displ(:,iglob)
+ enddo
+ enddo
+ enddo
+
+ ! computes the integrated derivatives of source parameters (M_jk and X_s)
+ call compute_adj_source_frechet(displ_element,Mxx(irec),Myy(irec),Mzz(irec),&
+ Mxy(irec),Mxz(irec),Myz(irec),eps_s,eps_m_s, &
+ hxir_store(irec_local,:),hetar_store(irec_local,:),hgammar_store(irec_local,:), &
+ hpxir_store(irec_local,:),hpetar_store(irec_local,:),hpgammar_store(irec_local,:), &
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix(:,:,:,ispec),xiy(:,:,:,ispec),xiz(:,:,:,ispec), &
+ etax(:,:,:,ispec),etay(:,:,:,ispec),etaz(:,:,:,ispec), &
+ gammax(:,:,:,ispec),gammay(:,:,:,ispec),gammaz(:,:,:,ispec))
+
+ stf = comp_source_time_function(dble(NSTEP-it)*DT-t0-t_cmt(irec),hdur_gaussian(irec))
+ stf_deltat = stf * deltat
+ Mxx_der(irec_local) = Mxx_der(irec_local) + eps_s(1,1) * stf_deltat
+ Myy_der(irec_local) = Myy_der(irec_local) + eps_s(2,2) * stf_deltat
+ Mzz_der(irec_local) = Mzz_der(irec_local) + eps_s(3,3) * stf_deltat
+ Mxy_der(irec_local) = Mxy_der(irec_local) + 2 * eps_s(1,2) * stf_deltat
+ Mxz_der(irec_local) = Mxz_der(irec_local) + 2 * eps_s(1,3) * stf_deltat
+ Myz_der(irec_local) = Myz_der(irec_local) + 2 * eps_s(2,3) * stf_deltat
+
+ sloc_der(:,irec_local) = sloc_der(:,irec_local) + eps_m_s(:) * stf_deltat
+ endif ! elastic
+
+ ! acoustic wave field
+ if( ispec_is_acoustic(ispec) ) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+
+ ! interpolates displ/veloc/pressure at receiver locations
+ call compute_interpolated_dva_ac(displ_element,veloc_element,&
+ potential_dot_dot_acoustic,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+ endif ! acoustic
+
+ !adjoint simulations
+ else if (SIMULATION_TYPE == 3) then
+
+ ispec = ispec_selected_rec(irec)
+
+ ! elastic wave field
+ if( ispec_is_elastic(ispec) ) then
+ ! backward fields: interpolates displ/veloc/accel at receiver locations
+ call compute_interpolated_dva(b_displ,b_veloc,b_accel,NGLOB_ADJOINT,&
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+ endif ! elastic
+
+ ! acoustic wave field
+ if( ispec_is_acoustic(ispec) ) then
+ ! backward fields: displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_ADJOINT, &
+ b_potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! backward fields: velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_ADJOINT, &
+ b_potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+
+ ! backward fields: interpolates displ/veloc/pressure at receiver locations
+ call compute_interpolated_dva_ac(displ_element,veloc_element,&
+ b_potential_dot_dot_acoustic,NGLOB_ADJOINT, &
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+ endif ! acoustic
+
+ endif ! SIMULATION_TYPE
+
+! store North, East and Vertical components
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ seismograms_d(:,irec_local,it) = sngl((nu(:,1,irec)*dxd + nu(:,2,irec)*dyd + nu(:,3,irec)*dzd))
+ seismograms_v(:,irec_local,it) = sngl((nu(:,1,irec)*vxd + nu(:,2,irec)*vyd + nu(:,3,irec)*vzd))
+ seismograms_a(:,irec_local,it) = sngl((nu(:,1,irec)*axd + nu(:,2,irec)*ayd + nu(:,3,irec)*azd))
+ else
+ seismograms_d(:,irec_local,it) = (nu(:,1,irec)*dxd + nu(:,2,irec)*dyd + nu(:,3,irec)*dzd)
+ seismograms_v(:,irec_local,it) = (nu(:,1,irec)*vxd + nu(:,2,irec)*vyd + nu(:,3,irec)*vzd)
+ seismograms_a(:,irec_local,it) = (nu(:,1,irec)*axd + nu(:,2,irec)*ayd + nu(:,3,irec)*azd)
+ endif
+
+ !adjoint simulations
+ if (SIMULATION_TYPE == 2) seismograms_eps(:,:,irec_local,it) = eps_s(:,:)
+
+ enddo ! nrec_local
+
+! write the current or final seismograms
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_SEISMOS) == 0 .or. it == NSTEP) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ call write_seismograms_to_file(myrank,seismograms_d,number_receiver_global,station_name, &
+ network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1,SIMULATION_TYPE)
+ call write_seismograms_to_file(myrank,seismograms_v,number_receiver_global,station_name, &
+ network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,2,SIMULATION_TYPE)
+ call write_seismograms_to_file(myrank,seismograms_a,number_receiver_global,station_name, &
+ network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,3,SIMULATION_TYPE)
+ else
+ call write_adj_seismograms_to_file(myrank,seismograms_d,number_receiver_global, &
+ nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
+ endif
+ endif
+
+ end subroutine write_seismograms
+
+
+!================================================================
+
+
! write seismograms to text files
- subroutine write_seismograms(myrank,seismograms,number_receiver_global, &
+ subroutine write_seismograms_to_file(myrank,seismograms,number_receiver_global, &
station_name,network_name,nrec,nrec_local, &
- it,DT,NSTEP,hdur,LOCAL_PATH,istore)
+ it,DT,NSTEP,t0,LOCAL_PATH,istore,SIMULATION_TYPE)
implicit none
include "constants.h"
- integer nrec,nrec_local,NSTEP,it,myrank,istore
+ integer :: nrec,nrec_local,NSTEP,it,myrank,istore
+ integer :: SIMULATION_TYPE
integer, dimension(nrec_local) :: number_receiver_global
real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NSTEP) :: seismograms
- double precision hdur,DT
+ double precision t0,DT
character(len=256) LOCAL_PATH
character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
@@ -51,6 +274,7 @@
! parameters for master collects seismograms
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: one_seismogram
+ real(kind=CUSTOM_REAL) :: time_t
integer :: nrec_local_received,NPROCTOT,total_seismos,receiver,sender
integer :: iproc,ier
@@ -70,10 +294,10 @@
do irec_local = 1,nrec_local
-! get global number of that receiver
+ ! get global number of that receiver
irec = number_receiver_global(irec_local)
-! save three components of displacement vector
+ ! save three components of displacement vector
irecord = 1
do iorientation = 1,NDIM
@@ -88,12 +312,12 @@
call exit_MPI(myrank,'incorrect channel value')
endif
-! create the name of the seismogram file for each slice
-! file name includes the name of the station, the network and the component
+ ! 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
+ ! check that length conforms to standard
if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) &
call exit_MPI(myrank,'wrong length of station name')
@@ -103,13 +327,13 @@
write(sisname,"(a,'.',a,'.',a3,'.sem',a1)") station_name(irec)(1:length_station_name),&
network_name(irec)(1:length_network_name),chn,component
-! directory to store seismograms
+ ! directory to store seismograms
if( USE_OUTPUT_FILES_PATH ) then
final_LOCAL_PATH = 'OUTPUT_FILES'//'/'
else
-! suppress white spaces if any
+ ! suppress white spaces if any
clean_LOCAL_PATH = adjustl(LOCAL_PATH)
-! create full final local path
+ ! create full final local path
final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
endif
@@ -121,16 +345,34 @@
! the results with the source time function
open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),status='unknown')
-! make sure we never write more than the maximum number of time steps
-! subtract half duration of the source to make sure travel time is correct
+ ! make sure we never write more than the maximum number of time steps
+ ! subtract half duration of the source to make sure travel time is correct
do isample = 1,min(it,NSTEP)
if(irecord == 1) then
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IOUT,*) sngl(dble(isample-1)*DT - hdur),' ',seismograms(iorientation,irec_local,isample)
- else
- write(IOUT,*) dble(isample-1)*DT - hdur,' ',seismograms(iorientation,irec_local,isample)
+
+ ! forward simulation
+ if( SIMULATION_TYPE == 1 ) then
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time_t = sngl( dble(isample-1)*DT - t0 )
+ else
+ time_t = dble(isample-1)*DT - t0
+ endif
endif
+
+ ! adjoint simulation: backward/reconstructed wavefields
+ if( SIMULATION_TYPE == 3 ) then
+ ! distinguish between single and double precision for reals
+ ! note: compare time_t with time used for source term
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time_t = sngl( dble(NSTEP-isample-1)*DT - t0 )
+ else
+ time_t = dble(NSTEP-isample-1)*DT - t0
+ endif
+ endif
+
+ write(IOUT,*) time_t,' ',seismograms(iorientation,irec_local,isample)
+
else
call exit_MPI(myrank,'incorrect record label')
endif
@@ -183,7 +425,7 @@
total_seismos = total_seismos + 1
-! save three components of displacement vector
+ ! save three components of displacement vector
irecord = 1
do iorientation = 1,NDIM
@@ -198,12 +440,12 @@
call exit_MPI(myrank,'incorrect channel value')
endif
-! create the name of the seismogram file for each slice
-! file name includes the name of the station, the network and the component
+ ! 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
+ ! check that length conforms to standard
if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) &
call exit_MPI(myrank,'wrong length of station name')
@@ -213,13 +455,13 @@
write(sisname,"(a,'.',a,'.',a3,'.sem',a1)") station_name(irec)(1:length_station_name),&
network_name(irec)(1:length_network_name),chn,component
-! directory to store seismograms
+ ! directory to store seismograms
if( USE_OUTPUT_FILES_PATH ) then
final_LOCAL_PATH = 'OUTPUT_FILES'//'/'
else
-! suppress white spaces if any
+ ! suppress white spaces if any
clean_LOCAL_PATH = adjustl(LOCAL_PATH)
-! create full final local path
+ ! create full final local path
final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
endif
@@ -230,16 +472,40 @@
! the results with the source time function
open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),status='unknown')
-! make sure we never write more than the maximum number of time steps
-! subtract half duration of the source to make sure travel time is correct
+ ! make sure we never write more than the maximum number of time steps
+ ! subtract half duration of the source to make sure travel time is correct
do isample = 1,min(it,NSTEP)
if(irecord == 1) then
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IOUT,*) sngl(dble(isample-1)*DT - hdur),' ',one_seismogram(iorientation,isample)
- else
- write(IOUT,*) dble(isample-1)*DT - hdur,' ',one_seismogram(iorientation,isample)
+ ! distinguish between single and double precision for reals
+ !if(CUSTOM_REAL == SIZE_REAL) then
+ ! write(IOUT,*) sngl(dble(isample-1)*DT - t0),' ',one_seismogram(iorientation,isample)
+ !else
+ ! write(IOUT,*) dble(isample-1)*DT - t0,' ',one_seismogram(iorientation,isample)
+ !endif
+
+ ! forward simulation
+ if( SIMULATION_TYPE == 1 ) then
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time_t = sngl( dble(isample-1)*DT - t0 )
+ else
+ time_t = dble(isample-1)*DT - t0
+ endif
endif
+
+ ! adjoint simulation: backward/reconstructed wavefields
+ if( SIMULATION_TYPE == 3 ) then
+ ! distinguish between single and double precision for reals
+ ! note: compare time_t with time used for source term
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time_t = sngl( dble(NSTEP-isample-1)*DT - t0 )
+ else
+ time_t = dble(NSTEP-isample-1)*DT - t0
+ endif
+ endif
+
+ write(IOUT,*) time_t,' ',one_seismogram(iorientation,isample)
+
else
call exit_MPI(myrank,'incorrect record label')
endif
@@ -278,14 +544,14 @@
endif ! WRITE_SEISMOGRAMS_BY_MASTER
- end subroutine write_seismograms
+ end subroutine write_seismograms_to_file
!=====================================================================
! write adjoint seismograms (displacement) to text files
- subroutine write_adj_seismograms(myrank,seismograms,number_receiver_global, &
- nrec_local,it,DT,NSTEP,hdur,LOCAL_PATH,istore)
+ subroutine write_adj_seismograms_to_file(myrank,seismograms,number_receiver_global, &
+ nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,istore)
implicit none
@@ -294,7 +560,7 @@
integer nrec_local,NSTEP,it,myrank,istore
integer, dimension(nrec_local) :: number_receiver_global
real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NSTEP) :: seismograms
- double precision hdur,DT
+ double precision t0,DT
character(len=256) LOCAL_PATH
@@ -318,10 +584,10 @@
do irec_local = 1,nrec_local
-! get global number of that receiver
+ ! get global number of that receiver
irec = number_receiver_global(irec_local)
-! save three components of displacement vector
+ ! save three components of displacement vector
irecord = 1
do iorientation = 1,NDIM
@@ -336,34 +602,34 @@
call exit_MPI(myrank,'incorrect channel value')
endif
-! create the name of the seismogram file for each slice
-! file name includes the name of the station, the network and the component
+ ! create the name of the seismogram file for each slice
+ ! file name includes the name of the station, the network and the component
write(sisname,"(a,i5.5,'.',a,'.',a3,'.sem',a1)") 'S',irec_local,&
'NT',chn,component
-! suppress white spaces if any
- clean_LOCAL_PATH = adjustl(LOCAL_PATH)
+ ! suppress white spaces if any
+ clean_LOCAL_PATH = adjustl(LOCAL_PATH)
-! create full final local path
- final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
+ ! create full final local path
+ final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
-! 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
+ ! 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
open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),status='unknown')
-! make sure we never write more than the maximum number of time steps
-! subtract half duration of the source to make sure travel time is correct
+ ! make sure we never write more than the maximum number of time steps
+ ! subtract half duration of the source to make sure travel time is correct
do isample = 1,min(it,NSTEP)
if(irecord == 1) then
-! distinguish between single and double precision for reals
+ ! distinguish between single and double precision for reals
if(CUSTOM_REAL == SIZE_REAL) then
- write(IOUT,*) sngl(dble(isample-1)*DT - hdur),' ',seismograms(iorientation,irec_local,isample)
+ write(IOUT,*) sngl(dble(isample-1)*DT - t0),' ',seismograms(iorientation,irec_local,isample)
else
- write(IOUT,*) dble(isample-1)*DT - hdur,' ',seismograms(iorientation,irec_local,isample)
+ write(IOUT,*) dble(isample-1)*DT - t0,' ',seismograms(iorientation,irec_local,isample)
endif
else
call exit_MPI(myrank,'incorrect record label')
@@ -372,18 +638,18 @@
close(IOUT)
- enddo
+ enddo
enddo
- end subroutine write_adj_seismograms
+ end subroutine write_adj_seismograms_to_file
!=====================================================================
! write adjoint seismograms (strain) to text files
- subroutine write_adj_seismograms2(myrank,seismograms,number_receiver_global, &
- nrec_local,it,DT,NSTEP,hdur,LOCAL_PATH)
+ subroutine write_adj_seismograms2_to_file(myrank,seismograms,number_receiver_global, &
+ nrec_local,it,DT,NSTEP,t0,LOCAL_PATH)
implicit none
@@ -392,7 +658,7 @@
integer nrec_local,NSTEP,it,myrank
integer, dimension(nrec_local) :: number_receiver_global
real(kind=CUSTOM_REAL), dimension(NDIM,NDIM,nrec_local,NSTEP) :: seismograms
- double precision hdur,DT
+ double precision t0,DT
character(len=256) LOCAL_PATH
@@ -405,71 +671,68 @@
do irec_local = 1,nrec_local
-! get global number of that receiver
+ ! get global number of that receiver
irec = number_receiver_global(irec_local)
-! save three components of displacement vector
+ ! save three components of displacement vector
irecord = 1
do idim = 1, 3
do jdim = idim, 3
- if(idim == 1 .and. jdim == 1) then
- chn = 'SNN'
- else if(idim == 1 .and. jdim == 2) then
- chn = 'SEN'
- else if(idim == 1 .and. jdim == 3) then
- chn = 'SEZ'
- else if(idim == 2 .and. jdim == 2) then
- chn = 'SEE'
- else if(idim == 2 .and. jdim == 3) then
- chn = 'SNZ'
- else if(idim == 3 .and. jdim == 3) then
- chn = 'SZZ'
- else
- call exit_MPI(myrank,'incorrect channel value')
- endif
+ if(idim == 1 .and. jdim == 1) then
+ chn = 'SNN'
+ else if(idim == 1 .and. jdim == 2) then
+ chn = 'SEN'
+ else if(idim == 1 .and. jdim == 3) then
+ chn = 'SEZ'
+ else if(idim == 2 .and. jdim == 2) then
+ chn = 'SEE'
+ else if(idim == 2 .and. jdim == 3) then
+ chn = 'SNZ'
+ else if(idim == 3 .and. jdim == 3) then
+ chn = 'SZZ'
+ else
+ call exit_MPI(myrank,'incorrect channel value')
+ endif
-! create the name of the seismogram file for each slice
-! file name includes the name of the station, the network and the component
-
- write(sisname,"(a,i5.5,'.',a,'.',a3,'.sem',a1)") 'S',irec_local,&
+ ! create the name of the seismogram file for each slice
+ ! file name includes the name of the station, the network and the component
+ write(sisname,"(a,i5.5,'.',a,'.',a3,'.sem',a1)") 'S',irec_local,&
'NT',chn,component
-! suppress white spaces if any
- clean_LOCAL_PATH = adjustl(LOCAL_PATH)
+ ! suppress white spaces if any
+ clean_LOCAL_PATH = adjustl(LOCAL_PATH)
-! create full final local path
- final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
+ ! create full final local path
+ final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
-! 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
- open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),status='unknown')
+ ! 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
+ open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),status='unknown')
-! make sure we never write more than the maximum number of time steps
-! subtract half duration of the source to make sure travel time is correct
- do isample = 1,min(it,NSTEP)
- if(irecord == 1) then
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IOUT,*) sngl(dble(isample-1)*DT - hdur),' ',seismograms(jdim,idim,irec_local,isample)
+ ! make sure we never write more than the maximum number of time steps
+ ! subtract half duration of the source to make sure travel time is correct
+ do isample = 1,min(it,NSTEP)
+ if(irecord == 1) then
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IOUT,*) sngl(dble(isample-1)*DT - t0),' ',seismograms(jdim,idim,irec_local,isample)
+ else
+ write(IOUT,*) dble(isample-1)*DT - t0,' ',seismograms(jdim,idim,irec_local,isample)
+ endif
else
- write(IOUT,*) dble(isample-1)*DT - hdur,' ',seismograms(jdim,idim,irec_local,isample)
+ call exit_MPI(myrank,'incorrect record label')
endif
- else
- call exit_MPI(myrank,'incorrect record label')
- endif
- enddo
+ enddo
- close(IOUT)
+ close(IOUT)
- enddo
+ enddo ! jdim
+ enddo ! idim
+ enddo ! irec_local
- enddo
-
-end do
-
-end subroutine write_adj_seismograms2
+end subroutine write_adj_seismograms2_to_file
More information about the CIG-COMMITS
mailing list