[cig-commits] r17980 - in seismo/2D/SPECFEM2D/trunk: . UTILS setup src
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Fri Feb 25 14:51:10 PST 2011
Author: dkomati1
Date: 2011-02-25 14:50:58 -0800 (Fri, 25 Feb 2011)
New Revision: 17980
Added:
seismo/2D/SPECFEM2D/trunk/UTILS/SEM_save_dir.py
seismo/2D/SPECFEM2D/trunk/setup/config.h.in
seismo/2D/SPECFEM2D/trunk/setup/constants.h.in
seismo/2D/SPECFEM2D/trunk/setup/precision_mpi.h.in
seismo/2D/SPECFEM2D/trunk/setup/scotchf.h
seismo/2D/SPECFEM2D/trunk/src/adj_seismogram.f90
seismo/2D/SPECFEM2D/trunk/src/assemble_MPI.F90
seismo/2D/SPECFEM2D/trunk/src/attenuation_compute_param.c
seismo/2D/SPECFEM2D/trunk/src/attenuation_model.f90
seismo/2D/SPECFEM2D/trunk/src/calendar.f90
seismo/2D/SPECFEM2D/trunk/src/check_quality_external_mesh.f90
seismo/2D/SPECFEM2D/trunk/src/check_stability.F90
seismo/2D/SPECFEM2D/trunk/src/checkgrid.F90
seismo/2D/SPECFEM2D/trunk/src/compute_Bielak_conditions.f90
seismo/2D/SPECFEM2D/trunk/src/compute_arrays_source.f90
seismo/2D/SPECFEM2D/trunk/src/compute_curl_one_element.f90
seismo/2D/SPECFEM2D/trunk/src/compute_energy.f90
seismo/2D/SPECFEM2D/trunk/src/compute_forces_acoustic.f90
seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_fluid.f90
seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_solid.f90
seismo/2D/SPECFEM2D/trunk/src/compute_forces_viscoelastic.f90
seismo/2D/SPECFEM2D/trunk/src/compute_gradient_attenuation.f90
seismo/2D/SPECFEM2D/trunk/src/compute_normal_vector.f90
seismo/2D/SPECFEM2D/trunk/src/compute_pressure.f90
seismo/2D/SPECFEM2D/trunk/src/compute_vector_field.f90
seismo/2D/SPECFEM2D/trunk/src/construct_acoustic_surface.f90
seismo/2D/SPECFEM2D/trunk/src/convert_time.f90
seismo/2D/SPECFEM2D/trunk/src/convolve_source_timefunction.f90
seismo/2D/SPECFEM2D/trunk/src/create_color_image.f90
seismo/2D/SPECFEM2D/trunk/src/createnum_fast.f90
seismo/2D/SPECFEM2D/trunk/src/createnum_slow.f90
seismo/2D/SPECFEM2D/trunk/src/datim.f90
seismo/2D/SPECFEM2D/trunk/src/define_derivation_matrices.f90
seismo/2D/SPECFEM2D/trunk/src/define_external_model.f90
seismo/2D/SPECFEM2D/trunk/src/define_shape_functions.f90
seismo/2D/SPECFEM2D/trunk/src/enforce_acoustic_free_surface.f90
seismo/2D/SPECFEM2D/trunk/src/exit_mpi.F90
seismo/2D/SPECFEM2D/trunk/src/get_MPI.F90
seismo/2D/SPECFEM2D/trunk/src/get_node_number.f90
seismo/2D/SPECFEM2D/trunk/src/get_perm_cuthill_mckee.f90
seismo/2D/SPECFEM2D/trunk/src/get_poroelastic_velocities.f90
seismo/2D/SPECFEM2D/trunk/src/gll_library.f90
seismo/2D/SPECFEM2D/trunk/src/gmat01.f90
seismo/2D/SPECFEM2D/trunk/src/include_for_periodic_conditions.f90
seismo/2D/SPECFEM2D/trunk/src/initialize_simulation.F90
seismo/2D/SPECFEM2D/trunk/src/invert_mass_matrix.f90
seismo/2D/SPECFEM2D/trunk/src/is_in_convex_quadrilateral.f90
seismo/2D/SPECFEM2D/trunk/src/lagrange_poly.f90
seismo/2D/SPECFEM2D/trunk/src/locate_receivers.F90
seismo/2D/SPECFEM2D/trunk/src/locate_source_force.F90
seismo/2D/SPECFEM2D/trunk/src/locate_source_moment_tensor.F90
seismo/2D/SPECFEM2D/trunk/src/meshfem2D.F90
seismo/2D/SPECFEM2D/trunk/src/netlib_specfun_erf.f90
seismo/2D/SPECFEM2D/trunk/src/paco_beyond_critical.f90
seismo/2D/SPECFEM2D/trunk/src/paco_convolve_fft.f90
seismo/2D/SPECFEM2D/trunk/src/part_unstruct.F90
seismo/2D/SPECFEM2D/trunk/src/plotgll.f90
seismo/2D/SPECFEM2D/trunk/src/plotpost.F90
seismo/2D/SPECFEM2D/trunk/src/prepare_absorb.f90
seismo/2D/SPECFEM2D/trunk/src/prepare_assemble_MPI.F90
seismo/2D/SPECFEM2D/trunk/src/prepare_color_image.F90
seismo/2D/SPECFEM2D/trunk/src/prepare_initialfield.F90
seismo/2D/SPECFEM2D/trunk/src/prepare_source_time_function.f90
seismo/2D/SPECFEM2D/trunk/src/read_databases.f90
seismo/2D/SPECFEM2D/trunk/src/read_external_model.f90
seismo/2D/SPECFEM2D/trunk/src/read_interfaces_file.f90
seismo/2D/SPECFEM2D/trunk/src/read_materials.f90
seismo/2D/SPECFEM2D/trunk/src/read_parameter_file.F90
seismo/2D/SPECFEM2D/trunk/src/read_regions.f90
seismo/2D/SPECFEM2D/trunk/src/read_source_file.f90
seismo/2D/SPECFEM2D/trunk/src/read_value_parameters.f90
seismo/2D/SPECFEM2D/trunk/src/recompute_jacobian.f90
seismo/2D/SPECFEM2D/trunk/src/save_databases.f90
seismo/2D/SPECFEM2D/trunk/src/save_gnuplot_file.f90
seismo/2D/SPECFEM2D/trunk/src/save_openDX_jacobian.f90
seismo/2D/SPECFEM2D/trunk/src/save_stations_file.f90
seismo/2D/SPECFEM2D/trunk/src/set_sources.f90
seismo/2D/SPECFEM2D/trunk/src/setup_sources_receivers.f90
seismo/2D/SPECFEM2D/trunk/src/sort_array_coordinates.F90
seismo/2D/SPECFEM2D/trunk/src/specfem2D.F90
seismo/2D/SPECFEM2D/trunk/src/spline_routines.f90
seismo/2D/SPECFEM2D/trunk/src/write_seismograms.F90
Removed:
seismo/2D/SPECFEM2D/trunk/SEM_save_dir.py
seismo/2D/SPECFEM2D/trunk/adj_seismogram.f90
seismo/2D/SPECFEM2D/trunk/assemble_MPI.F90
seismo/2D/SPECFEM2D/trunk/attenuation_compute_param.c
seismo/2D/SPECFEM2D/trunk/attenuation_model.f90
seismo/2D/SPECFEM2D/trunk/calendar.f90
seismo/2D/SPECFEM2D/trunk/check_quality_external_mesh.f90
seismo/2D/SPECFEM2D/trunk/check_stability.F90
seismo/2D/SPECFEM2D/trunk/checkgrid.F90
seismo/2D/SPECFEM2D/trunk/compute_Bielak_conditions.f90
seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90
seismo/2D/SPECFEM2D/trunk/compute_curl_one_element.f90
seismo/2D/SPECFEM2D/trunk/compute_energy.f90
seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90
seismo/2D/SPECFEM2D/trunk/compute_forces_poro_fluid.f90
seismo/2D/SPECFEM2D/trunk/compute_forces_poro_solid.f90
seismo/2D/SPECFEM2D/trunk/compute_forces_viscoelastic.f90
seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90
seismo/2D/SPECFEM2D/trunk/compute_normal_vector.f90
seismo/2D/SPECFEM2D/trunk/compute_pressure.f90
seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90
seismo/2D/SPECFEM2D/trunk/config.h.in
seismo/2D/SPECFEM2D/trunk/constants.h.in
seismo/2D/SPECFEM2D/trunk/construct_acoustic_surface.f90
seismo/2D/SPECFEM2D/trunk/convert_time.f90
seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90
seismo/2D/SPECFEM2D/trunk/create_color_image.f90
seismo/2D/SPECFEM2D/trunk/createnum_fast.f90
seismo/2D/SPECFEM2D/trunk/createnum_slow.f90
seismo/2D/SPECFEM2D/trunk/datim.f90
seismo/2D/SPECFEM2D/trunk/define_derivation_matrices.f90
seismo/2D/SPECFEM2D/trunk/define_external_model.f90
seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90
seismo/2D/SPECFEM2D/trunk/enforce_acoustic_free_surface.f90
seismo/2D/SPECFEM2D/trunk/exit_mpi.F90
seismo/2D/SPECFEM2D/trunk/get_MPI.F90
seismo/2D/SPECFEM2D/trunk/get_node_number.f90
seismo/2D/SPECFEM2D/trunk/get_perm_cuthill_mckee.f90
seismo/2D/SPECFEM2D/trunk/get_poroelastic_velocities.f90
seismo/2D/SPECFEM2D/trunk/gll_library.f90
seismo/2D/SPECFEM2D/trunk/gmat01.f90
seismo/2D/SPECFEM2D/trunk/include_for_periodic_conditions.f90
seismo/2D/SPECFEM2D/trunk/initialize_simulation.F90
seismo/2D/SPECFEM2D/trunk/invert_mass_matrix.f90
seismo/2D/SPECFEM2D/trunk/is_in_convex_quadrilateral.f90
seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90
seismo/2D/SPECFEM2D/trunk/locate_receivers.F90
seismo/2D/SPECFEM2D/trunk/locate_source_force.F90
seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90
seismo/2D/SPECFEM2D/trunk/meshfem2D.F90
seismo/2D/SPECFEM2D/trunk/netlib_specfun_erf.f90
seismo/2D/SPECFEM2D/trunk/paco_beyond_critical.f90
seismo/2D/SPECFEM2D/trunk/paco_convolve_fft.f90
seismo/2D/SPECFEM2D/trunk/part_unstruct.F90
seismo/2D/SPECFEM2D/trunk/plotgll.f90
seismo/2D/SPECFEM2D/trunk/plotpost.F90
seismo/2D/SPECFEM2D/trunk/precision_mpi.h.in
seismo/2D/SPECFEM2D/trunk/prepare_absorb.f90
seismo/2D/SPECFEM2D/trunk/prepare_assemble_MPI.F90
seismo/2D/SPECFEM2D/trunk/prepare_color_image.F90
seismo/2D/SPECFEM2D/trunk/prepare_initialfield.F90
seismo/2D/SPECFEM2D/trunk/prepare_source_time_function.f90
seismo/2D/SPECFEM2D/trunk/read_databases.f90
seismo/2D/SPECFEM2D/trunk/read_external_model.f90
seismo/2D/SPECFEM2D/trunk/read_interfaces_file.f90
seismo/2D/SPECFEM2D/trunk/read_materials.f90
seismo/2D/SPECFEM2D/trunk/read_parameter_file.F90
seismo/2D/SPECFEM2D/trunk/read_regions.f90
seismo/2D/SPECFEM2D/trunk/read_source_file.f90
seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90
seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90
seismo/2D/SPECFEM2D/trunk/save_databases.f90
seismo/2D/SPECFEM2D/trunk/save_gnuplot_file.f90
seismo/2D/SPECFEM2D/trunk/save_openDX_jacobian.f90
seismo/2D/SPECFEM2D/trunk/save_stations_file.f90
seismo/2D/SPECFEM2D/trunk/scotchf.h
seismo/2D/SPECFEM2D/trunk/set_sources.f90
seismo/2D/SPECFEM2D/trunk/setup_sources_receivers.f90
seismo/2D/SPECFEM2D/trunk/sort_array_coordinates.F90
seismo/2D/SPECFEM2D/trunk/specfem2D.F90
seismo/2D/SPECFEM2D/trunk/spline_routines.f90
seismo/2D/SPECFEM2D/trunk/write_seismograms.F90
Log:
moved all the source files to the new "src" directory and all the setup files to the new "setup" directory
Deleted: seismo/2D/SPECFEM2D/trunk/SEM_save_dir.py
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SEM_save_dir.py 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/SEM_save_dir.py 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,67 +0,0 @@
-#!/usr/bin/env python
-# -*- coding: utf-8 -*-
-
-""" Python code to save data obtained after running SPECFEM with the configuration files.
-This file must be made executable (chmod +x) and put in the root directory of the SPECFEM package.
-The new directory where information will be stored is automatically created.
-The OUTPUT_FILES directory should be empty before running the xmeshfem + xspecfem sequence.
-
-syntax : ./SEM_save_dir.py dirname
-
-Created on Sun Nov 7 2010
-
- at author: Paul Cristini, Laboratoire de Mecanique et d'Acoustique, CNRS, Marseille, France
-"""
-
-from os import *
-import sys, shutil, string
-import os.path as op
-
-def SemSave(rep):
- SEM=getcwd()
- nvdir=op.join(SEM,rep)
- if not path.isdir(rep):
- # Copy of the entire OUTPUT_FILES directory to the new directory
- shutil.copytree(op.join(SEM,'OUTPUT_FILES'),nvdir,symlinks=False)
- # Copy of Par_file file
- shutil.copyfile(op.join(SEM,'DATA','Par_file'),op.join(nvdir,'Par_file'))
- # Copy of SOURCE file
- shutil.copyfile(op.join(SEM,'DATA','SOURCE'),op.join(nvdir,'SOURCE'))
- # Par_file reading
- filename=SEM+'/DATA/Par_file'
- f = file(filename,'r')
- lignes= f.readlines()
- f.close()
- # Save stations if generated
- if GetValuePar('generate_STATIONS',lignes)=='.true.':
- shutil.copyfile(op.join(SEM,'DATA','STATIONS'),op.join(nvdir,'STATIONS'))
- # Save configuration files
- if GetValuePar('read_external_mesh',lignes)=='.true.':
- fic=GetValuePar('mesh_file',lignes)
- shutil.copyfile(fic,op.join(nvdir,op.split(fic)[1]))
- fic=GetValuePar('nodes_coords_file',lignes)
- shutil.copyfile(fic,op.join(nvdir,op.split(fic)[1]))
- fic=GetValuePar('materials_file',lignes)
- shutil.copyfile(fic,op.join(nvdir,op.split(fic)[1]))
- fic=GetValuePar('free_surface_file',lignes)
- shutil.copyfile(fic,op.join(nvdir,op.split(fic)[1]))
- fic=GetValuePar('absorbing_surface_file',lignes)
- shutil.copyfile(fic,op.join(nvdir,op.split(fic)[1]))
- else:
- fic=GetValuePar('interfacesfile',lignes)
- shutil.copyfile(op.join(SEM,'DATA',fic),op.join(nvdir,fic))
- else:
- print 'Unable to save, directory /'+rep+' already exists. Change name !'
-
-def GetValuePar(VAR,lignes):
- """ Return the values of a parameter present in the lines of a file"""
- for ligne in lignes:
- lsplit=string.split(ligne)
- if lsplit!=[]:
- if lsplit[0]==VAR:
- val=lsplit[2]
- break
- return val
-
-if __name__=='__main__':
- SemSave(sys.argv[1])
Copied: seismo/2D/SPECFEM2D/trunk/UTILS/SEM_save_dir.py (from rev 17978, seismo/2D/SPECFEM2D/trunk/SEM_save_dir.py)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/UTILS/SEM_save_dir.py (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/UTILS/SEM_save_dir.py 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,67 @@
+#!/usr/bin/env python
+# -*- coding: utf-8 -*-
+
+""" Python code to save data obtained after running SPECFEM with the configuration files.
+This file must be made executable (chmod +x) and put in the root directory of the SPECFEM package.
+The new directory where information will be stored is automatically created.
+The OUTPUT_FILES directory should be empty before running the xmeshfem + xspecfem sequence.
+
+syntax : ./SEM_save_dir.py dirname
+
+Created on Sun Nov 7 2010
+
+ at author: Paul Cristini, Laboratoire de Mecanique et d'Acoustique, CNRS, Marseille, France
+"""
+
+from os import *
+import sys, shutil, string
+import os.path as op
+
+def SemSave(rep):
+ SEM=getcwd()
+ nvdir=op.join(SEM,rep)
+ if not path.isdir(rep):
+ # Copy of the entire OUTPUT_FILES directory to the new directory
+ shutil.copytree(op.join(SEM,'OUTPUT_FILES'),nvdir,symlinks=False)
+ # Copy of Par_file file
+ shutil.copyfile(op.join(SEM,'DATA','Par_file'),op.join(nvdir,'Par_file'))
+ # Copy of SOURCE file
+ shutil.copyfile(op.join(SEM,'DATA','SOURCE'),op.join(nvdir,'SOURCE'))
+ # Par_file reading
+ filename=SEM+'/DATA/Par_file'
+ f = file(filename,'r')
+ lignes= f.readlines()
+ f.close()
+ # Save stations if generated
+ if GetValuePar('generate_STATIONS',lignes)=='.true.':
+ shutil.copyfile(op.join(SEM,'DATA','STATIONS'),op.join(nvdir,'STATIONS'))
+ # Save configuration files
+ if GetValuePar('read_external_mesh',lignes)=='.true.':
+ fic=GetValuePar('mesh_file',lignes)
+ shutil.copyfile(fic,op.join(nvdir,op.split(fic)[1]))
+ fic=GetValuePar('nodes_coords_file',lignes)
+ shutil.copyfile(fic,op.join(nvdir,op.split(fic)[1]))
+ fic=GetValuePar('materials_file',lignes)
+ shutil.copyfile(fic,op.join(nvdir,op.split(fic)[1]))
+ fic=GetValuePar('free_surface_file',lignes)
+ shutil.copyfile(fic,op.join(nvdir,op.split(fic)[1]))
+ fic=GetValuePar('absorbing_surface_file',lignes)
+ shutil.copyfile(fic,op.join(nvdir,op.split(fic)[1]))
+ else:
+ fic=GetValuePar('interfacesfile',lignes)
+ shutil.copyfile(op.join(SEM,'DATA',fic),op.join(nvdir,fic))
+ else:
+ print 'Unable to save, directory /'+rep+' already exists. Change name !'
+
+def GetValuePar(VAR,lignes):
+ """ Return the values of a parameter present in the lines of a file"""
+ for ligne in lignes:
+ lsplit=string.split(ligne)
+ if lsplit!=[]:
+ if lsplit[0]==VAR:
+ val=lsplit[2]
+ break
+ return val
+
+if __name__=='__main__':
+ SemSave(sys.argv[1])
Deleted: seismo/2D/SPECFEM2D/trunk/adj_seismogram.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/adj_seismogram.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/adj_seismogram.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,176 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- program adj_seismogram
-
-! This program cuts a certain portion of the seismograms and convert it
-! into the adjoint source for generating banana-dougnut kernels
-
- implicit none
-!
-!!!! user edit
- integer, parameter :: NSTEP = 3000
- integer, parameter :: nrec = 1
- double precision, parameter :: t0 = 12
- double precision, parameter :: deltat = 6d-2
- double precision, parameter :: EPS = 1.d-40
-!!!!
- integer :: itime,icomp,istart,iend,nlen,irec,NDIM,NDIMr,adj_comp
- double precision :: time,tstart(nrec),tend(nrec)
- character(len=150), dimension(nrec) :: station_name
- double precision, dimension(NSTEP) :: time_window
- double precision :: seism(NSTEP,3),Nnorm,seism_win(NSTEP)
- double precision :: seism_veloc(NSTEP),seism_accel(NSTEP),ft_bar(NSTEP)
- character(len=3) :: compr(2),comp(3)
- character(len=150) :: filename,filename2
-
- NDIM=3
- comp = (/"BHX","BHY","BHZ"/)
-
-!!!! user edit
-! which calculation: P-SV (use (1)) or SH (membrane) (use (2)) waves
- NDIMr=2 !(1)
-! NDIMr=1 !(2)
-! list of stations
- station_name(1) = 'S0001'
- tstart(1) = 100d0 + t0
- tend(1) = 120d0 + t0
-! which calculation: P-SV (use (1)) or SH (membrane) (use (2)) waves
- compr = (/"BHX","BHZ"/) !(1)
-! compr = (/"BHY","dummy"/) !(2)
-! chose the component for the adjoint source (adj_comp = 1: X, 2:Y, 3:Z)
- adj_comp = 1
-!!!!
-
- do irec =1,nrec
-
- do icomp = 1, NDIMr
-
- filename = 'OUTPUT_FILES/'//trim(station_name(irec))//'.AA.'// compr(icomp) // '.semd'
- open(unit = 10, file = trim(filename))
-
- do itime = 1,NSTEP
- read(10,*) time , seism(itime,icomp)
- enddo
-
- enddo
-
- if(NDIMr==2)then
- seism(:,3) = seism(:,2)
- seism(:,2) = 0.d0
- else
- seism(:,2) = seism(:,1)
- seism(:,1) = 0.d0
- seism(:,3) = 0.d0
- endif
-
- close(10)
-
-
- istart = max(floor(tstart(irec)/deltat),1)
- iend = min(floor(tend(irec)/deltat),NSTEP)
- print*,'istart =',istart, 'iend =', iend
- print*,'tstart =',istart*deltat, 'tend =', iend*deltat
- if(istart >= iend) stop 'check istart,iend'
- nlen = iend - istart +1
-
- do icomp = 1, NDIM
-
- print*,comp(icomp)
-
- filename = 'OUTPUT_FILES/'//trim(station_name(irec))//'.AA.'// comp(icomp) // '.adj'
- open(unit = 11, file = trim(filename))
-
- time_window(:) = 0.d0
- seism_win(:) = seism(:,icomp)
- seism_veloc(:) = 0.d0
- seism_accel(:) = 0.d0
-
- do itime =istart,iend
-! time_window(itime) = 1.d0 - cos(pi*(itime-1)/NSTEP+1)**10 ! cosine window
- time_window(itime) = 1.d0 - (2* (dble(itime) - istart)/(iend-istart) -1.d0)**2 ! Welch window
- enddo
-
- do itime = 2,NSTEP-1
- seism_veloc(itime) = (seism_win(itime+1) - seism_win(itime-1))/(2*deltat)
- enddo
- seism_veloc(1) = (seism_win(2) - seism_win(1))/deltat
- seism_veloc(NSTEP) = (seism_win(NSTEP) - seism_win(NSTEP-1))/deltat
-
- do itime = 2,NSTEP-1
- seism_accel(itime) = (seism_veloc(itime+1) - seism_veloc(itime-1))/(2*deltat)
- enddo
- seism_accel(1) = (seism_veloc(2) - seism_veloc(1))/deltat
- seism_accel(NSTEP) = (seism_veloc(NSTEP) - seism_veloc(NSTEP-1))/deltat
-
- Nnorm = deltat * sum(time_window(:) * seism_win(:) * seism_accel(:))
-! Nnorm = deltat * sum(time_window(:) * seism_veloc(:) * seism_veloc(:))
-! cross-correlation traveltime adjoint source
- if(abs(Nnorm) > EPS) then
-! ft_bar(:) = - seism_veloc(:) * time_window(:) / Nnorm
- ft_bar(:) = seism_veloc(:) * time_window(:) / Nnorm
- print*,'Norm =', Nnorm
- else
- print *, 'norm < EPS for file '
- print*,'Norm =', Nnorm
- ft_bar(:) = 0.d0
- endif
-
- do itime =1,NSTEP
- if(icomp == adj_comp) then
- write(11,*) (itime-1)*deltat - t0, ft_bar(itime)
- else
- write(11,*) (itime-1)*deltat - t0, 0.d0
- endif
- enddo
-
- enddo
- close(11)
-
- enddo
- print*,'*************************'
- print*,'The input files (S****.AA.BHX/BHY/BHZ.adj) needed to run the adjoint simulation are in OUTPUT_FILES'
- print*,'*************************'
-
- end program adj_seismogram
Deleted: seismo/2D/SPECFEM2D/trunk/assemble_MPI.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/assemble_MPI.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/assemble_MPI.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,563 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!
-! This file contains subroutines related to assembling (of the mass matrix, potential_dot_dot and
-! accel_elastic, accels_poroelastic, accelw_poroelastic).
-! These subroutines are for the most part not used in the sequential version.
-!
-
-
-#ifdef USE_MPI
-
-!-----------------------------------------------
-! Assembling the mass matrix.
-!-----------------------------------------------
- subroutine assemble_MPI_scalar(array_val1,npoin_val1, &
- array_val2,npoin_val2, &
- array_val3,array_val4,npoin_val3, &
- ninterface, max_interface_size, max_ibool_interfaces_size_ac, &
- max_ibool_interfaces_size_el, &
- max_ibool_interfaces_size_po, &
- ibool_interfaces_acoustic,ibool_interfaces_elastic, &
- ibool_interfaces_poroelastic, &
- nibool_interfaces_acoustic,nibool_interfaces_elastic, &
- nibool_interfaces_poroelastic,my_neighbours)
-
- implicit none
-
- include 'constants.h'
- include 'mpif.h'
-
- integer, intent(in) :: ninterface
- integer, intent(in) :: max_interface_size
- integer, intent(in) :: max_ibool_interfaces_size_ac,max_ibool_interfaces_size_el, &
- max_ibool_interfaces_size_po
- integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: &
- ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic,nibool_interfaces_elastic, &
- nibool_interfaces_poroelastic
- integer, dimension(ninterface), intent(in) :: my_neighbours
- ! array to assemble
- ! acoustic
- integer :: npoin_val1
- real(kind=CUSTOM_REAL), dimension(npoin_val1), intent(inout) :: array_val1
- ! elastic
- integer :: npoin_val2
- real(kind=CUSTOM_REAL), dimension(npoin_val2), intent(inout) :: array_val2
- ! poroelastic
- integer :: npoin_val3
- real(kind=CUSTOM_REAL), dimension(npoin_val3), intent(inout) :: array_val3,array_val4
-
- integer :: ipoin, num_interface
- integer :: ier
- integer :: i
- double precision, dimension(max_ibool_interfaces_size_ac+max_ibool_interfaces_size_el+&
- 2*max_ibool_interfaces_size_po, ninterface) :: &
- buffer_send_faces_scalar, &
- buffer_recv_faces_scalar
- integer, dimension(MPI_STATUS_SIZE) :: msg_status
- integer, dimension(ninterface) :: msg_requests
-
- buffer_send_faces_scalar(:,:) = 0.d0
- buffer_recv_faces_scalar(:,:) = 0.d0
-
- do num_interface = 1, ninterface
-
- ipoin = 0
- do i = 1, nibool_interfaces_acoustic(num_interface)
- ipoin = ipoin + 1
- buffer_send_faces_scalar(ipoin,num_interface) = &
- array_val1(ibool_interfaces_acoustic(i,num_interface))
- end do
-
- do i = 1, nibool_interfaces_elastic(num_interface)
- ipoin = ipoin + 1
- buffer_send_faces_scalar(ipoin,num_interface) = &
- array_val2(ibool_interfaces_elastic(i,num_interface))
- end do
-
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- ipoin = ipoin + 1
- buffer_send_faces_scalar(ipoin,num_interface) = &
- array_val3(ibool_interfaces_poroelastic(i,num_interface))
- end do
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- ipoin = ipoin + 1
- buffer_send_faces_scalar(ipoin,num_interface) = &
- array_val4(ibool_interfaces_poroelastic(i,num_interface))
- end do
-
- ! non-blocking synchronous send request
- call MPI_ISSEND( buffer_send_faces_scalar(1,num_interface), &
- nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface)+&
- nibool_interfaces_poroelastic(num_interface)+nibool_interfaces_poroelastic(num_interface), &
- MPI_DOUBLE_PRECISION, &
- my_neighbours(num_interface), 11, &
- MPI_COMM_WORLD, msg_requests(num_interface), ier)
-
- end do
-
- do num_interface = 1, ninterface
-
- ! starts a blocking receive
- call MPI_recv ( buffer_recv_faces_scalar(1,num_interface), &
- nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface)+&
- nibool_interfaces_poroelastic(num_interface)+nibool_interfaces_poroelastic(num_interface), &
- MPI_DOUBLE_PRECISION, &
- my_neighbours(num_interface), 11, &
- MPI_COMM_WORLD, msg_status(1), ier)
-
- ipoin = 0
- do i = 1, nibool_interfaces_acoustic(num_interface)
- ipoin = ipoin + 1
- array_val1(ibool_interfaces_acoustic(i,num_interface)) = &
- array_val1(ibool_interfaces_acoustic(i,num_interface)) &
- + buffer_recv_faces_scalar(ipoin,num_interface)
- end do
-
- do i = 1, nibool_interfaces_elastic(num_interface)
- ipoin = ipoin + 1
- array_val2(ibool_interfaces_elastic(i,num_interface)) = &
- array_val2(ibool_interfaces_elastic(i,num_interface)) &
- + buffer_recv_faces_scalar(ipoin,num_interface)
- end do
-
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- ipoin = ipoin + 1
- array_val3(ibool_interfaces_poroelastic(i,num_interface)) = &
- array_val3(ibool_interfaces_poroelastic(i,num_interface)) &
- + buffer_recv_faces_scalar(ipoin,num_interface)
- end do
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- ipoin = ipoin + 1
- array_val4(ibool_interfaces_poroelastic(i,num_interface)) = &
- array_val4(ibool_interfaces_poroelastic(i,num_interface)) &
- + buffer_recv_faces_scalar(ipoin,num_interface)
- end do
-
- end do
-
- ! synchronizes MPI processes
- call MPI_BARRIER(mpi_comm_world,ier)
-
- end subroutine assemble_MPI_scalar
-
-
-!-----------------------------------------------
-! Assembling potential_dot_dot for acoustic elements :
-! the buffers are filled, the Isend and Irecv are started here, then
-! contributions are added.
-! The previous version included communication overlap using persistent
-! communication, but the merging of the outer and inner elements rendered
-! overlap no longer possible, while persistent communications were removed
-! because trace tool MPITrace does not yet instrument those.
-! Particular care should be taken concerning possible optimisations of the
-! communication scheme.
-!-----------------------------------------------
- subroutine assemble_MPI_vector_ac(array_val1,npoin, &
- ninterface, ninterface_acoustic, &
- inum_interfaces_acoustic, &
- max_interface_size, max_ibool_interfaces_size_ac,&
- ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
- tab_requests_send_recv_acoustic, &
- buffer_send_faces_vector_ac, &
- buffer_recv_faces_vector_ac, &
- my_neighbours )
-
- implicit none
-
- include 'constants.h'
- include 'mpif.h'
- include 'precision_mpi.h'
-
- integer, intent(in) :: npoin
- integer, intent(in) :: ninterface, ninterface_acoustic
- integer, dimension(ninterface), intent(in) :: inum_interfaces_acoustic
- integer, intent(in) :: max_interface_size
- integer, intent(in) :: max_ibool_interfaces_size_ac
- integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_acoustic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic
- integer, dimension(ninterface_acoustic*2), intent(inout) :: tab_requests_send_recv_acoustic
- real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(inout) :: &
- buffer_send_faces_vector_ac
- real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(inout) :: &
- buffer_recv_faces_vector_ac
- ! array to assemble
- real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1
- integer, dimension(ninterface), intent(in) :: my_neighbours
-
- ! local parameters
- integer :: ipoin, num_interface,iinterface,ier,iglob
- integer, dimension(MPI_STATUS_SIZE) :: status_acoustic
-
- ! initializes buffers
- buffer_send_faces_vector_ac(:,:) = 0._CUSTOM_REAL
- buffer_recv_faces_vector_ac(:,:) = 0._CUSTOM_REAL
- tab_requests_send_recv_acoustic(:) = 0
-
- ! loops over acoustic interfaces only
- do iinterface = 1, ninterface_acoustic
-
- ! gets interface index in the range of all interfaces [1,ninterface]
- num_interface = inum_interfaces_acoustic(iinterface)
-
- ! loops over all interface points
- do ipoin = 1, nibool_interfaces_acoustic(num_interface)
- iglob = ibool_interfaces_acoustic(ipoin,num_interface)
-
- ! copies array values to buffer
- buffer_send_faces_vector_ac(ipoin,iinterface) = array_val1(iglob)
- end do
-
- end do
-
- do iinterface = 1, ninterface_acoustic
-
- ! gets global interface index
- num_interface = inum_interfaces_acoustic(iinterface)
-
- ! non-blocking synchronous send
- call MPI_ISSEND( buffer_send_faces_vector_ac(1,iinterface), &
- nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_acoustic(iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_start')
- end if
-
- ! starts a non-blocking receive
- call MPI_Irecv ( buffer_recv_faces_vector_ac(1,iinterface), &
- nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_acoustic(ninterface_acoustic+iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector')
- end if
-
- end do
-
-
- ! waits for MPI requests to complete (recv)
- ! each wait returns once the specified MPI request completed
- do iinterface = 1, ninterface_acoustic
- call MPI_Wait (tab_requests_send_recv_acoustic(ninterface_acoustic+iinterface), &
- status_acoustic, ier)
- enddo
-
- ! assembles the array values
- do iinterface = 1, ninterface_acoustic
-
- ! gets global interface index
- num_interface = inum_interfaces_acoustic(iinterface)
-
- ! loops over all interface points
- do ipoin = 1, nibool_interfaces_acoustic(num_interface)
- iglob = ibool_interfaces_acoustic(ipoin,num_interface)
- ! adds buffer contribution
- array_val1(iglob) = array_val1(iglob) + buffer_recv_faces_vector_ac(ipoin,iinterface)
- end do
-
- end do
-
-
- ! waits for MPI requests to complete (send)
- ! just to make sure that all sending is done
- do iinterface = 1, ninterface_acoustic
- call MPI_Wait (tab_requests_send_recv_acoustic(iinterface), status_acoustic, ier)
- enddo
-
-
- end subroutine assemble_MPI_vector_ac
-
-
-!-----------------------------------------------
-! Assembling accel_elastic for elastic elements :
-! the buffers are filled, the Isend and Irecv are started here, then
-! contributions are added.
-! The previous version included communication overlap using persistent
-! communication, but the merging of the outer and inner elements rendered
-! overlap no longer possible, while persistent communications were removed
-! because trace tool MPITrace does not yet instrument those.
-! Particular care should be taken concerning possible optimisations of the
-! communication scheme.
-!-----------------------------------------------
- subroutine assemble_MPI_vector_el(array_val2,npoin, &
- ninterface, ninterface_elastic, &
- inum_interfaces_elastic, &
- max_interface_size, max_ibool_interfaces_size_el,&
- ibool_interfaces_elastic, nibool_interfaces_elastic, &
- tab_requests_send_recv_elastic, &
- buffer_send_faces_vector_el, &
- buffer_recv_faces_vector_el, &
- my_neighbours)
-
- implicit none
-
- include 'constants.h'
- include 'mpif.h'
- include 'precision_mpi.h'
-
- integer, intent(in) :: npoin
- integer, intent(in) :: ninterface, ninterface_elastic
- integer, dimension(ninterface), intent(in) :: inum_interfaces_elastic
- integer, intent(in) :: max_interface_size
- integer, intent(in) :: max_ibool_interfaces_size_el
- integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_elastic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_elastic
- integer, dimension(ninterface_elastic*2), intent(inout) :: tab_requests_send_recv_elastic
- real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_el,ninterface_elastic), intent(inout) :: &
- buffer_send_faces_vector_el
- real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_el,ninterface_elastic), intent(inout) :: &
- buffer_recv_faces_vector_el
- ! array to assemble
- real(kind=CUSTOM_REAL), dimension(3,npoin), intent(inout) :: array_val2
- integer, dimension(ninterface), intent(in) :: my_neighbours
-
- integer :: ipoin, num_interface, iinterface, ier, i
- integer, dimension(MPI_STATUS_SIZE) :: status_elastic
-
-
- do iinterface = 1, ninterface_elastic
-
- num_interface = inum_interfaces_elastic(iinterface)
-
- ipoin = 0
- do i = 1, nibool_interfaces_elastic(num_interface)
- buffer_send_faces_vector_el(ipoin+1:ipoin+3,iinterface) = &
- array_val2(:,ibool_interfaces_elastic(i,num_interface))
- ipoin = ipoin + 3
- end do
-
- end do
-
- do iinterface = 1, ninterface_elastic
-
- num_interface = inum_interfaces_elastic(iinterface)
-
- call MPI_ISSEND( buffer_send_faces_vector_el(1,iinterface), &
- 3*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_elastic(iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_el')
- end if
-
- call MPI_Irecv ( buffer_recv_faces_vector_el(1,iinterface), &
- 3*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_elastic(ninterface_elastic+iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_el')
- end if
-
- end do
-
- do iinterface = 1, ninterface_elastic*2
-
- call MPI_Wait (tab_requests_send_recv_elastic(iinterface), status_elastic, ier)
-
- enddo
-
- do iinterface = 1, ninterface_elastic
-
- num_interface = inum_interfaces_elastic(iinterface)
-
- ipoin = 0
- do i = 1, nibool_interfaces_elastic(num_interface)
- array_val2(:,ibool_interfaces_elastic(i,num_interface)) = &
- array_val2(:,ibool_interfaces_elastic(i,num_interface)) &
- + buffer_recv_faces_vector_el(ipoin+1:ipoin+3,iinterface)
- ipoin = ipoin + 3
- end do
-
- end do
-
- end subroutine assemble_MPI_vector_el
-
-
-!-----------------------------------------------
-! Assembling accel_elastic for elastic elements :
-! the buffers are filled, the Isend and Irecv are started here, then
-! contributions are added.
-! The previous version included communication overlap using persistent
-! communication, but the merging of the outer and inner elements rendered
-! overlap no longer possible, while persistent communications were removed
-! because trace tool MPITrace does not yet instrument those.
-! Particular care should be taken concerning possible optimisations of the
-! communication scheme.
-!-----------------------------------------------
- subroutine assemble_MPI_vector_po(array_val3,array_val4,npoin, &
- ninterface, ninterface_poroelastic, &
- inum_interfaces_poroelastic, &
- max_interface_size, max_ibool_interfaces_size_po,&
- ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
- tab_requests_send_recv_poro, &
- buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
- buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
- my_neighbours)
-
- implicit none
-
- include 'constants.h'
- include 'mpif.h'
- include 'precision_mpi.h'
-
- integer, intent(in) :: npoin
- integer, intent(in) :: ninterface, ninterface_poroelastic
- integer, dimension(ninterface), intent(in) :: inum_interfaces_poroelastic
- integer, intent(in) :: max_interface_size
- integer, intent(in) :: max_ibool_interfaces_size_po
- integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_poroelastic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_poroelastic
- integer, dimension(ninterface_poroelastic*4), intent(inout) :: tab_requests_send_recv_poro
- real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(inout) :: &
- buffer_send_faces_vector_pos,buffer_send_faces_vector_pow
- real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(inout) :: &
- buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow
- ! array to assemble
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(inout) :: array_val3,array_val4
- integer, dimension(ninterface), intent(in) :: my_neighbours
-
- integer :: ipoin, num_interface, iinterface, ier, i
- integer, dimension(MPI_STATUS_SIZE) :: status_poroelastic
-
-
- do iinterface = 1, ninterface_poroelastic
-
- num_interface = inum_interfaces_poroelastic(iinterface)
-
- ipoin = 0
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- buffer_send_faces_vector_pos(ipoin+1:ipoin+2,iinterface) = &
- array_val3(:,ibool_interfaces_poroelastic(i,num_interface))
- ipoin = ipoin + 2
- end do
-
- ipoin = 0
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- buffer_send_faces_vector_pow(ipoin+1:ipoin+2,iinterface) = &
- array_val4(:,ibool_interfaces_poroelastic(i,num_interface))
- ipoin = ipoin + 2
- end do
-
- end do
-
- do iinterface = 1, ninterface_poroelastic
-
- num_interface = inum_interfaces_poroelastic(iinterface)
-
- call MPI_ISSEND( buffer_send_faces_vector_pos(1,iinterface), &
- NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_poro(iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pos')
- end if
-
- call MPI_Irecv ( buffer_recv_faces_vector_pos(1,iinterface), &
- NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_poro(ninterface_poroelastic+iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pos')
- end if
-
- call MPI_ISSEND( buffer_send_faces_vector_pow(1,iinterface), &
- NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_poro(ninterface_poroelastic*2+iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pow')
- end if
-
- call MPI_Irecv ( buffer_recv_faces_vector_pow(1,iinterface), &
- NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
- my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
- tab_requests_send_recv_poro(ninterface_poroelastic*3+iinterface), ier)
-
- if ( ier /= MPI_SUCCESS ) then
- call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pow')
- end if
-
- end do
-
- do iinterface = 1, ninterface_poroelastic*4
-
- call MPI_Wait (tab_requests_send_recv_poro(iinterface), status_poroelastic, ier)
-
- enddo
-
- do iinterface = 1, ninterface_poroelastic
-
- num_interface = inum_interfaces_poroelastic(iinterface)
-
- ipoin = 0
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) = &
- array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) + &
- buffer_recv_faces_vector_pos(ipoin+1:ipoin+2,iinterface)
- ipoin = ipoin + 2
- end do
-
- ipoin = 0
- do i = 1, nibool_interfaces_poroelastic(num_interface)
- array_val4(:,ibool_interfaces_poroelastic(i,num_interface)) = &
- array_val4(:,ibool_interfaces_poroelastic(i,num_interface)) + &
- buffer_recv_faces_vector_pow(ipoin+1:ipoin+2,iinterface)
- ipoin = ipoin + 2
- end do
-
- end do
-
- end subroutine assemble_MPI_vector_po
-
-#endif
Deleted: seismo/2D/SPECFEM2D/trunk/attenuation_compute_param.c
===================================================================
--- seismo/2D/SPECFEM2D/trunk/attenuation_compute_param.c 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/attenuation_compute_param.c 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,1176 +0,0 @@
-
-/* See Liu, Anderson & Kanamori (Geophysical Journal of the Royal Astronomical Society, vol. 47, p. 41-58, 1976) for details */
-
-/* cleaned by Dimitri Komatitsch, University of Pau, France, July 2007 */
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <stdio.h>
-#include <math.h>
-#include <sgtty.h>
-#include <signal.h>
-#include <stdlib.h>
-
-/* useful constants */
-
-#define PI 3.14159265358979
-#define PI2 6.28318530717958
-
-/* Underscores should or should not follow this function name, depending on the compiler and its options.
- It is called in "attenuation_model.f90".
-*/
-int attenuation_compute_param_(int *nmech_in, double *Qp_in, double *Qs_in, double *f1_in, double *f2_in,
- double *tau_sigma_nu1, double *tau_sigma_nu2,
- double *tau_epsilon_nu1, double *tau_epsilon_nu2
- )
-
-{
- int xmgr, n, i, j, plot, nu;
- double Q_s, target_Qp, target_Qs;
- double f1, f2, Q, om0, Omega;
- double a, b;
- double kappa, mu, kappa0, mu0, kappaR, muR;
- double *tau_s, *tau_e;
- double *dvector();
- void constant_Q2_sub(),plot_modulus();
- void free_dvector();
-
-
- /* We get the arguments passed in fortran by adress. */
- target_Qp = *Qp_in; /* target value of Qp */
- target_Qs = *Qs_in; /* target value of Qs */
- n = *nmech_in; /* number of mechanisms */
- f1 = *f1_in; /* shortest frequency (Hz) */
- f2 = *f2_in; /* highest frequency (Hz) */
-
- /*
- printf("target value of Qp: ");
- scanf("%lf",&target_Qp);
- printf("%lf\n",target_Qp);
-
- printf("target value of Qs: ");
- scanf("%lf",&target_Qs);
- printf("%lf\n",target_Qs);
-
- printf("shortest frequency (Hz): ");
- scanf("%lf",&f1);
- printf("%lf\n",f1);
-
- printf("highest frequency (Hz): ");
- scanf("%lf",&f2);
- printf("%lf\n",f2);
-
- printf("number of mechanisms: ");
- scanf("%d",&n);
- printf("%d\n",n);
- */
-
-/* DK DK printf("1 = use xmgr 0 = do not use xmgr: "); */
-/* scanf("%d",&xmgr); */
- xmgr = 0;
-
- if (f2 < f1) {
- printf("T2 > T1\n");
- exit; }
-
- if (target_Qp <= 0.0001) {
- printf("Qp cannot be negative or null\n");
- exit; }
-
- if (target_Qs <= 0.0001) {
- printf("Qs cannot be negative or null\n");
- exit; }
-
- if (n < 1) {
- printf("n < 1\n");
- exit; }
-
- om0 = PI2 * pow(10.0, 0.5 * (log10(f1) + log10(f2)));
-
- /*
- printf("\n! put this in file constants.h\n\n");
-
- printf("! number of standard linear solids for attenuation\n");
- printf(" integer, parameter :: N_SLS = %d\n\n",n);
-
- printf("! put this in file attenuation_model.f90\n\n");
-
- printf("! frequency range: %lf Hz - %lf Hz\n", f1 , f2);
- printf("! central frequency in log scale in Hz = %20.15f\n",om0 / PI2);
-
- printf("! target constant attenuation factor Qp = %20.10lf\n", target_Qp);
- printf("! target constant attenuation factor Qs = %20.10lf\n\n", target_Qs);
-
- printf("! tau_sigma evenly spaced in log frequency, do not depend on value of Q\n\n");
- */
-
- plot = 0;
-
-/* loop on the Qp dilatation mode (nu = 1) and Qs shear mode (nu = 2) */
- for (nu = 1; nu <= 2; nu++) {
-
-/* assign Qp or Qs to generic variable Q_s which is used for the calculations */
- if (nu == 1) { Q_s = target_Qp ; }
- if (nu == 2) { Q_s = target_Qs ; }
-
- tau_s = dvector(1, n);
- tau_e = dvector(1, n);
-
- constant_Q2_sub(f1, f2, n, Q_s, tau_s, tau_e, xmgr);
-
-/* output in Fortran90 format */
- for (i = 1; i <= n; i++) {
- /*
- printf(" tau_sigma_nu%d(%1d) = %30.20lfd0\n", nu, i, tau_s[i]);
- */
- /* We put the results in tau_sigma_nu to get them in fortran. */
- if ( nu == 1 ) {
- tau_sigma_nu1[i-1] = tau_s[i];
- }
- if ( nu == 2 ) {
- tau_sigma_nu2[i-1] = tau_s[i];
- }
-
- }
- //printf("\n");
-
- for (i = 1; i <= n; i++) {
- /*
- printf(" tau_epsilon_nu%d(%1d) = %30.20lfd0\n", nu, i, tau_e[i]);
- */
- /* We put the results in tau_epsilon_nu to get them in fortran. */
- if ( nu == 1 ) {
- tau_epsilon_nu1[i-1] = tau_e[i];
- }
- if ( nu == 2 ) {
- tau_epsilon_nu2[i-1] = tau_e[i];
- }
-
- }
- //printf("\n");
-
- free_dvector(tau_s, 1, n);
- free_dvector(tau_e, 1, n);
-
- }
-
-}
-
-void plot_modulus(f1, f2, n, m, mR, Q, tau_e, tau_s ,xmgr)
- int n, xmgr;
- double f1, f2, m, mR, Q, *tau_e, *tau_s;
-{
-int pid, i;
-double exp1, exp2, dexp, expo;
-double f, om, Omega;
-double a, b, m_om, m_prem;
-char strng[180];
-int getpid(), system();
-FILE *fp_v, *fp_q;
-
-pid = getpid();
-sprintf(strng, "modulus%1d", pid);
-if((fp_v=fopen(strng,"w"))==NULL) {
- puts("cannot open file\n");
- exit;
-}
-sprintf(strng, "Q%1d", pid);
-if((fp_q=fopen(strng,"w"))==NULL) {
- puts("cannot open file\n");
- exit;
-}
-
-exp1 = log10(f1) - 2.0;
-exp2 = log10(f2) + 2.0;
-dexp = (exp2 - exp1) / 100.0;
-for (expo = exp1; expo <= exp2; expo += dexp) {
- f = pow(10.0, expo);
- om = PI2 * f;
- a = 1.0;
- b = 0.0;
- for (i = 1; i <= n; i++) {
- a -= om * om * tau_e[i] * (tau_e[i] - tau_s[i]) /
- (1.0 + om * om * tau_e[i] * tau_e[i]);
- b += om * (tau_e[i] - tau_s[i]) /
- (1.0 + om * om * tau_e[i] * tau_e[i]);
- }
- Omega=a*(sqrt(1.0+b*b/(a*a))-1.0);
- m_om = 2.0*mR* Omega/(b*b);
- m_prem = m * (1.0 + (2.0 / (PI * Q)) * log(om / PI2));
- fprintf(fp_v, "%f %f %f\n", expo, m_om/m, m_prem/m);
- if (om >= PI2 * f1 && om <= PI2 * f2) {
- fprintf(fp_q, "%f %f %f\n", expo, 1.0/atan(b/a), Q);
- }
-}
-fclose(fp_v);
-fclose(fp_q);
-
-/* DK DK call xmgr to plot curves if needed */
-
-if (xmgr == 1) {
- sprintf(strng, "xmgr -nxy Q%1d", pid);
- system(strng);
- sprintf(strng, "xmgr -nxy modulus%1d", pid);
- system(strng);
- sprintf(strng, "rm modulus%1d", pid);
- system(strng);
- sprintf(strng, "rm Q%1d", pid);
- system(strng);
-}
-
-}
-
-#include <malloc.h>
-#include <stdio.h>
-
-void nrerror(error_text)
-char error_text[];
-{
- void exit();
-
- fprintf(stderr,"Numerical Recipes run-time error...\n");
- fprintf(stderr,"%s\n",error_text);
- fprintf(stderr,"...now exiting to system...\n");
- exit(1);
-}
-
-float *vector(nl,nh)
-int nl,nh;
-{
- float *v;
-
- v=(float *)malloc((unsigned) (nh-nl+1)*sizeof(float));
- if (!v) nrerror("allocation failure in vector()");
- return v-nl;
-}
-
-int *ivector(nl,nh)
-int nl,nh;
-{
- int *v;
-
- v=(int *)malloc((unsigned) (nh-nl+1)*sizeof(int));
- if (!v) nrerror("allocation failure in ivector()");
- return v-nl;
-}
-
-double *dvector(nl,nh)
-int nl,nh;
-{
- double *v;
-
- v=(double *)malloc((unsigned) (nh-nl+1)*sizeof(double));
- if (!v) nrerror("allocation failure in dvector()");
- return v-nl;
-}
-
-
-
-float **matrix(nrl,nrh,ncl,nch)
-int nrl,nrh,ncl,nch;
-{
- int i;
- float **m;
-
- m=(float **) malloc((unsigned) (nrh-nrl+1)*sizeof(float*));
- if (!m) nrerror("allocation failure 1 in matrix()");
- m -= nrl;
-
- for(i=nrl;i<=nrh;i++) {
- m[i]=(float *) malloc((unsigned) (nch-ncl+1)*sizeof(float));
- if (!m[i]) nrerror("allocation failure 2 in matrix()");
- m[i] -= ncl;
- }
- return m;
-}
-
-double **dmatrix(nrl,nrh,ncl,nch)
-int nrl,nrh,ncl,nch;
-{
- int i;
- double **m;
-
- m=(double **) malloc((unsigned) (nrh-nrl+1)*sizeof(double*));
- if (!m) nrerror("allocation failure 1 in dmatrix()");
- m -= nrl;
-
- for(i=nrl;i<=nrh;i++) {
- m[i]=(double *) malloc((unsigned) (nch-ncl+1)*sizeof(double));
- if (!m[i]) nrerror("allocation failure 2 in dmatrix()");
- m[i] -= ncl;
- }
- return m;
-}
-
-int **imatrix(nrl,nrh,ncl,nch)
-int nrl,nrh,ncl,nch;
-{
- int i,**m;
-
- m=(int **)malloc((unsigned) (nrh-nrl+1)*sizeof(int*));
- if (!m) nrerror("allocation failure 1 in imatrix()");
- m -= nrl;
-
- for(i=nrl;i<=nrh;i++) {
- m[i]=(int *)malloc((unsigned) (nch-ncl+1)*sizeof(int));
- if (!m[i]) nrerror("allocation failure 2 in imatrix()");
- m[i] -= ncl;
- }
- return m;
-}
-
-
-
-float **submatrix(a,oldrl,oldrh,oldcl,oldch,newrl,newcl)
-float **a;
-int oldrl,oldrh,oldcl,oldch,newrl,newcl;
-{
- int i,j;
- float **m;
-
- m=(float **) malloc((unsigned) (oldrh-oldrl+1)*sizeof(float*));
- if (!m) nrerror("allocation failure in submatrix()");
- m -= newrl;
-
- for(i=oldrl,j=newrl;i<=oldrh;i++,j++) m[j]=a[i]+oldcl-newcl;
-
- return m;
-}
-
-
-
-void free_vector(v,nl,nh)
-float *v;
-int nl,nh;
-{
- free((char*) (v+nl));
-}
-
-void free_ivector(v,nl,nh)
-int *v,nl,nh;
-{
- free((char*) (v+nl));
-}
-
-void free_dvector(v,nl,nh)
-double *v;
-int nl,nh;
-{
- free((char*) (v+nl));
-}
-
-
-
-void free_matrix(m,nrl,nrh,ncl,nch)
-float **m;
-int nrl,nrh,ncl,nch;
-{
- int i;
-
- for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
- free((char*) (m+nrl));
-}
-
-void free_dmatrix(m,nrl,nrh,ncl,nch)
-double **m;
-int nrl,nrh,ncl,nch;
-{
- int i;
-
- for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
- free((char*) (m+nrl));
-}
-
-void free_imatrix(m,nrl,nrh,ncl,nch)
-int **m;
-int nrl,nrh,ncl,nch;
-{
- int i;
-
- for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
- free((char*) (m+nrl));
-}
-
-
-
-void free_submatrix(b,nrl,nrh,ncl,nch)
-float **b;
-int nrl,nrh,ncl,nch;
-{
- free((char*) (b+nrl));
-}
-
-
-
-float **convert_matrix(a,nrl,nrh,ncl,nch)
-float *a;
-int nrl,nrh,ncl,nch;
-{
- int i,j,nrow,ncol;
- float **m;
-
- nrow=nrh-nrl+1;
- ncol=nch-ncl+1;
- m = (float **) malloc((unsigned) (nrow)*sizeof(float*));
- if (!m) nrerror("allocation failure in convert_matrix()");
- m -= nrl;
- for(i=0,j=nrl;i<=nrow-1;i++,j++) m[j]=a+ncol*i-ncl;
- return m;
-}
-
-
-
-void free_convert_matrix(b,nrl,nrh,ncl,nch)
-float **b;
-int nrl,nrh,ncl,nch;
-{
- free((char*) (b+nrl));
-}
-
-#include <math.h>
-
-#define NMAX 5000
-#define ALPHA 1.0
-#define BETA 0.5
-#define GAMMA 2.0
-
-#define GET_PSUM for (j=1;j<=ndim;j++) { for (i=1,sum=0.0;i<=mpts;i++)\
- sum += p[i][j]; psum[j]=sum;}
-
-void amoeba(p,y,ndim,ftol,funk,nfunk)
-float **p,y[],ftol,(*funk)();
-int ndim,*nfunk;
-{
- int i,j,ilo,ihi,inhi,mpts=ndim+1;
- float ytry,ysave,sum,rtol,amotry(),*psum,*vector();
- void nrerror(),free_vector();
-
- psum=vector(1,ndim);
- *nfunk=0;
- GET_PSUM
- for (;;) {
- ilo=1;
- ihi = y[1]>y[2] ? (inhi=2,1) : (inhi=1,2);
- for (i=1;i<=mpts;i++) {
- if (y[i] < y[ilo]) ilo=i;
- if (y[i] > y[ihi]) {
- inhi=ihi;
- ihi=i;
- } else if (y[i] > y[inhi])
- if (i != ihi) inhi=i;
- }
- rtol=2.0*fabs(y[ihi]-y[ilo])/(fabs(y[ihi])+fabs(y[ilo]));
- if (rtol < ftol) break;
- if (*nfunk >= NMAX) nrerror("Too many iterations in AMOEBA");
- ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,-ALPHA);
- if (ytry <= y[ilo])
- ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,GAMMA);
- else if (ytry >= y[inhi]) {
- ysave=y[ihi];
- ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,BETA);
- if (ytry >= ysave) {
- for (i=1;i<=mpts;i++) {
- if (i != ilo) {
- for (j=1;j<=ndim;j++) {
- psum[j]=0.5*(p[i][j]+p[ilo][j]);
- p[i][j]=psum[j];
- }
- y[i]=(*funk)(psum);
- }
- }
- *nfunk += ndim;
- GET_PSUM
- }
- }
- }
- free_vector(psum,1,ndim);
-}
-
-float amotry(p,y,psum,ndim,funk,ihi,nfunk,fac)
-float **p,*y,*psum,(*funk)(),fac;
-int ndim,ihi,*nfunk;
-{
- int j;
- float fac1,fac2,ytry,*ptry,*vector();
- void nrerror(),free_vector();
-
- ptry=vector(1,ndim);
- fac1=(1.0-fac)/ndim;
- fac2=fac1-fac;
- for (j=1;j<=ndim;j++) ptry[j]=psum[j]*fac1-p[ihi][j]*fac2;
- ytry=(*funk)(ptry);
- ++(*nfunk);
- if (ytry < y[ihi]) {
- y[ihi]=ytry;
- for (j=1;j<=ndim;j++) {
- psum[j] += ptry[j]-p[ihi][j];
- p[ihi][j]=ptry[j];
- }
- }
- free_vector(ptry,1,ndim);
- return ytry;
-}
-
-#undef ALPHA
-#undef BETA
-#undef GAMMA
-#undef NMAX
-
-void spline(x,y,n,yp1,ypn,y2)
-float x[],y[],yp1,ypn,y2[];
-int n;
-{
- int i,k;
- float p,qn,sig,un,*u,*vector();
- void free_vector();
-
- u=vector(1,n-1);
- if (yp1 > 0.99e30)
- y2[1]=u[1]=0.0;
- else {
- y2[1] = -0.5;
- u[1]=(3.0/(x[2]-x[1]))*((y[2]-y[1])/(x[2]-x[1])-yp1);
- }
- for (i=2;i<=n-1;i++) {
- sig=(x[i]-x[i-1])/(x[i+1]-x[i-1]);
- p=sig*y2[i-1]+2.0;
- y2[i]=(sig-1.0)/p;
- u[i]=(y[i+1]-y[i])/(x[i+1]-x[i]) - (y[i]-y[i-1])/(x[i]-x[i-1]);
- u[i]=(6.0*u[i]/(x[i+1]-x[i-1])-sig*u[i-1])/p;
- }
- if (ypn > 0.99e30)
- qn=un=0.0;
- else {
- qn=0.5;
- un=(3.0/(x[n]-x[n-1]))*(ypn-(y[n]-y[n-1])/(x[n]-x[n-1]));
- }
- y2[n]=(un-qn*u[n-1])/(qn*y2[n-1]+1.0);
- for (k=n-1;k>=1;k--)
- y2[k]=y2[k]*y2[k+1]+u[k];
- free_vector(u,1,n-1);
-}
-
-void splint(xa,ya,y2a,n,x,y)
-float xa[],ya[],y2a[],x,*y;
-int n;
-{
- int klo,khi,k;
- float h,b,a;
- void nrerror();
-
- klo=1;
- khi=n;
- while (khi-klo > 1) {
- k=(khi+klo) >> 1;
- if (xa[k] > x) khi=k;
- else klo=k;
- }
- h=xa[khi]-xa[klo];
- if (h == 0.0) nrerror("Bad XA input to routine SPLINT");
- a=(xa[khi]-x)/h;
- b=(x-xa[klo])/h;
- *y=a*ya[klo]+b*ya[khi]+((a*a*a-a)*y2a[klo]+(b*b*b-b)*y2a[khi])*(h*h)/6.0;
-}
-
-#define FUNC(x) ((*func)(x))
-
-float trapzd(func,a,b,n)
-float a,b;
-float (*func)(); /* ANSI: float (*func)(float); */
-int n;
-{
- float x,tnm,sum,del;
- static float s;
- static int it;
- int j;
-
- if (n == 1) {
- it=1;
- return (s=0.5*(b-a)*(FUNC(a)+FUNC(b)));
- } else {
- tnm=it;
- del=(b-a)/tnm;
- x=a+0.5*del;
- for (sum=0.0,j=1;j<=it;j++,x+=del) sum += FUNC(x);
- it *= 2;
- s=0.5*(s+(b-a)*sum/tnm);
- return s;
- }
-}
-
-#include <math.h>
-
-#define EPS 0.5e-5
-#define JMAX 20
-#define JMAXP JMAX+1
-#define K 5
-
-float qromb(func,a,b)
-float a,b;
-float (*func)();
-{
- float ss,dss,trapzd();
- float s[JMAXP+1],h[JMAXP+1];
- int j;
- void polint(),nrerror();
-
- h[1]=1.0;
- for (j=1;j<=JMAX;j++) {
- s[j]=trapzd(func,a,b,j);
- if (j >= K) {
- polint(&h[j-K],&s[j-K],K,0.0,&ss,&dss);
- if (fabs(dss) < EPS*fabs(ss)) return ss;
- }
- s[j+1]=s[j];
- h[j+1]=0.25*h[j];
- }
- nrerror("Too many steps in routine QROMB");
-}
-
-#undef EPS
-#undef JMAX
-#undef JMAXP
-#undef K
-
-#include <math.h>
-
-void polint(xa,ya,n,x,y,dy)
-float xa[],ya[],x,*y,*dy;
-int n;
-{
- int i,m,ns=1;
- float den,dif,dift,ho,hp,w;
- float *c,*d,*vector();
- void nrerror(),free_vector();
-
- dif=fabs(x-xa[1]);
- c=vector(1,n);
- d=vector(1,n);
- for (i=1;i<=n;i++) {
- if ( (dift=fabs(x-xa[i])) < dif) {
- ns=i;
- dif=dift;
- }
- c[i]=ya[i];
- d[i]=ya[i];
- }
- *y=ya[ns--];
- for (m=1;m<n;m++) {
- for (i=1;i<=n-m;i++) {
- ho=xa[i]-x;
- hp=xa[i+m]-x;
- w=c[i+1]-d[i];
- if ( (den=ho-hp) == 0.0) nrerror("Error in routine POLINT");
- den=w/den;
- d[i]=hp*den;
- c[i]=ho*den;
- }
- *y += (*dy=(2*ns < (n-m) ? c[ns+1] : d[ns--]));
- }
- free_vector(d,1,n);
- free_vector(c,1,n);
-}
-
-#define MBIG 1000000000
-#define MSEED 161803398
-#define MZ 0
-#define FAC (1.0/MBIG)
-
-float ran3(idum)
-int *idum;
-{
- static int inext,inextp;
- static long ma[56];
- static int iff=0;
- long mj,mk;
- int i,ii,k;
-
- if (*idum < 0 || iff == 0) {
- iff=1;
- mj=MSEED-(*idum < 0 ? -*idum : *idum);
- mj %= MBIG;
- ma[55]=mj;
- mk=1;
- for (i=1;i<=54;i++) {
- ii=(21*i) % 55;
- ma[ii]=mk;
- mk=mj-mk;
- if (mk < MZ) mk += MBIG;
- mj=ma[ii];
- }
- for (k=1;k<=4;k++)
- for (i=1;i<=55;i++) {
- ma[i] -= ma[1+(i+30) % 55];
- if (ma[i] < MZ) ma[i] += MBIG;
- }
- inext=0;
- inextp=31;
- *idum=1;
- }
- if (++inext == 56) inext=1;
- if (++inextp == 56) inextp=1;
- mj=ma[inext]-ma[inextp];
- if (mj < MZ) mj += MBIG;
- ma[inext]=mj;
- return mj*FAC;
-}
-
-#undef MBIG
-#undef MSEED
-#undef MZ
-#undef FAC
-
-#include <math.h>
-
-static double at,bt,ct;
-#define PYTHAG(a,b) ((at=fabs(a)) > (bt=fabs(b)) ? \
-(ct=bt/at,at*sqrt(1.0+ct*ct)) : (bt ? (ct=at/bt,bt*sqrt(1.0+ct*ct)): 0.0))
-
-static double maxarg1,maxarg2;
-#define MAX(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1) > (maxarg2) ?\
- (maxarg1) : (maxarg2))
-#define SIGN(a,b) ((b) >= 0.0 ? fabs(a) : -fabs(a))
-
-void dsvdcmp(a,m,n,w,v)
-double **a,*w,**v;
-int m,n;
-{
- int flag,i,its,j,jj,k,l,nm;
- double c,f,h,s,x,y,z;
- double anorm=0.0,g=0.0,scale=0.0;
- double *rv1,*dvector();
- void nrerror(),free_dvector();
-
- if (m < n) nrerror("SVDCMP: You must augment A with extra zero rows");
- rv1=dvector(1,n);
- for (i=1;i<=n;i++) {
- l=i+1;
- rv1[i]=scale*g;
- g=s=scale=0.0;
- if (i <= m) {
- for (k=i;k<=m;k++) scale += fabs(a[k][i]);
- if (scale) {
- for (k=i;k<=m;k++) {
- a[k][i] /= scale;
- s += a[k][i]*a[k][i];
- }
- f=a[i][i];
- g = -SIGN(sqrt(s),f);
- h=f*g-s;
- a[i][i]=f-g;
- if (i != n) {
- for (j=l;j<=n;j++) {
- for (s=0.0,k=i;k<=m;k++) s += a[k][i]*a[k][j];
- f=s/h;
- for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
- }
- }
- for (k=i;k<=m;k++) a[k][i] *= scale;
- }
- }
- w[i]=scale*g;
- g=s=scale=0.0;
- if (i <= m && i != n) {
- for (k=l;k<=n;k++) scale += fabs(a[i][k]);
- if (scale) {
- for (k=l;k<=n;k++) {
- a[i][k] /= scale;
- s += a[i][k]*a[i][k];
- }
- f=a[i][l];
- g = -SIGN(sqrt(s),f);
- h=f*g-s;
- a[i][l]=f-g;
- for (k=l;k<=n;k++) rv1[k]=a[i][k]/h;
- if (i != m) {
- for (j=l;j<=m;j++) {
- for (s=0.0,k=l;k<=n;k++) s += a[j][k]*a[i][k];
- for (k=l;k<=n;k++) a[j][k] += s*rv1[k];
- }
- }
- for (k=l;k<=n;k++) a[i][k] *= scale;
- }
- }
- anorm=MAX(anorm,(fabs(w[i])+fabs(rv1[i])));
- }
- for (i=n;i>=1;i--) {
- if (i < n) {
- if (g) {
- for (j=l;j<=n;j++)
- v[j][i]=(a[i][j]/a[i][l])/g;
- for (j=l;j<=n;j++) {
- for (s=0.0,k=l;k<=n;k++) s += a[i][k]*v[k][j];
- for (k=l;k<=n;k++) v[k][j] += s*v[k][i];
- }
- }
- for (j=l;j<=n;j++) v[i][j]=v[j][i]=0.0;
- }
- v[i][i]=1.0;
- g=rv1[i];
- l=i;
- }
- for (i=n;i>=1;i--) {
- l=i+1;
- g=w[i];
- if (i < n)
- for (j=l;j<=n;j++) a[i][j]=0.0;
- if (g) {
- g=1.0/g;
- if (i != n) {
- for (j=l;j<=n;j++) {
- for (s=0.0,k=l;k<=m;k++) s += a[k][i]*a[k][j];
- f=(s/a[i][i])*g;
- for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
- }
- }
- for (j=i;j<=m;j++) a[j][i] *= g;
- } else {
- for (j=i;j<=m;j++) a[j][i]=0.0;
- }
- ++a[i][i];
- }
- for (k=n;k>=1;k--) {
- for (its=1;its<=30;its++) {
- flag=1;
- for (l=k;l>=1;l--) {
- nm=l-1;
- if (fabs(rv1[l])+anorm == anorm) {
- flag=0;
- break;
- }
- if (fabs(w[nm])+anorm == anorm) break;
- }
- if (flag) {
- c=0.0;
- s=1.0;
- for (i=l;i<=k;i++) {
- f=s*rv1[i];
- if (fabs(f)+anorm != anorm) {
- g=w[i];
- h=PYTHAG(f,g);
- w[i]=h;
- h=1.0/h;
- c=g*h;
- s=(-f*h);
- for (j=1;j<=m;j++) {
- y=a[j][nm];
- z=a[j][i];
- a[j][nm]=y*c+z*s;
- a[j][i]=z*c-y*s;
- }
- }
- }
- }
- z=w[k];
- if (l == k) {
- if (z < 0.0) {
- w[k] = -z;
- for (j=1;j<=n;j++) v[j][k]=(-v[j][k]);
- }
- break;
- }
- if (its == 60) nrerror("No convergence in 60 SVDCMP iterations");
- x=w[l];
- nm=k-1;
- y=w[nm];
- g=rv1[nm];
- h=rv1[k];
- f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y);
- g=PYTHAG(f,1.0);
- f=((x-z)*(x+z)+h*((y/(f+SIGN(g,f)))-h))/x;
- c=s=1.0;
- for (j=l;j<=nm;j++) {
- i=j+1;
- g=rv1[i];
- y=w[i];
- h=s*g;
- g=c*g;
- z=PYTHAG(f,h);
- rv1[j]=z;
- c=f/z;
- s=h/z;
- f=x*c+g*s;
- g=g*c-x*s;
- h=y*s;
- y=y*c;
- for (jj=1;jj<=n;jj++) {
- x=v[jj][j];
- z=v[jj][i];
- v[jj][j]=x*c+z*s;
- v[jj][i]=z*c-x*s;
- }
- z=PYTHAG(f,h);
- w[j]=z;
- if (z) {
- z=1.0/z;
- c=f*z;
- s=h*z;
- }
- f=(c*g)+(s*y);
- x=(c*y)-(s*g);
- for (jj=1;jj<=m;jj++) {
- y=a[jj][j];
- z=a[jj][i];
- a[jj][j]=y*c+z*s;
- a[jj][i]=z*c-y*s;
- }
- }
- rv1[l]=0.0;
- rv1[k]=f;
- w[k]=x;
- }
- }
- free_dvector(rv1,1,n);
-}
-
-#undef SIGN
-#undef MAX
-#undef PYTHAG
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <stdio.h>
-#include <math.h>
-#include <sgtty.h>
-#include <signal.h>
-#include <stdlib.h>
-
-/* useful constants */
-
-#define PI 3.14159265358979
-#define PI2 6.28318530717958
-
-void constant_Q2_sub(f1, f2, n, Q, tau_s, tau_e, xmgr)
-
- int n, xmgr;
- double f1, f2, Q;
- double *tau_s, *tau_e;
-{
- int i,j;
- double *x1, *x2;
- double *gradient, **hessian;
- double *dvector(), **dmatrix();
- void derivatives();
- void initialize(), invert();
- void free_dvector(), free_dmatrix();
-
- if (f2 < f1) {
- printf("T2 > T1\n");
- exit;
- }
- if (Q < 0.0) {
- printf("Q < 0\n");
- exit;
- }
- if (n < 1) {
- printf("n < 1\n");
- exit;
- }
-
- x1 = dvector(1, n);
- x2 = dvector(1, n);
- gradient = dvector(1, n);
- hessian = dmatrix(1, n, 1, n);
- for(i=1;i<=n;i++) {
- x1[i]=0.0;
- x2[i]=0.0;
- gradient[i]=0.0;
- for(j=1;j<=n;j++) hessian[i][j]=0.0;
- }
-
- initialize(f1, f2, n, Q, x1, x2);
-
- derivatives(f1, f2, n, Q, x1, x2, gradient, hessian);
-
- invert(x1, gradient, hessian, n);
-
- free_dvector(gradient, 1, n);
- free_dmatrix(hessian, 1, n, 1, n);
-
- for (i = 1; i <= n; i++) {
- tau_e[i]=x1[i] + x2[i];
- }
- for (i = 1; i <= n; i++) {
- tau_s[i]=x2[i];
- }
-
- free_dvector(x1, 1, n);
- free_dvector(x2, 1, n);
-
-}
-
-void initialize(f1, f2, n, Q, x1, x2)
- int n;
- double f1, f2, Q, *x1, *x2;
-{
-int i;
-double q, omega, *tau_e, *tau_s;
-double exp1, exp2, dexp, expo;
-double *dvector();
-void free_dvector();
-
-tau_e = dvector(1, n);
-tau_s = dvector(1, n);
-if (n > 1) {
- exp1 = log10(f1);
- exp2 = log10(f2);
- dexp = (exp2 - exp1) / ((double) (n - 1));
- q = 1.0 / ((n - 1.0) * Q);
- for (i = 1, expo = exp1; i <= n; i++, expo += dexp) {
- omega = PI2 * pow(10.0, expo);
- tau_s[i] = 1.0 / omega;
- tau_e[i] = tau_s[i] * (1.0 + q) / (1.0 - q);
- }
-} else {
- q = 1.0 / Q;
- exp1 = log10(f1);
- exp2 = log10(f2);
- expo=(exp1+exp2)/2.0;
- omega = PI2 * pow(10.0, expo);
- tau_s[1] = 1.0 / omega;
- tau_e[1] = tau_s[1] * (1.0 + q) / (1.0 - q);
-}
-/*
- * x1 denotes the parameter tau_e - tau_s and x2 denotes the parameter tau_s
- */
-for (i = 1; i <= n; i++) {
- x1[i] = tau_e[i] - tau_s[i];
- x2[i] = tau_s[i];
-}
-
-free_dvector(tau_e, 1, n);
-free_dvector(tau_s, 1, n);
-}
-
-double penalty(f1, f2, n, Q, x1, x2)
- int n;
- double f1, f2, Q, *x1, *x2;
-{
-int i;
-double exp1, exp2, dexp, expo;
-double pnlt;
-double f, df, omega;
-double tau_e, tau_s, a, b, Q_omega;
-
-exp1 = log10(f1);
-exp2 = log10(f2);
-dexp = (exp2 - exp1) / 100.0;
-pnlt = 0.0;
-for (expo = exp1; expo <= exp2; expo += dexp) {
- f = pow(10.0, expo);
- df = pow(10.0, expo + dexp) - f;
- omega = PI2 * f;
- a = (double) (1 - n);
- b = 0.0;
- for (i = 1; i <= n; i++) {
- tau_e = x1[i] + x2[i];
- tau_s = x2[i];
- a += (1.0 + omega * omega * tau_e * tau_s) /
- (1.0 + omega * omega * tau_s * tau_s);
- b += omega * (tau_e - tau_s) /
- (1.0 + omega * omega * tau_s * tau_s);
- }
- Q_omega = a / b;
- pnlt += pow(1.0 / Q - 1.0 / Q_omega, 2.0) * df;
-}
-pnlt /= (f2 - f1);
-return pnlt;
-}
-
-
-void derivatives(f1, f2, n, Q, x1, x2, gradient, hessian)
- int n;
- double f1, f2, Q, *x1, *x2;
- double *gradient, **hessian;
-{
-int i, j;
-double exp1, exp2, dexp, expo;
-double f, df, omega;
-double *dadp, *dbdp, *dqdp, d2qdp2;
-double tau_e, tau_s, a, b, Q_omega;
-double *dvector();
-void free_dvector();
-
-dadp = dvector(1, n);
-dbdp = dvector(1, n);
-dqdp = dvector(1, n);
-exp1 = log10(f1);
-exp2 = log10(f2);
-dexp = (exp2 - exp1) / 100.0;
-for (i = 1; i <= n; i++) {
- gradient[i] = 0.0;
- for (j = 1; j <= i; j++) {
- hessian[j][i] = 0.0;
- hessian[j][i] = hessian[i][j];
- }
-}
-for (expo = exp1; expo <= exp2; expo += dexp) {
- f = pow(10.0, expo);
- df = pow(10.0, expo + dexp) - f;
- omega = PI2 * f;
- a = (double) (1 - n);
- b = 0.0;
- for (i = 1; i <= n; i++) {
- tau_e = x1[i] + x2[i];
- tau_s = x2[i];
- a += (1.0 + omega * omega * tau_e * tau_s) /
- (1.0 + omega * omega * tau_s * tau_s);
- b += omega * (tau_e - tau_s) /
- (1.0 + omega * omega * tau_s * tau_s);
- dadp[i] = omega * omega * tau_s / (1.0 + omega * omega * tau_s * tau_s);
- dbdp[i] = omega / (1.0 + omega * omega * tau_s * tau_s);
- }
- Q_omega = a / b;
- for (i = 1; i <= n; i++) {
- dqdp[i] = (dbdp[i] - (b / a) * dadp[i]) / a;
- gradient[i] += 2.0 * (1.0 / Q_omega - 1.0 / Q) * dqdp[i] * df / (f2 - f1);
- for (j = 1; j <= i; j++) {
- d2qdp2 = -(dadp[i] * dbdp[j] + dbdp[i] * dadp[j]
- - 2.0 * (b / a) * dadp[i] * dadp[j]) / (a * a);
- hessian[i][j] += (2.0 * dqdp[i] * dqdp[j] + 2.0 * (1.0 / Q_omega - 1.0 / Q) * d2qdp2)
- * df / (f2 - f1);
- hessian[j][i] = hessian[i][j];
- }
- }
-}
-free_dvector(dadp, 1, n);
-free_dvector(dbdp, 1, n);
-free_dvector(dqdp, 1, n);
-}
-
-void invert(x, b, A, n)
- int n;
- double *x;
- double *b, **A;
-{
-int i, j, k;
-double *dvector(), **dmatrix();
-double *xp, *W, **V, **A_inverse;
-void free_dvector(), free_dmatrix(), dsvdcmp();
-
-xp = dvector(1, n);
-W = dvector(1, n);
-V = dmatrix(1, n, 1, n);
-A_inverse = dmatrix(1, n, 1, n);
-dsvdcmp(A, n, n, W, V);
-for (i = 1; i <= n; i++)
- for (j = 1; j <= n; j++)
- V[i][j] = (1.0 / W[i]) * A[j][i];
-for (i = 1; i <= n; i++) {
- for (j = 1; j <= n; j++) {
- A_inverse[i][j] = 0.0;
- for (k = 1; k <= n; k++)
- A_inverse[i][j] += A[i][k] * V[k][j];
- }
-}
-free_dvector(W, 1, n);
-free_dmatrix(V, 1, n, 1, n);
-for (i = 1; i <= n; i++) {
- xp[i] = x[i];
- for (j = 1; j <= n; j++) {
- xp[i] -= A_inverse[i][j] * b[j];
- }
- x[i] = xp[i];
-}
-free_dvector(xp, 1, n);
-free_dmatrix(A_inverse, 1, n, 1, n);
-}
Deleted: seismo/2D/SPECFEM2D/trunk/attenuation_model.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/attenuation_model.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/attenuation_model.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,153 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine attenuation_model(N_SLS,Qp_attenuation,Qs_attenuation,f0_attenuation, &
- inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2)
-
-! define the attenuation constants
-
- implicit none
-
- include "constants.h"
-
- integer :: N_SLS
- double precision :: Qp_attenuation,Qs_attenuation,f0_attenuation
- double precision, dimension(N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
- double precision :: Mu_nu1,Mu_nu2
-
- integer :: i_sls
-
- double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,tau_epsilon_nu2,tau_sigma_nu2
-
- double precision :: f1_attenuation, f2_attenuation
-
-
-! f1 and f2 are computed as : f2/f1=12 and (log(f1)+log(f2))/2 = log(f0)
- f1_attenuation = exp(log(f0_attenuation)-log(12.d0)/2.d0)
- f2_attenuation = 12.d0 * f1_attenuation
-
-! Call of C function that computes attenuation parameters (function in file "attenuation_compute_param.c";
-! a main can be found in UTILS/attenuation directory).
-! Beware of underscores in this function name; depending on your compiler and compilation options, you will have to add or
-! delete underscores. Also look in file "attenuation_compute_param.c" for this issue.
- call attenuation_compute_param(N_SLS, Qp_attenuation, Qs_attenuation, &
- f1_attenuation,f2_attenuation, &
- tau_sigma_nu1, tau_sigma_nu2, tau_epsilon_nu1, tau_epsilon_nu2)
-
-! attenuation constants for standard linear solids
-
-! nu1 is the dilatation mode
-! nu2 is the shear mode
-
-! array index (1) is the first standard linear solid, (2) is the second etc.
-
-! from J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
-! vol. 58(1), p. 110-120 (1993) for two memory-variable mechanisms (page 112).
-! Beware: these values implement specific values of the quality factors:
-! Qp approximately equal to 13 and Qs approximately equal to 10,
-! which means very high attenuation, see that paper for details.
-! tau_epsilon_nu1(1) = 0.0334d0
-! tau_sigma_nu1(1) = 0.0303d0
-! tau_epsilon_nu2(1) = 0.0352d0
-! tau_sigma_nu2(1) = 0.0287d0
-
-! tau_epsilon_nu1(2) = 0.0028d0
-! tau_sigma_nu1(2) = 0.0025d0
-! tau_epsilon_nu2(2) = 0.0029d0
-! tau_sigma_nu2(2) = 0.0024d0
-
-! from J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation
-! in a linear viscoelastic medium, Geophysical Journal International,
-! vol. 95, p. 597-611 (1988) for two memory-variable mechanisms (page 604).
-! Beware: these values implement specific values of the quality factors:
-! Qp approximately equal to 27 and Qs approximately equal to 20,
-! which means very high attenuation, see that paper for details.
-! tau_epsilon_nu1(1) = 0.0325305d0
-! tau_sigma_nu1(1) = 0.0311465d0
-! tau_epsilon_nu2(1) = 0.0332577d0
-! tau_sigma_nu2(1) = 0.0304655d0
-
-! tau_epsilon_nu1(2) = 0.0032530d0
-! tau_sigma_nu1(2) = 0.0031146d0
-! tau_epsilon_nu2(2) = 0.0033257d0
-! tau_sigma_nu2(2) = 0.0030465d0
-
-! values for Paul Cristini for fluid-solid ocean acoustics simulations
-
-! for N_SLS = 2
-! frequency range: 1.500000 Hz - 18.000000 Hz
-! central frequency in log scale in Hz = 5.196152422706633
-! target constant attenuation factor Q = 136.4376068115
-! tau sigma evenly spaced in log frequency, do not depend on value of Q
-
-! tau_sigma_nu1(1) = 0.10610329539459699422d0
-! tau_sigma_nu1(2) = 0.00884194128288308401d0
-
-! tau_epsilon_nu1(1) = 0.10754721280605997191d0
-! tau_epsilon_nu1(2) = 0.00895488050110176612d0
-
-! tau_epsilon_nu2(1) = tau_epsilon_nu1(1)
-! tau_epsilon_nu2(2) = tau_epsilon_nu1(2)
-! tau_sigma_nu2(1) = tau_sigma_nu1(1)
-! tau_sigma_nu2(2) = tau_sigma_nu1(2)
-
-!
-!--- other constants computed from the parameters above, do not modify
-!
- inv_tau_sigma_nu1(:) = ONE / tau_sigma_nu1(:)
- inv_tau_sigma_nu2(:) = ONE / tau_sigma_nu2(:)
-
- phi_nu1(:) = (ONE - tau_epsilon_nu1(:)/tau_sigma_nu1(:)) / tau_sigma_nu1(:)
- phi_nu2(:) = (ONE - tau_epsilon_nu2(:)/tau_sigma_nu2(:)) / tau_sigma_nu2(:)
-
- Mu_nu1 = ONE
- Mu_nu2 = ONE
-
- do i_sls = 1,N_SLS
- Mu_nu1 = Mu_nu1 - (ONE - tau_epsilon_nu1(i_sls)/tau_sigma_nu1(i_sls))
- Mu_nu2 = Mu_nu2 - (ONE - tau_epsilon_nu2(i_sls)/tau_sigma_nu2(i_sls))
- enddo
-
- end subroutine attenuation_model
-
Deleted: seismo/2D/SPECFEM2D/trunk/calendar.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/calendar.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/calendar.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,729 +0,0 @@
-
- integer function julian_day(yr,mo,da)
-
- implicit none
-
- integer yr,mo,da
-
- integer mon(12)
- integer lpyr
- data mon /0,31,59,90,120,151,181,212,243,273,304,334/
-
- julian_day = da + mon(mo)
- if(mo>2) julian_day = julian_day + lpyr(yr)
-
- end function julian_day
-
-! ------------------------------------------------------------------
-
- integer function lpyr(yr)
-
- implicit none
-
- integer yr
-!
-!---- returns 1 if leap year
-!
- lpyr=0
- if(mod(yr,400) == 0) then
- lpyr=1
- else if(mod(yr,4) == 0) then
- lpyr=1
- if(mod(yr,100) == 0) lpyr=0
- endif
-
- end function lpyr
-
-! ------------------------------------------------------------------
-
-! function to determine if year is a leap year
- logical function is_leap_year(yr)
-
- implicit none
-
- integer yr
-
- integer, external :: lpyr
-
-!---- function lpyr above returns 1 if leap year
- if(lpyr(yr) == 1) then
- is_leap_year = .true.
- else
- is_leap_year = .false.
- endif
-
- end function is_leap_year
-
-
-!----------------------------------------------------------------------------------------------
-! open-source subroutines below taken from ftp://ftp.met.fsu.edu/pub/ahlquist/calendar_software
-!----------------------------------------------------------------------------------------------
-
- integer function idaywk(jdayno)
-
-! IDAYWK = compute the DAY of the WeeK given the Julian Day number,
-! version 1.0.
-
- implicit none
-
-! Input variable
- integer, intent(in) :: jdayno
-! jdayno = Julian Day number starting at noon of the day in question.
-
-! Output of the function:
-! idaywk = day of the week, where 0=Sunday, 1=Monday, ..., 6=Saturday.
-
-!----------
-! Compute the day of the week given the Julian Day number.
-! You can find the Julian Day number given (day,month,year)
-! using subroutine calndr below.
-! Example: For the first day of the Gregorian calendar,
-! Friday 15 October 1582, compute the Julian day number (option 3 of
-! subroutine calndr) and compute the day of the week.
-! call calndr (3, 15, 10, 1582, jdayno)
-! write(*,*) jdayno, idaywk(jdayno)
-! The numbers printed should be 2299161 and 5, where 5 refers to Friday.
-!
-! Copyright (C) 1999 Jon Ahlquist.
-! Issued under the second GNU General Public License.
-! See www.gnu.org for details.
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-! If you find any errors, please notify:
-! Jon Ahlquist <ahlquist at met.fsu.edu>
-! Dept of Meteorology
-! Florida State University
-! Tallahassee, FL 32306-4520
-! 15 March 1999.
-!
-!-----
-
-! converted to Fortran90 by Dimitri Komatitsch,
-! University of Pau, France, January 2008.
-
-! jdSun is the Julian Day number starting at noon on any Sunday.
-! I arbitrarily chose the first Sunday after Julian Day 1,
-! which is Julian Day 6.
- integer, parameter :: jdSun = 6
-
- idaywk = mod(jdayno-jdSun,7)
-
-! If jdayno-jdSun < 0, then we are taking the modulus of a negative
-! number. Fortran's built-in mod function returns a negative value
-! when the argument is negative. In that case, we adjust the result
-! to a positive value.
- if (idaywk < 0) idaywk = idaywk + 7
-
- end function idaywk
-
-!
-!----
-!
-
- subroutine calndr(iday,month,iyear,idayct)
-
-! CALNDR = CALeNDaR conversions, version 1.0
-
- implicit none
-
-! specify the desired calendar conversion option.
-! in order to return the julian day number, compatible with function idaywk from above,
-! we choose option 3
-! (tested with dates: Feb, 23 2010 -> idaywk = Tue
-! Dec, 24 2009 -> idaywk = Thu
-! Oct, 15 1582 -> idaywk = Fri ...which all look o.k. )
- integer, parameter :: ioptn = 3
-
-! Input/Output variables
- integer, intent(inout) :: iday,month,iyear,idayct
-
-!----------
-!
-! Subroutine calndr() performs calendar calculations using either
-! the standard Gregorian calendar or the old Julian calendar.
-! This subroutine extends the definitions of these calendar systems
-! to any arbitrary year. The algorithms in this subroutine
-! will work with any date in the past or future,
-! but overflows will occur if the numbers are sufficiently large.
-! For a computer using a 32-bit integer, this routine can handle
-! any date between roughly 5.8 million BC and 5.8 million AD
-! without experiencing overflow during calculations.
-!
-! No external functions or subroutines are called.
-!
-!----------
-!
-! INPUT/OUTPUT ARGUMENTS FOR SUBROUTINE CALNDR()
-!
-! "ioptn" is the desired calendar conversion option explained below.
-! Positive option values use the standard modern Gregorian calendar.
-! Negative option values use the old Julian calendar which was the
-! standard in Europe from its institution by Julius Caesar in 45 BC
-! until at least 4 October 1582. The Gregorian and Julian calendars
-! are explained further below.
-!
-! (iday,month,iyear) is a calendar date where "iday" is the day of
-! the month, "month" is 1 for January, 2 for February, etc.,
-! and "iyear" is the year. If the year is 1968 AD, enter iyear=1968,
-! since iyear=68 would refer to 68 AD.
-! For BC years, iyear should be negative, so 45 BC would be iyear=-45.
-! By convention, there is no year 0 under the BC/AD year numbering
-! scheme. That is, years proceed as 2 BC, 1 BC, 1 AD, 2 AD, etc.,
-! without including 0. Subroutine calndr() will print an error message
-! and stop if you specify iyear=0.
-!
-! "idayct" is a day count. It is either the day number during the
-! specified year or the Julian Day number, depending on the value
-! of ioptn. By day number during the specified year, we mean
-! idayct=1 on 1 January, idayct=32 on 1 February, etc., to idayct=365
-! or 366 on 31 December, depending on whether the specified year
-! is a leap year.
-!
-! The values of input variables are not changed by this subroutine.
-!
-!
-! ALLOWABLE VALUES FOR "IOPTN" and the conversions they invoke.
-! Positive option values ( 1 to 5) use the standard Gregorian calendar.
-! Negative option values (-1 to -5) use the old Julian calendar.
-!
-! Absolute
-! value
-! of ioptn Input variable(s) Output variable(s)
-!
-! 1 iday,month,iyear idayct
-! Given a calendar date (iday,month,iyear), compute the day number
-! (idayct) during the year, where 1 January is day number 1 and
-! 31 December is day number 365 or 366, depending on whether it is
-! a leap year.
-!
-! 2 idayct,iyear iday,month
-! Given the day number of the year (idayct) and the year (iyear),
-! compute the day of the month (iday) and the month (month).
-!
-! 3 iday,month,iyear idayct
-! Given a calendar date (iday,month,iyear), compute the Julian Day
-! number (idayct) that starts at noon of the calendar date specified.
-!
-! 4 idayct iday,month,iyear
-! Given the Julian Day number (idayct) that starts at noon,
-! compute the corresponding calendar date (iday,month,iyear).
-!
-! 5 idayct iday,month,iyear
-! Given the Julian Day number (idayct) that starts at noon,
-! compute the corresponding day number for the year (iday)
-! and year (iyear). On return from calndr(), "month" will always
-! be set equal to 1 when ioptn=5.
-!
-! No inverse function is needed for ioptn=5 because it is
-! available through option 3. One simply calls calndr() with:
-! ioptn = 3,
-! iday = day number of the year instead of day of the month,
-! month = 1, and
-! iyear = whatever the desired year is.
-!
-!----------
-!
-! EXAMPLES
-! The first 6 examples are for the standard Gregorian calendar.
-! All the examples deal with 15 October 1582, which was the first day
-! of the Gregorian calendar. 15 October is the 288-th day of the year.
-! Julian Day number 2299161 began at noon on 15 October 1582.
-!
-! Find the day number during the year on 15 October 1582
-! ioptn = 1
-! call calndr (ioptn, 15, 10, 1582, idayct)
-! calndr() should return idayct=288
-!
-! Find the day of the month and month for day 288 in year 1582.
-! ioptn = 2
-! call calndr (ioptn, iday, month, 1582, 288)
-! calndr() should return iday=15 and month=10.
-!
-! Find the Julian Day number for 15 October 1582.
-! ioptn = 3
-! call calndr (ioptn, 15, 10, 1582, julian)
-! calndr() should return julian=2299161
-!
-! Find the Julian Day number for day 288 during 1582 AD.
-! When the input is day number of the year, one should specify month=1
-! ioptn = 3
-! call calndr (ioptn, 288, 1, 1582, julian)
-! calndr() should return dayct=2299161
-!
-! Find the date for Julian Day number 2299161.
-! ioptn = 4
-! call calndr (ioptn, iday, month, iyear, 2299161)
-! calndr() should return iday=15, month=10, and iyear=1582
-!
-! Find the day number during the year (iday) and year
-! for Julian Day number 2299161.
-! ioptn = 5
-! call calndr (ioptn, iday, month, iyear, 2299161)
-! calndr() should return iday=288, month=1, iyear=1582
-!
-! Given 15 October 1582 under the Gregorian calendar,
-! find the date (idayJ,imonthJ,iyearJ) under the Julian calendar.
-! To do this, we call calndr() twice, using the Julian Day number
-! as the intermediate value.
-! call calndr ( 3, 15, 10, 1582, julian)
-! call calndr (-4, idayJ, monthJ, iyearJ, julian)
-! The first call to calndr() should return julian=2299161, and
-! the second should return idayJ=5, monthJ=10, iyearJ=1582
-!
-!----------
-!
-! BASIC CALENDAR INFORMATION
-!
-! The Julian calendar was instituted by Julius Caesar in 45 BC.
-! Every fourth year is a leap year in which February has 29 days.
-! That is, the Julian calendar assumes that the year is exactly
-! 365.25 days long. Actually, the year is not quite this long.
-! The modern Gregorian calendar remedies this by omitting leap years
-! in years divisible by 100 except when the year is divisible by 400.
-! Thus, 1700, 1800, and 1900 are leap years under the Julian calendar
-! but not under the Gregorian calendar. The years 1600 and 2000 are
-! leap years under both the Julian and the Gregorian calendars.
-! Other years divisible by 4 are leap years under both calendars,
-! such as 1992, 1996, 2004, 2008, 2012, etc. For BC years, we recall
-! that year 0 was omitted, so 1 BC, 5 BC, 9 BC, 13 BC, etc., and 401 BC,
-! 801 BC, 1201 BC, etc., are leap years under both calendars, while
-! 101 BC, 201 BC, 301 BC, 501 BC, 601 BC, 701 BC, 901 BC, 1001 BC,
-! 1101 BC, etc., are leap years under the Julian calendar but not
-! the Gregorian calendar.
-!
-! The Gregorian calendar is named after Pope Gregory XIII. He declared
-! that the last day of the old Julian calendar would be Thursday,
-! 4 October 1582 and that the following day, Friday, would be reckoned
-! under the new calendar as 15 October 1582. The jump of 10 days was
-! included to make 21 March closer to the spring equinox.
-!
-! Only a few Catholic countries (Italy, Poland, Portugal, and Spain)
-! switched to the Gregorian calendar on the day after 4 October 1582.
-! It took other countries months to centuries to change to the
-! Gregorian calendar. For example, England's first day under the
-! Gregorian calendar was 14 September 1752. The same date applied to
-! the entire British empire, including America. Japan, Russia, and many
-! eastern European countries did not change to the Gregorian calendar
-! until the 20th century. The last country to change was Turkey,
-! which began using the Gregorian calendar on 1 January 1927.
-!
-! Therefore, between the years 1582 and 1926 AD, you must know
-! the country in which an event was dated to interpret the date
-! correctly. In Sweden, there was even a year (1712) when February
-! had 30 days. Consult a book on calendars for more details
-! about when various countries changed their calendars.
-!
-! DAY NUMBER DURING THE YEAR
-! The day number during the year is simply a counter equal to 1 on
-! 1 January, 32 on 1 February, etc., thorugh 365 or 366 on 31 December,
-! depending on whether the year is a leap year. Sometimes this is
-! called the Julian Day, but that term is better reserved for the
-! day counter explained below.
-!
-! JULIAN DAY NUMBER
-! The Julian Day numbering system was designed by Joseph Scaliger
-! in 1582 to remove ambiguity caused by varying calendar systems.
-! The name "Julian Day" was chosen to honor Scaliger's father,
-! Julius Caesar Scaliger (1484-1558), an Italian scholar and physician
-! who lived in France. Because Julian Day numbering was especially
-! designed for astronomers, Julian Days begin at noon so that the day
-! counter does not change in the middle of an astronmer's observing
-! period. Julian Day 0 began at noon on 1 January 4713 BC under the
-! Julian calendar. A modern reference point is that 23 May 1968
-! (Gregorian calendar) was Julian Day 2,440,000.
-!
-! JULIAN DAY NUMBER EXAMPLES
-!
-! The table below shows a few Julian Day numbers and their corresponding
-! dates, depending on which calendar is used. A negative 'iyear' refers
-! to BC (Before Christ).
-!
-! Julian Day under calendar:
-! iday month iyear Gregorian Julian
-! 24 11 -4714 0 -38
-! 1 1 -4713 38 0
-! 1 1 1 1721426 1721424
-! 4 10 1582 2299150 2299160
-! 15 10 1582 2299161 2299171
-! 1 3 1600 2305508 2305518
-! 23 5 1968 2440000 2440013
-! 5 7 1998 2451000 2451013
-! 1 3 2000 2451605 2451618
-! 1 1 2001 2451911 2451924
-!
-! From this table, we can see that the 10 day difference between the
-! two calendars in 1582 grew to 13 days by 1 March 1900, since 1900 was
-! a leap year under the Julian calendar but not under the Gregorian
-! calendar. The gap will widen to 14 days after 1 March 2100 for the
-! same reason.
-!
-!----------
-!
-! PORTABILITY
-!
-! This subroutine is written in standard FORTRAN 90.
-! It calls no external functions or subroutines and should run
-! without problem on any computer having a 32-bit word or longer.
-!
-!----------
-!
-! ALGORITHM
-!
-! The goal in coding calndr() was clear, clean code, not efficiency.
-! Calendar calculations usually take a trivial fraction of the time
-! in any program in which dates conversions are involved.
-! Data analysis usually takes the most time.
-!
-! Standard algorithms are followed in this subroutine. Internal to
-! this subroutine, we use a year counter "jyear" such that
-! jyear=iyear when iyear is positive
-! =iyear+1 when iyear is negative.
-! Thus, jyear does not experience a 1 year jump like iyear does
-! when going from BC to AD. Specifically, jyear=0 when iyear=-1,
-! i.e., when the year is 1 BC.
-!
-! For simplicity in dealing with February, inside this subroutine,
-! we let the year begin on 1 March so that the adjustable month,
-! February is the last month of the year.
-! It is clear that the calendar used to work this way because the
-! months September, October, November, and December refer to
-! 7, 8, 9, and 10. For consistency, jyear is incremented on 1 March
-! rather than on 1 January. Of course, everything is adjusted back to
-! standard practice of years beginning on 1 January before answers
-! are returned to the routine that calls calndr().
-!
-! Lastly, we use a trick to calculate the number of days from 1 March
-! until the end of the month that precedes the specified month.
-! That number of days is int(30.6001*(month+1))-122,
-! where 30.6001 is used to avoid the possibility of round-off and
-! truncation error. For example, if 30.6 were used instead,
-! 30.6*5 should be 153, but round-off error could make it 152.99999,
-! which would then truncated to 152, causing an error of 1 day.
-!
-! Algorithm reference:
-! Dershowitz, Nachum and Edward M. Reingold, 1990: Calendrical
-! Calculations. Software-Practice and Experience, vol. 20, number 9
-! (September 1990), pp. 899-928.
-!
-! Copyright (C) 1999 Jon Ahlquist.
-! Issued under the second GNU General Public License.
-! See www.gnu.org for details.
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-! If you find any errors, please notify:
-! Jon Ahlquist <ahlquist at met.fsu.edu>
-! Dept of Meteorology
-! Florida State University
-! Tallahassee, FL 32306-4520
-! 15 March 1999.
-!
-!-----
-
-! converted to Fortran90 by Dimitri Komatitsch,
-! University of Pau, France, January 2008.
-
-! Declare internal variables.
- integer jdref, jmonth, jyear, leap, n1yr, n4yr, n100yr, n400yr, ndays, ndy400, ndy100, nyrs, yr400, yrref
-!
-! Explanation of all internal variables.
-! jdref Julian Day on which 1 March begins in the reference year.
-! jmonth Month counter which equals month+1 if month .gt. 2
-! or month+13 if month .le. 2.
-! jyear Year index, jyear=iyear if iyear .gt. 0, jyear=iyear+1
-! if iyear .lt. 0. Thus, jyear does not skip year 0
-! like iyear does between BC and AD years.
-! leap =1 if the year is a leap year, =0 if not.
-! n1yr Number of complete individual years between iyear and
-! the reference year after all 4, 100,
-! and 400 year periods have been removed.
-! n4yr Number of complete 4 year cycles between iyear and
-! the reference year after all 100 and 400 year periods
-! have been removed.
-! n100yr Number of complete 100 year periods between iyear and
-! the reference year after all 400 year periods
-! have been removed.
-! n400yr Number of complete 400 year periods between iyear and
-! the reference year.
-! ndays Number of days since 1 March during iyear. (In intermediate
-! steps, it holds other day counts as well.)
-! ndy400 Number of days in 400 years. Under the Gregorian calendar,
-! this is 400*365 + 100 - 3 = 146097. Under the Julian
-! calendar, this is 400*365 + 100 = 146100.
-! ndy100 Number of days in 100 years, Under the Gregorian calendar,
-! this is 100*365 + 24 = 36524. Under the Julian calendar,
-! this is 100*365 + 25 = 36525.
-! nyrs Number of years from the beginning of yr400
-! to the beginning of jyear. (Used for option +/-3).
-! yr400 The largest multiple of 400 years that is .le. jyear.
-!
-!
-!----------------------------------------------------------------
-! Do preparation work.
-!
-! Look for out-of-range option values.
- if ((ioptn == 0) .or. (abs(ioptn) >= 6)) then
- write(*,*)'For calndr(), you specified ioptn = ', ioptn
- write(*,*) 'Allowable values are 1 to 5 for the Gregorian calendar'
- write(*,*) 'and -1 to -5 for the Julian calendar.'
- stop
- endif
-!
-! Options 1-3 have "iyear" as an input value.
-! Internally, we use variable "jyear" that does not have a jump
-! from -1 (for 1 BC) to +1 (for 1 AD).
- if (abs(ioptn) <= 3) then
- if (iyear > 0) then
- jyear = iyear
- elseif (iyear == 0) then
- write(*,*) 'For calndr(), you specified the nonexistent year 0'
- stop
- else
- jyear = iyear + 1
- endif
-!
-! Set "leap" equal to 0 if "jyear" is not a leap year
-! and equal to 1 if it is a leap year.
- leap = 0
- if ((jyear/4)*4 == jyear) then
- leap = 1
- endif
- if ((ioptn > 0) .and. &
- ((jyear/100)*100 == jyear) .and. &
- ((jyear/400)*400 /= jyear) ) then
- leap = 0
- endif
- endif
-!
-! Options 3-5 involve Julian Day numbers, which need a reference year
-! and the Julian Days that began at noon on 1 March of the reference
-! year under the Gregorian and Julian calendars. Any year for which
-! "jyear" is divisible by 400 can be used as a reference year.
-! We chose 1600 AD as the reference year because it is the closest
-! multiple of 400 to the institution of the Gregorian calendar, making
-! it relatively easy to compute the Julian Day for 1 March 1600
-! given that, on 15 October 1582 under the Gregorian calendar,
-! the Julian Day was 2299161. Similarly, we need to do the same
-! calculation for the Julian calendar. We can compute this Julian
-! Day knwoing that on 4 October 1582 under the Julian calendar,
-! the Julian Day number was 2299160. The details of these calculations
-! is next.
-! From 15 October until 1 March, the number of days is the remainder
-! of October plus the days in November, December, January, and February:
-! 17+30+31+31+28 = 137, so 1 March 1583 under the Gregorian calendar
-! was Julian Day 2,299,298. Because of the 10 day jump ahead at the
-! switch from the Julian calendar to the Gregorian calendar, 1 March
-! 1583 under the Julian calendar was Julian Day 2,299,308. Making use
-! of the rules for the two calendar systems, 1 March 1600 was Julian
-! Day 2,299,298 + (1600-1583)*365 + 5 (due to leap years) =
-! 2,305,508 under the Gregorian calendar and day 2,305,518 under the
-! Julian calendar.
-! We also set the number of days in 400 years and 100 years.
-! For reference, 400 years is 146097 days under the Gregorian calendar
-! and 146100 days under the Julian calendar. 100 years is 36524 days
-! under the Gregorian calendar and 36525 days under the Julian calendar.
- if (abs(ioptn) >= 3) then
-!
-! Julian calendar values.
- yrref = 1600
- jdref = 2305518
-! = Julian Day reference value for the day that begins
-! at noon on 1 March of the reference year "yrref".
- ndy400 = 400*365 + 100
- ndy100 = 100*365 + 25
-!
-! Adjust for Gregorian calendar values.
- if (ioptn > 0) then
- jdref = jdref - 10
- ndy400 = ndy400 - 3
- ndy100 = ndy100 - 1
- endif
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -1 and +1:
-! Given a calendar date (iday,month,iyear), compute the day number
-! of the year (idayct), where 1 January is day number 1 and 31 December
-! is day number 365 or 366, depending on whether it is a leap year.
- if (abs(ioptn) == 1) then
-!
-! Compute the day number during the year.
- if (month <= 2) then
- idayct = iday + (month-1)*31
- else
- idayct = iday + int(30.6001 * (month+1)) - 63 + leap
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -2 and +2:
-! Given the day number of the year (idayct) and the year (iyear),
-! compute the day of the month (iday) and the month (month).
- elseif (abs(ioptn) == 2) then
-!
- if (idayct < 60+leap) then
- month = (idayct-1)/31
- iday = idayct - month*31
- month = month + 1
- else
- ndays = idayct - (60+leap)
-! = number of days past 1 March of the current year.
- jmonth = (10*(ndays+31))/306 + 3
-! = month counter, =4 for March, =5 for April, etc.
- iday = (ndays+123) - int(30.6001*jmonth)
- month = jmonth - 1
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -3 and +3:
-! Given a calendar date (iday,month,iyear), compute the Julian Day
-! number (idayct) that starts at noon.
- elseif (abs(ioptn) == 3) then
-!
-! Shift to a system where the year starts on 1 March, so January
-! and February belong to the preceding year.
-! Define jmonth=4 for March, =5 for April, ..., =15 for February.
- if (month <= 2) then
- jyear = jyear - 1
- jmonth = month + 13
- else
- jmonth = month + 1
- endif
-!
-! Find the closest multiple of 400 years that is .le. jyear.
- yr400 = (jyear/400)*400
-! = multiple of 400 years at or less than jyear.
- if (jyear < yr400) then
- yr400 = yr400 - 400
- endif
-!
- n400yr = (yr400 - yrref)/400
-! = number of 400-year periods from yrref to yr400.
- nyrs = jyear - yr400
-! = number of years from the beginning of yr400
-! to the beginning of jyear.
-!
-! Compute the Julian Day number.
- idayct = iday + int(30.6001*jmonth) - 123 + 365*nyrs + nyrs/4 &
- + jdref + n400yr*ndy400
-!
-! If we are using the Gregorian calendar, we must not count
-! every 100-th year as a leap year. nyrs is less than 400 years,
-! so we do not need to consider the leap year that would occur if
-! nyrs were divisible by 400, i.e., we do not add nyrs/400.
- if (ioptn > 0) then
- idayct = idayct - nyrs/100
- endif
-!
-!----------------------------------------------------------------
-! OPTIONS -5, -4, +4, and +5:
-! Given the Julian Day number (idayct) that starts at noon,
-! compute the corresponding calendar date (iday,month,iyear)
-! (abs(ioptn)=4) or day number during the year (abs(ioptn)=5).
- else
-!
-! Create a new reference date which begins on the nearest
-! 400-year cycle less than or equal to the Julian Day for 1 March
-! in the year in which the given Julian Day number (idayct) occurs.
- ndays = idayct - jdref
- n400yr = ndays / ndy400
-! = integral number of 400-year periods separating
-! idayct and the reference date, jdref.
- jdref = jdref + n400yr*ndy400
- if (jdref > idayct) then
- n400yr = n400yr - 1
- jdref = jdref - ndy400
- endif
-!
- ndays = idayct - jdref
-! = number from the reference date to idayct.
-!
- n100yr = min(ndays/ndy100, 3)
-! = number of complete 100-year periods
-! from the reference year to the current year.
-! The min() function is necessary to avoid n100yr=4
-! on 29 February of the last year in the 400-year cycle.
-!
- ndays = ndays - n100yr*ndy100
-! = remainder after removing an integral number of
-! 100-year periods.
-!
- n4yr = ndays / 1461
-! = number of complete 4-year periods in the current century.
-! 4 years consists of 4*365 + 1 = 1461 days.
-!
- ndays = ndays - n4yr*1461
-! = remainder after removing an integral number
-! of 4-year periods.
-!
- n1yr = min(ndays/365, 3)
-! = number of complete years since the last leap year.
-! The min() function is necessary to avoid n1yr=4
-! when the date is 29 February on a leap year,
-! in which case ndays=1460, and 1460/365 = 4.
-!
- ndays = ndays - 365*n1yr
-! = number of days so far in the current year,
-! where ndays=0 on 1 March.
-!
- iyear = n1yr + 4*n4yr + 100*n100yr + 400*n400yr + yrref
-! = year, as counted in the standard way,
-! but relative to 1 March.
-!
-! At this point, we need to separate ioptn=abs(4), which seeks a
-! calendar date, and ioptn=abs(5), which seeks the day number during
-! the year. First compute the calendar date if desired (abs(ioptn)=4).
- if (abs(ioptn) == 4) then
- jmonth = (10*(ndays+31))/306 + 3
-! = offset month counter. jmonth=4 for March, =13 for
-! December, =14 for January, =15 for February.
- iday = (ndays+123) - int(30.6001*jmonth)
-! = day of the month, starting with 1 on the first day
-! of the month.
-!
-! Now adjust for the fact that the year actually begins
-! on 1 January.
- if (jmonth <= 13) then
- month = jmonth - 1
- else
- month = jmonth - 13
- iyear = iyear + 1
- endif
-!
-! This code handles abs(ioptn)=5, finding the day number during the year.
- else
-! ioptn=5 always returns month=1, which we set now.
- month = 1
-!
-! We need to determine whether this is a leap year.
- leap = 0
- if ((jyear/4)*4 == jyear) then
- leap = 1
- endif
- if ((ioptn > 0) .and. &
- ((jyear/100)*100 == jyear) .and. &
- ((jyear/400)*400 /= jyear) ) then
- leap = 0
- endif
-!
-! Now find the day number "iday".
-! ndays is the number of days since the most recent 1 March,
-! so ndays=0 on 1 March.
- if (ndays <=305) then
- iday = ndays + 60 + leap
- else
- iday = ndays - 305
- iyear = iyear + 1
- endif
- endif
-!
-! Adjust the year if it is .le. 0, and hence BC (Before Christ).
- if (iyear <= 0) then
- iyear = iyear - 1
- endif
-!
-! End the code for the last option, ioptn.
- endif
-
- end subroutine calndr
-
Deleted: seismo/2D/SPECFEM2D/trunk/check_quality_external_mesh.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/check_quality_external_mesh.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/check_quality_external_mesh.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,689 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! read an external 2D mesh file and display statistics about mesh quality;
-! and create an OpenDX file showing a given range of elements or a single element
-
-! Dimitri Komatitsch, University of Toulouse, France, January 2011.
-! (adapted from the version that is available in our 3D code, SPECFEM3D)
-
-!! DK DK
-!! DK DK this routine could be improved by computing the mean in addition to min and max of ratios
-!! DK DK
-
- program check_quality_external_mesh
-
- implicit none
-
- include "constants.h"
-
- integer, parameter :: NGNOD = 4 ! quadrangles
-
- integer :: NPOIN ! number of nodes
- integer :: NSPEC ! number of elements
-
- double precision, dimension(:), allocatable :: x,y,z
-
- integer, dimension(:,:), allocatable :: ibool
-
- integer :: i,ispec,iformat,ispec_min_edge_length,ispec_max_edge_length, &
- ispec_begin,ispec_end,ispec_to_output,ispec_equiangle_skewness_max
-
-! for quality of mesh
- double precision :: equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio
- double precision :: equiangle_skewness_min,edge_aspect_ratio_min,diagonal_aspect_ratio_min
- double precision :: equiangle_skewness_max,edge_aspect_ratio_max,diagonal_aspect_ratio_max
- double precision :: skewness_AVS_DX_min,skewness_AVS_DX_max,distance_min,distance_max
- double precision :: distmin,distmax
-
-! for histogram
- integer, parameter :: NCLASS = 20
- integer classes_skewness(0:NCLASS-1)
- integer :: iclass
- double precision :: current_percent,total_percent
-
-! to export elements that have a certain skewness range to OpenDX
- integer :: ntotspecAVS_DX
- logical :: USE_OPENDX
-
- character(len=100) interfacesfile,title
-
- ! flag to save the last frame for kernels calculation purpose and type of simulation
- logical :: SAVE_FORWARD
- integer :: SIMULATION_TYPE
-
- ! parameters for external mesh
- logical :: read_external_mesh
- character(len=256) :: mesh_file, nodes_coords_file
-
- ! ignore variable name field (junk) at the beginning of each input line
- !logical, parameter :: IGNORE_JUNK = .true.
-
- integer :: NPOIN_unique_needed
- integer, dimension(:), allocatable :: ibool_reduced
- logical, dimension(:), allocatable :: mask_ibool
-
- if(NGNOD /= 4) stop 'NGNOD must be 4'
-
- ! ***
- ! *** read the parameter file
- ! ***
-
- print *,'Reading the parameter file ... '
- print *
-
- open(unit=IIN,file='DATA/Par_file',status='old')
-
- ! read and ignore file names and path for output
- call read_value_string(IIN,IGNORE_JUNK,title)
- call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
-
- ! read and ignore type of simulation
- call read_value_integer(IIN,IGNORE_JUNK,SIMULATION_TYPE)
- call read_value_logical(IIN,IGNORE_JUNK,SAVE_FORWARD)
-
- ! read info about external mesh
- call read_value_logical(IIN,IGNORE_JUNK,read_external_mesh)
- if(.not. read_external_mesh) stop 'this program is designed for read_external_mesh = .true.'
- call read_value_string(IIN,IGNORE_JUNK,mesh_file)
- call read_value_string(IIN,IGNORE_JUNK,nodes_coords_file)
-
- print *
- print *,'1 = output elements above a certain skewness threshold in OpenDX format'
- print *,'2 = output a given element in OpenDX format'
- print *,'3 = do not output any OpenDX file'
- print *
- print *,'enter value:'
- read(5,*) iformat
-
- if(iformat < 1 .or. iformat > 3) stop 'exiting...'
-
- if(iformat == 1 .or. iformat == 2) then
- USE_OPENDX = .true.
- else
- USE_OPENDX = .false.
- endif
-
-! read the nodes
- print *
- print *,'start reading the external node file: ',nodes_coords_file(1:len_trim(nodes_coords_file))
- open(unit=10,file=nodes_coords_file,status='unknown',action='read')
-
-! read the header
- read(10,*) NPOIN
-
-! read the mesh
- print *,'start reading the external mesh file: ',mesh_file(1:len_trim(mesh_file))
- open(unit=11,file=mesh_file,status='unknown',action='read')
-
-! read the header
- read(11,*) NSPEC
-
- allocate(x(NPOIN))
- allocate(y(NPOIN))
- allocate(z(NPOIN))
-
- allocate(ibool(NGNOD,NSPEC))
-
- if(USE_OPENDX) then
-
- if(iformat == 1) then
-
-! read range of skewness used for elements
- print *
- print *,'enter minimum skewness for OpenDX (between 0. and 0.99):'
- read(5,*) skewness_AVS_DX_min
- if(skewness_AVS_DX_min < 0.d0) skewness_AVS_DX_min = 0.d0
- if(skewness_AVS_DX_min > 0.99999d0) skewness_AVS_DX_min = 0.99999d0
-
-!!!!!!!! print *,'enter maximum skewness for OpenDX (between 0. and 1.):'
-!!!!!!!!!!!!! read(5,*) skewness_AVS_DX_max
- skewness_AVS_DX_max = 0.99999d0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- if(skewness_AVS_DX_max < 0.d0) skewness_AVS_DX_max = 0.d0
- if(skewness_AVS_DX_max > 0.99999d0) skewness_AVS_DX_max = 0.99999d0
-
- if(skewness_AVS_DX_min > skewness_AVS_DX_max) stop 'incorrect skewness range'
-
- else
- print *,'enter the element number to output in OpenDX format between 1 and ',NSPEC
- read(5,*) ispec_to_output
- if(ispec_to_output < 1 .or. ispec_to_output > NSPEC) stop 'incorrect element number to output'
- endif
-
- endif
-
-! read the points
- print *,'NPOIN = ',NPOIN
- do i = 1,NPOIN
- read(10,*) x(i),y(i)
-! the 2D mesh is flat, therefore the third coordinate is zero
- z(i) = 0
- enddo
- close(10)
-
-! read the elements
- print *,'NSPEC = ',NSPEC
- do i = 1,NSPEC
- read(11,*) ibool(1,i),ibool(2,i),ibool(3,i),ibool(4,i)
- enddo
- close(11)
-
- print *,'done reading the external files'
- print *
-
- print *,'start computing the minimum and maximum edge size'
-
-! ************* compute min and max of skewness and ratios ******************
-
-! erase minimum and maximum of quality numbers
- equiangle_skewness_min = + HUGEVAL
- edge_aspect_ratio_min = + HUGEVAL
- diagonal_aspect_ratio_min = + HUGEVAL
- distance_min = + HUGEVAL
-
- equiangle_skewness_max = - HUGEVAL
- edge_aspect_ratio_max = - HUGEVAL
- diagonal_aspect_ratio_max = - HUGEVAL
- distance_max = - HUGEVAL
-
- ispec_min_edge_length = -1
- ispec_max_edge_length = -1
-
-! loop on all the elements
- do ispec = 1,NSPEC
-
- if(mod(ispec,100000) == 0) print *,'processed ',ispec,' elements out of ',NSPEC
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! store element number in which the edge of minimum or maximum length is located
- if(distmin < distance_min) ispec_min_edge_length = ispec
- if(distmax > distance_max) ispec_max_edge_length = ispec
-
-! compute minimum and maximum of quality numbers
- equiangle_skewness_min = min(equiangle_skewness_min,equiangle_skewness)
- edge_aspect_ratio_min = min(edge_aspect_ratio_min,edge_aspect_ratio)
- diagonal_aspect_ratio_min = min(diagonal_aspect_ratio_min,diagonal_aspect_ratio)
- distance_min = min(distance_min,distmin)
-
- if(equiangle_skewness > equiangle_skewness_max) ispec_equiangle_skewness_max = ispec
- equiangle_skewness_max = max(equiangle_skewness_max,equiangle_skewness)
- edge_aspect_ratio_max = max(edge_aspect_ratio_max,edge_aspect_ratio)
- diagonal_aspect_ratio_max = max(diagonal_aspect_ratio_max,diagonal_aspect_ratio)
- distance_max = max(distance_max,distmax)
-
- enddo
- print *,'done processing ',NSPEC,' elements out of ',NSPEC
-
- print *
- print *,'------------'
- print *,'mesh quality parameter definitions:'
- print *
- print *,'equiangle skewness: 0. perfect, 1. bad'
- print *,'skewness max deviation angle: 0. perfect, 90. bad'
- print *,'edge aspect ratio: 1. perfect, above 1. gives stretching factor'
- print *,'diagonal aspect ratio: 1. perfect, above 1. gives stretching factor'
- print *,'------------'
-
- print *
- print *,'minimum length of an edge in the whole mesh (m) = ',distance_min,' in element ',ispec_min_edge_length
- print *
- print *,'maximum length of an edge in the whole mesh (m) = ',distance_max,' in element ',ispec_max_edge_length
- print *
- print *,'max equiangle skewness = ',equiangle_skewness_max
- print *,'in element ',ispec_equiangle_skewness_max
-! print *,'min equiangle skewness = ',equiangle_skewness_min
- print *
- print *,'max deviation angle from a right angle (90 degrees) is therefore = ',90.*equiangle_skewness_max
- print *
- print *,'worst angle in the mesh is therefore either ',90.*(1. - equiangle_skewness_max)
- print *,'or ',180. - 90.*(1. - equiangle_skewness_max),' degrees'
- print *
- print *,'max edge aspect ratio = ',edge_aspect_ratio_max
-! print *,'min edge aspect ratio = ',edge_aspect_ratio_min
- print *
- print *,'max diagonal aspect ratio = ',diagonal_aspect_ratio_max
-! print *,'min diagonal aspect ratio = ',diagonal_aspect_ratio_min
- print *
-
-! create statistics about mesh quality
- print *,'creating histogram and statistics of mesh quality'
-
-! erase histogram of skewness
- classes_skewness(:) = 0
-
-! loop on all the elements
- do ispec = 1,NSPEC
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! store skewness in histogram
- iclass = int(equiangle_skewness * dble(NCLASS))
- if(iclass < 0) iclass = 0
- if(iclass > NCLASS-1) iclass = NCLASS-1
- classes_skewness(iclass) = classes_skewness(iclass) + 1
-
- enddo
-
-! create histogram of skewness and save in Gnuplot file
- print *
- print *,'histogram of skewness (0. good - 1. bad):'
- print *
- total_percent = 0.
- open(unit=14,file='mesh_quality_histogram.txt',status='unknown')
- do iclass = 0,NCLASS-1
- current_percent = 100.*dble(classes_skewness(iclass))/dble(NSPEC)
- total_percent = total_percent + current_percent
- print *,real(iclass/dble(NCLASS)),' - ',real((iclass+1)/dble(NCLASS)),classes_skewness(iclass),' ',sngl(current_percent),' %'
- write(14,*) 0.5*(real(iclass/dble(NCLASS)) + real((iclass+1)/dble(NCLASS))),' ',sngl(current_percent)
- enddo
- close(14)
-
-! create script for Gnuplot histogram file
- open(unit=14,file='plot_mesh_quality_histogram.gnu',status='unknown')
- write(14,*) 'set term x11'
- write(14,*) '#set term gif'
- write(14,*) '#set output "mesh_quality_histogram.gif"'
- write(14,*)
- write(14,*) 'set xrange [0:1]'
- write(14,*) 'set xtics 0,0.1,1'
- write(14,*) 'set boxwidth ',1./real(NCLASS)
- write(14,*) 'set xlabel "Skewness range"'
- write(14,*) 'set ylabel "Percentage of elements (%)"'
- write(14,*) 'plot "mesh_quality_histogram.txt" with boxes'
- write(14,*) 'pause -1 "hit any key..."'
- close(14)
-
- print *
- print *,'total number of elements = ',NSPEC
- print *
-
-! display warning if maximum skewness is too high
- if(equiangle_skewness_max >= 0.75d0) then
- print *
- print *,'*********************************************'
- print *,'*********************************************'
- print *,' WARNING, mesh is bad (max skewness >= 0.75)'
- print *,'*********************************************'
- print *,'*********************************************'
- print *
- endif
-
- if(total_percent < 99.9d0 .or. total_percent > 100.1d0) then
- print *,'total percentage = ',total_percent,' %'
- stop 'total percentage should be 100%'
- endif
-
-! ************* create OpenDX file with elements in a certain range of skewness
-
- if(USE_OPENDX) then
-
- print *
- if(iformat == 1) then
- print *,'creating OpenDX file with subset of elements in skewness range'
- print *,'between ',skewness_AVS_DX_min,' and ',skewness_AVS_DX_max
- else
- print *,'creating OpenDX file with element #',ispec_to_output
- endif
- print *
-
-! ************* count number of elements in skewness range *************
-
-! erase number of elements belonging to skewness range for AVS_DX
- ntotspecAVS_DX = 0
-
-! loop on all the elements
- if(iformat == 1) then
-
- do ispec = 1,NSPEC
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! check if element belongs to requested skewness range
- if(equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max) &
- ntotspecAVS_DX = ntotspecAVS_DX + 1
-
- enddo
-
- else
-! outputing a single element
- ntotspecAVS_DX = 1
- endif
-
- if(ntotspecAVS_DX == 0) then
- stop 'no elements in skewness range, no file created'
- else if(iformat == 1) then
- print *
- print *,'there are ',ntotspecAVS_DX,' elements in AVS or DX skewness range ',skewness_AVS_DX_min,skewness_AVS_DX_max
- print *
- endif
-
- open(unit=11,file='DX_mesh_quality.dx',status='unknown')
-
-! generate the subset of points that are needed
-
-! count the number of unique points
- NPOIN_unique_needed = 0
- allocate(mask_ibool(NPOIN))
- mask_ibool(:) = .false.
-
-! loop on all the elements
- if(iformat == 1) then
- ispec_begin = 1
- ispec_end = NSPEC
- else
- ispec_begin = ispec_to_output
- ispec_end = ispec_to_output
- endif
-
- do ispec = ispec_begin,ispec_end
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! check if element needs to be output
- if(iformat == 2 .or. (iformat == 1 .and. &
- equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
-! create point for first corner of the element
- if(.not. mask_ibool(ibool(1,ispec))) then
- mask_ibool(ibool(1,ispec)) = .true.
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for second corner of the element
- if(.not. mask_ibool(ibool(2,ispec))) then
- mask_ibool(ibool(2,ispec)) = .true.
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for third corner of the element
- if(.not. mask_ibool(ibool(3,ispec))) then
- mask_ibool(ibool(3,ispec)) = .true.
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for fourth corner of the element
- if(.not. mask_ibool(ibool(4,ispec))) then
- mask_ibool(ibool(4,ispec)) = .true.
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
- endif
-
- enddo
-
-
-! ************* generate points ******************
-
-! write OpenDX header
- write(11,*) 'object 1 class array type float rank 1 shape 3 items ',NPOIN_unique_needed,' data follows'
-
- allocate(ibool_reduced(NPOIN))
-
-! count the number of unique points
- NPOIN_unique_needed = 0
- mask_ibool(:) = .false.
-
-! loop on all the elements
- if(iformat == 1) then
- ispec_begin = 1
- ispec_end = NSPEC
- else
- ispec_begin = ispec_to_output
- ispec_end = ispec_to_output
- endif
-
- do ispec = ispec_begin,ispec_end
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! check if element needs to be output
- if(iformat == 2 .or. (iformat == 1 .and. &
- equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
-! create point for first corner of the element
- if(.not. mask_ibool(ibool(1,ispec))) then
- mask_ibool(ibool(1,ispec)) = .true.
- ibool_reduced(ibool(1,ispec)) = NPOIN_unique_needed
- write(11,*) sngl(x(ibool(1,ispec))),sngl(y(ibool(1,ispec))),sngl(z(ibool(1,ispec)))
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for second corner of the element
- if(.not. mask_ibool(ibool(2,ispec))) then
- mask_ibool(ibool(2,ispec)) = .true.
- ibool_reduced(ibool(2,ispec)) = NPOIN_unique_needed
- write(11,*) sngl(x(ibool(2,ispec))),sngl(y(ibool(2,ispec))),sngl(z(ibool(2,ispec)))
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for third corner of the element
- if(.not. mask_ibool(ibool(3,ispec))) then
- mask_ibool(ibool(3,ispec)) = .true.
- ibool_reduced(ibool(3,ispec)) = NPOIN_unique_needed
- write(11,*) sngl(x(ibool(3,ispec))),sngl(y(ibool(3,ispec))),sngl(z(ibool(3,ispec)))
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
-! create point for fourth corner of the element
- if(.not. mask_ibool(ibool(4,ispec))) then
- mask_ibool(ibool(4,ispec)) = .true.
- ibool_reduced(ibool(4,ispec)) = NPOIN_unique_needed
- write(11,*) sngl(x(ibool(4,ispec))),sngl(y(ibool(4,ispec))),sngl(z(ibool(4,ispec)))
- NPOIN_unique_needed = NPOIN_unique_needed + 1
- endif
-
- endif
-
- enddo
-
- deallocate(mask_ibool)
-
-! ************* generate elements ******************
-
- write(11,*) 'object 2 class array type int rank 1 shape ',NGNOD,' items ',ntotspecAVS_DX,' data follows'
-
-! loop on all the elements
- if(iformat == 1) then
- ispec_begin = 1
- ispec_end = NSPEC
- else
- ispec_begin = ispec_to_output
- ispec_end = ispec_to_output
- endif
-
- do ispec = ispec_begin,ispec_end
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! check if element needs to be output
- if(iformat == 2 .or. (iformat == 1 .and. &
- equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
-! point order in OpenDX in 2D is 1,4,2,3 *not* 1,2,3,4 as in AVS
-! point order in OpenDX in 3D is 4,1,8,5,3,2,7,6, *not* 1,2,3,4,5,6,7,8 as in AVS
-! in the case of OpenDX, node numbers start at zero
- write(11,"(i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9)") &
- ibool_reduced(ibool(1,ispec)), ibool_reduced(ibool(4,ispec)), &
- ibool_reduced(ibool(2,ispec)), ibool_reduced(ibool(3,ispec))
- if(iformat == 1) print *,'element ',ispec,' belongs to the range and has skewness = ',sngl(equiangle_skewness)
- endif
-
- enddo
-
-! ************* generate element data values ******************
-
-! output OpenDX header for data
- write(11,*) 'attribute "element type" string "quads"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
-
-! loop on all the elements
- do ispec = ispec_begin,ispec_end
-
- call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
-! check if element needs to be output
- if(iformat == 2 .or. (iformat == 1 .and. &
- equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) &
- write(11,*) sngl(equiangle_skewness)
-
- enddo
-
-! define OpenDX field
- write(11,*) 'attribute "dep" string "connections"'
- write(11,*) 'object "irregular positions irregular connections" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
-
-! close OpenDX file
- close(11)
-
- endif
-
- end program check_quality_external_mesh
-
-!
-!=====================================================================
-!
-
-! create mesh quality data for a given 2D spectral element
-
- subroutine create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
- equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
-
- implicit none
-
- include "constants.h"
-
- integer :: icorner,ispec,NSPEC,NPOIN,NGNOD,i
-
- double precision, dimension(NPOIN) :: x,y,z
-
- integer, dimension(NGNOD,NSPEC) :: ibool
-
- double precision, dimension(NGNOD) :: xelm,yelm,zelm
-
- double precision vectorA_x,vectorA_y,vectorA_z
- double precision vectorB_x,vectorB_y,vectorB_z
- double precision norm_A,norm_B,angle_vectors
- double precision distmin,distmax,dist,dist1,dist2
- double precision equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio
-
-! topology of faces of cube for skewness
-! only one face in 2D
- integer faces_topo(6)
-
-! store the corners of this element for the skewness routine
- do i = 1,NGNOD
- xelm(i) = x(ibool(i,ispec))
- yelm(i) = y(ibool(i,ispec))
- zelm(i) = z(ibool(i,ispec))
- enddo
-
-! define topology of faces of cube for skewness
-
-! only one face in 2D
- faces_topo(1) = 1
- faces_topo(2) = 2
- faces_topo(3) = 3
- faces_topo(4) = 4
-
-! define wraparound for angles for skewness calculation
- faces_topo(5) = faces_topo(1)
- faces_topo(6) = faces_topo(2)
-
-! compute equiangle skewness (as defined in Fluent/Gambit manual)
-! and compute edge aspect ratio using the corners of the element
- distmin = + HUGEVAL
- distmax = - HUGEVAL
- equiangle_skewness = - HUGEVAL
-
- do icorner = 1,4
-
-! first vector of angle
- vectorA_x = xelm(faces_topo(icorner)) - xelm(faces_topo(icorner+1))
- vectorA_y = yelm(faces_topo(icorner)) - yelm(faces_topo(icorner+1))
- vectorA_z = zelm(faces_topo(icorner)) - zelm(faces_topo(icorner+1))
-
-! second vector of angle
- vectorB_x = xelm(faces_topo(icorner+2)) - xelm(faces_topo(icorner+1))
- vectorB_y = yelm(faces_topo(icorner+2)) - yelm(faces_topo(icorner+1))
- vectorB_z = zelm(faces_topo(icorner+2)) - zelm(faces_topo(icorner+1))
-
-! norm of vectors A and B
- norm_A = sqrt(vectorA_x**2 + vectorA_y**2 + vectorA_z**2)
- norm_B = sqrt(vectorB_x**2 + vectorB_y**2 + vectorB_z**2)
-
-! angle formed by the two vectors
- angle_vectors = dacos((vectorA_x*vectorB_x + vectorA_y*vectorB_y + vectorA_z*vectorB_z) / (norm_A * norm_B))
-
-! compute equiangle skewness
- equiangle_skewness = max(equiangle_skewness,dabs(2.d0 * angle_vectors - PI) / PI)
-
-! compute min and max size of an edge
- dist = sqrt(vectorA_x**2 + vectorA_y**2 + vectorA_z**2)
-
- distmin = min(distmin,dist)
- distmax = max(distmax,dist)
-
- enddo
-
-! compute edge aspect ratio
- edge_aspect_ratio = distmax / distmin
-
-! compute diagonal aspect ratio
- dist1 = sqrt((xelm(1) - xelm(3))**2 + (yelm(1) - yelm(3))**2 + (zelm(1) - zelm(3))**2)
- dist2 = sqrt((xelm(2) - xelm(4))**2 + (yelm(2) - yelm(4))**2 + (zelm(2) - zelm(4))**2)
- diagonal_aspect_ratio = max(dist1,dist2) / min(dist1,dist2)
-
- end subroutine create_mesh_quality_data_2D
-
Deleted: seismo/2D/SPECFEM2D/trunk/check_stability.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/check_stability.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/check_stability.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,305 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine check_stability(myrank,time,it,NSTEP, &
- npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- any_elastic_glob,any_elastic,displ_elastic, &
- any_poroelastic_glob,any_poroelastic, &
- displs_poroelastic,displw_poroelastic, &
- any_acoustic_glob,any_acoustic,potential_acoustic, &
- year_start,month_start,time_start)
-
-! checks simulation stability and outputs timerun infos
-
- implicit none
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: myrank,it,NSTEP
-
- double precision :: time
-
- logical :: any_elastic_glob,any_elastic
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
-
- logical :: any_poroelastic_glob,any_poroelastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
-
- logical :: any_acoustic_glob,any_acoustic
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
-
- double precision :: time_start
- integer :: year_start,month_start
-
- ! local parameters
- double precision displnorm_all,displnorm_all_glob
- ! timer to count elapsed time
- double precision :: time_end
- integer :: year_end,month_end
- double precision :: tCPU,t_remain,t_total
- integer :: ihours,iminutes,iseconds,int_tCPU, &
- ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
- ihours_total,iminutes_total,iseconds_total,int_t_total
- ! to determine date and time at which the run will finish
- character(len=8) datein
- character(len=10) timein
- character(len=5) :: zone
- integer, dimension(8) :: time_values
- character(len=3), dimension(12) :: month_name
- character(len=3), dimension(0:6) :: weekday_name
- data month_name /'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/
- data weekday_name /'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'/
- integer :: year,mon,day,hr,minutes,timestamp,julian_day_number,day_of_week
- integer, external :: idaywk
-#ifdef USE_MPI
- integer :: ier
-#endif
-
- ! user output
- if (myrank == 0) then
- write(IOUT,*)
- if(time >= 1.d-3 .and. time < 1000.d0) then
- write(IOUT,"('Time step number ',i7,' t = ',f9.4,' s out of ',i7)") it,time,NSTEP
- else
- write(IOUT,"('Time step number ',i7,' t = ',1pe12.6,' s out of ',i7)") it,time,NSTEP
- endif
- write(IOUT,*) 'We have done ',sngl(100.d0*dble(it-1)/dble(NSTEP-1)),'% of the total'
- endif
-
-
- ! elastic wavefield
- if(any_elastic_glob) then
- if(any_elastic) then
- displnorm_all = maxval(sqrt(displ_elastic(1,:)**2 &
- + displ_elastic(2,:)**2 &
- + displ_elastic(3,:)**2))
- else
- displnorm_all = 0.d0
- endif
-
- displnorm_all_glob = displnorm_all
-#ifdef USE_MPI
- call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
-#endif
-
- if (myrank == 0) &
- write(IOUT,*) 'Max norm of vector field in solid (elastic) = ',displnorm_all_glob
-
- ! check stability of the code in solid, exit if unstable
- ! negative values can occur with some compilers when the unstable value is greater
- ! than the greatest possible floating-point number of the machine
- if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
- call exit_MPI('code became unstable and blew up in solid (elastic)')
-
- endif
-
- ! poroelastic wavefield
- if(any_poroelastic_glob) then
- if(any_poroelastic) then
- displnorm_all = maxval(sqrt(displs_poroelastic(1,:)**2 &
- + displs_poroelastic(2,:)**2))
- else
- displnorm_all = 0.d0
- endif
-
- displnorm_all_glob = displnorm_all
-#ifdef USE_MPI
- call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
-#endif
-
- if (myrank == 0) &
- write(IOUT,*) 'Max norm of vector field in solid (poroelastic) = ',displnorm_all_glob
-
- ! check stability of the code in solid, exit if unstable
- ! negative values can occur with some compilers when the unstable value is greater
- ! than the greatest possible floating-point number of the machine
- if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
- call exit_MPI('code became unstable and blew up in solid (poroelastic)')
-
- if(any_poroelastic) then
- displnorm_all = maxval(sqrt(displw_poroelastic(1,:)**2 &
- + displw_poroelastic(2,:)**2))
- else
- displnorm_all = 0.d0
- endif
-
- displnorm_all_glob = displnorm_all
-#ifdef USE_MPI
- call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
-#endif
-
- if (myrank == 0) &
- write(IOUT,*) 'Max norm of vector field in fluid (poroelastic) = ',displnorm_all_glob
-
- ! check stability of the code in solid, exit if unstable
- ! negative values can occur with some compilers when the unstable value is greater
- ! than the greatest possible floating-point number of the machine
- if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
- call exit_MPI('code became unstable and blew up in fluid (poroelastic)')
-
- endif
-
-
- ! acoustic wavefield
- if(any_acoustic_glob) then
- if(any_acoustic) then
- displnorm_all = maxval(abs(potential_acoustic(:)))
- else
- displnorm_all = 0.d0
- endif
-
- displnorm_all_glob = displnorm_all
-#ifdef USE_MPI
- call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
-#endif
-
- if (myrank == 0) &
- write(IOUT,*) 'Max absolute value of scalar field in fluid (acoustic) = ',displnorm_all_glob
-
- ! check stability of the code in fluid, exit if unstable
- ! negative values can occur with some compilers when the unstable value is greater
- ! than the greatest possible floating-point number of the machine
- if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
- call exit_MPI('code became unstable and blew up in fluid (acoustic)')
-
- endif
-
- ! count elapsed wall-clock time
- call date_and_time(datein,timein,zone,time_values)
- ! time_values(1): year
- ! time_values(2): month of the year
- ! time_values(3): day of the month
- ! time_values(5): hour of the day
- ! time_values(6): minutes of the hour
- ! time_values(7): seconds of the minute
- ! time_values(8): milliseconds of the second
- ! this fails if we cross the end of the month
- time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
- 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
- month_end = time_values(2)
- year_end = time_values(1)
-
- ! elapsed time since beginning of the simulation
- if (myrank == 0) then
- if(month_end == month_start .and. year_end == year_start) then
- tCPU = time_end - time_start
- int_tCPU = int(tCPU)
- ihours = int_tCPU / 3600
- iminutes = (int_tCPU - 3600*ihours) / 60
- iseconds = int_tCPU - 3600*ihours - 60*iminutes
- write(IOUT,*) 'Elapsed time in seconds = ',tCPU
- write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
- write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
-
- ! compute estimated remaining simulation time
- t_remain = (NSTEP - it) * (tCPU/dble(it))
- int_t_remain = int(t_remain)
- ihours_remain = int_t_remain / 3600
- iminutes_remain = (int_t_remain - 3600*ihours_remain) / 60
- iseconds_remain = int_t_remain - 3600*ihours_remain - 60*iminutes_remain
- write(IOUT,*) 'Time steps remaining = ',NSTEP - it
- write(IOUT,*) 'Estimated remaining time in seconds = ',t_remain
- write(IOUT,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- ihours_remain,iminutes_remain,iseconds_remain
-
- ! compute estimated total simulation time
- t_total = t_remain + tCPU
- int_t_total = int(t_total)
- ihours_total = int_t_total / 3600
- iminutes_total = (int_t_total - 3600*ihours_total) / 60
- iseconds_total = int_t_total - 3600*ihours_total - 60*iminutes_total
- write(IOUT,*) 'Estimated total run time in seconds = ',t_total
- write(IOUT,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- ihours_total,iminutes_total,iseconds_total
-
- if(it < NSTEP) then
- ! compute date and time at which the run should finish
- ! (useful for long runs); for simplicity only minutes
- ! are considered, seconds are ignored; in any case the prediction is not
- ! accurate down to seconds because of system and network fluctuations
- year = time_values(1)
- mon = time_values(2)
- day = time_values(3)
- hr = time_values(5)
- minutes = time_values(6)
-
- ! get timestamp in minutes of current date and time
- call convtime(timestamp,year,mon,day,hr,minutes)
-
- ! add remaining minutes
- timestamp = timestamp + nint(t_remain / 60.d0)
-
- ! get date and time of that future timestamp in minutes
- call invtime(timestamp,year,mon,day,hr,minutes)
-
- ! convert to Julian day to get day of the week
- call calndr(day,mon,year,julian_day_number)
- day_of_week = idaywk(julian_day_number)
-
- write(IOUT,"(' The run will finish approximately on: ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
- weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
-
- endif
- write(IOUT,*)
- else
- write(IOUT,*) 'The calendar has crossed the end of the month during the simulation,'
- write(IOUT,*) 'cannot produce accurate CPU time estimates any more.'
- write(IOUT,*)
- endif
- endif
-
- if (myrank == 0) write(IOUT,*)
-
- end subroutine check_stability
-
Deleted: seismo/2D/SPECFEM2D/trunk/checkgrid.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/checkgrid.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/checkgrid.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,3102 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine checkgrid(vpext,vsext,rhoext,density,poroelastcoef, &
- porosity,tortuosity,permeability,ibool,kmato, &
- coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
- assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat, &
- f0,initialfield,time_function_type, &
- coorg,xinterp,zinterp,shapeint,knods,simulation_title, &
- npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,all_anisotropic, &
- myrank,nproc,NSOURCES,poroelastic, &
- freq0,Q0,TURN_VISCATTENUATION_ON)
-
-! check the mesh, stability and number of points per wavelength
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include 'mpif.h'
-#endif
-
-! option to display only part of the mesh and not the whole mesh,
-! for instance to analyze Cuthill-McKee mesh partitioning etc.
- integer :: UPPER_LIMIT_DISPLAY
-
- integer :: npoin,nspec,numat
- integer, dimension(nspec) :: kmato
- logical, dimension(nspec) :: poroelastic
- integer, dimension(NGLLX,NGLLX,nspec) :: ibool
-
- double precision, dimension(2,numat) :: density
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(3,numat) :: permeability
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
-
- double precision coord(NDIM,npoin)
-
- integer :: NSOURCES
- integer, dimension(NSOURCES) :: time_function_type
- double precision, dimension(NSOURCES) :: f0
-
- integer :: pointsdisp,npgeo,ngnod
-
- integer :: knods(ngnod,nspec)
-
- double precision :: xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
- double precision :: shapeint(ngnod,pointsdisp,pointsdisp)
-
- double precision :: coorg(NDIM,npgeo)
-
-! title of the plot
- character(len=60) :: simulation_title
-
- double precision :: vpImin,vpImax
- double precision :: vpIImin,vpIImax
- double precision :: deltat
-
- logical :: assign_external_model,initialfield,any_elastic,any_poroelastic,all_anisotropic, &
- TURN_VISCATTENUATION_ON
-
- integer :: myrank,nproc
-
- ! local parameters
- double precision vpIImax_local,vpIImin_local
- double precision vsmin,vsmax,densmin,densmax,vpImax_local,vpImin_local,vsmin_local
- double precision kappa_s,kappa_f,kappa_fr,mu_s,mu_fr,denst_s,denst_f,denst,phi,tort,cpIloc,cpIIloc,csloc
- double precision D_biot,H_biot,C_biot,M_biot,cpIsquare,cpIIsquare,cssquare
- double precision f0min,f0max,freq0,Q0,w_c,eta_f,perm
- double precision lambdaplus2mu,mu
- double precision distance_min,distance_max,distance_min_local,distance_max_local
- double precision courant_stability_number_max,lambdaPImin,lambdaPImax,lambdaPIImin,lambdaPIImax, &
- lambdaSmin,lambdaSmax
- double precision distance_1,distance_2,distance_3,distance_4
-
-! for the stability condition
-! maximum polynomial degree for which we can compute the stability condition
- integer, parameter :: NGLLX_MAX_STABILITY = 15
- double precision :: percent_GLL(NGLLX_MAX_STABILITY)
-
-! color palette
- integer, parameter :: NUM_COLORS = 236
- double precision, dimension(NUM_COLORS) :: red,green,blue
-
- double precision :: xmax,zmax,height,usoffset,sizex,sizez,courant_stability_number
- double precision :: x1,z1,x2,z2,ratio_page,xmin,zmin,lambdaS_local,lambdaPI_local
-
-#ifdef USE_MPI
- integer :: icol
- double precision :: vpImin_glob,vpImax_glob,vsmin_glob,vsmax_glob,densmin_glob,densmax_glob
- double precision :: vpIImin_glob,vpIImax_glob
- double precision :: distance_min_glob,distance_max_glob
- double precision :: courant_stability_max_glob,lambdaPImin_glob,lambdaPImax_glob,&
- lambdaPIImin_glob,lambdaPIImax_glob,lambdaSmin_glob,lambdaSmax_glob
- double precision :: xmin_glob, xmax_glob, zmin_glob, zmax_glob
-#endif
-
- logical :: any_elastic_glob,any_poroelastic_glob
- double precision, dimension(2,nspec*5) :: coorg_send
- double precision, dimension(:,:), allocatable :: coorg_recv
- integer, dimension(nspec) :: RGB_send
- integer, dimension(:), allocatable :: RGB_recv
- real, dimension(nspec) :: greyscale_send
- real, dimension(:), allocatable :: greyscale_recv
- integer :: nspec_recv
- integer :: num_ispec
- integer :: iproc
- integer :: ier
- integer :: i,j,ispec,material
- integer :: is,ir,in,nnum
-
-#ifdef USE_MPI
- integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
-#endif
-
- ! check
- if(UPPER_LIMIT_DISPLAY > nspec) &
- call exit_MPI('cannot have UPPER_LIMIT_DISPLAY > nspec in checkgrid.F90')
-
-#ifndef USE_MPI
- allocate(coorg_recv(1,1))
- allocate(RGB_recv(1))
- allocate(greyscale_recv(1))
- nspec_recv = 0
- ier = 0
- iproc = nproc
- deallocate(coorg_recv)
- deallocate(RGB_recv)
- deallocate(greyscale_recv)
-#endif
-
-
-! define percentage of smallest distance between GLL points for NGLLX points
-! percentages were computed by calling the GLL points routine for each degree
- call checkgrid_setup_GLLper(percent_GLL,NGLLX_MAX_STABILITY)
-
-! define color palette in random order
- call checkgrid_setup_colorp(red,green,blue,NUM_COLORS)
-
-!---- compute parameters for the spectral elements
-
- vpImin = HUGEVAL
- vpImax = -HUGEVAL
-
- if(any_elastic .or. any_poroelastic) then
- vsmin = HUGEVAL
- vsmax = -HUGEVAL
- else
- vsmin = 0
- vsmax = 0
- endif
-
- if(any_poroelastic) then
- vpIImin = HUGEVAL
- vpIImax = -HUGEVAL
- else
- vpIImin = 0
- vpIImax = 0
- endif
-
- densmin = HUGEVAL
- densmax = -HUGEVAL
-
- distance_min = HUGEVAL
- distance_max = -HUGEVAL
-
- courant_stability_number_max = -HUGEVAL
-
- lambdaPImin = HUGEVAL
- lambdaPImax = -HUGEVAL
-
- if(any_elastic .or. any_poroelastic) then
- lambdaSmin = HUGEVAL
- lambdaSmax = -HUGEVAL
- else
- lambdaSmin = 0
- lambdaSmax = 0
- endif
-
- if(any_poroelastic) then
- lambdaPIImin = HUGEVAL
- lambdaPIImax = -HUGEVAL
- else
- lambdaPIImin = 0
- lambdaPIImax = 0
- endif
-
- do ispec=1,nspec
-
- material = kmato(ispec)
-
- if(poroelastic(ispec)) then
-
- ! poroelastic material
-
- phi = porosity(material)
- tort = tortuosity(material)
- perm = permeability(1,material)
- ! solid properties
- mu_s = poroelastcoef(2,1,material)
- kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
- denst_s = density(1,material)
- denst = denst_s
- ! fluid properties
- kappa_f = poroelastcoef(1,2,material)
- denst_f = density(2,material)
- eta_f = poroelastcoef(2,2,material)
- ! frame properties
- mu_fr = poroelastcoef(2,3,material)
- kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
- ! Biot coefficients for the input phi
- D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
- H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
- C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
- M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
- tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIloc = sqrt(cpIsquare)
- cpIIloc = sqrt(cpIIsquare)
- csloc = sqrt(cssquare)
- else
- mu = poroelastcoef(2,1,material)
- lambdaplus2mu = poroelastcoef(3,1,material)
- denst = density(1,material)
-
- cpIloc = sqrt(lambdaplus2mu/denst)
- cpIIloc = 0.d0
- csloc = sqrt(mu/denst)
- endif
-
- vpImax_local = -HUGEVAL
- vpImin_local = HUGEVAL
- vpIImax_local = -HUGEVAL
- vpIImin_local = HUGEVAL
- vsmin_local = HUGEVAL
-
- distance_min_local = HUGEVAL
- distance_max_local = -HUGEVAL
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
-!--- if heterogeneous formulation with external velocity model
- if(assign_external_model) then
- cpIloc = vpext(i,j,ispec)
- csloc = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- endif
-
-!--- compute min and max of velocity and density models
- vpImin = min(vpImin,cpIloc)
- vpImax = max(vpImax,cpIloc)
-
-! ignore acoustic and elastic regions with cpII = 0
- if(cpIIloc > 0.0001d0) vpIImin = min(vpIImin,cpIIloc)
- vpIImax = max(vpIImax,cpIIloc)
-
-! ignore fluid regions with Vs = 0
- if(csloc > 0.0001d0) vsmin = min(vsmin,csloc)
- vsmax = max(vsmax,csloc)
-
- densmin = min(densmin,denst)
- densmax = max(densmax,denst)
-
- vpImax_local = max(vpImax_local,vpImax)
- vpImin_local = min(vpImin_local,vpImin)
- vpIImax_local = max(vpIImax_local,vpIImax)
- vpIImin_local = min(vpIImin_local,vpIImin)
- vsmin_local = min(vsmin_local,vsmin)
-
- enddo
- enddo
-
-! compute minimum and maximum size of edges of this grid cell
- distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
- (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
-
- distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
-
- distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
-
- distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
- (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
-
- distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
- distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
-
- distance_min = min(distance_min,distance_min_local)
- distance_max = max(distance_max,distance_max_local)
-
- courant_stability_number_max = max(courant_stability_number_max, &
- vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX)))
-
-! ignore fluid regions with Vs = 0
- if(csloc > 0.0001d0) then
- lambdaSmin = min(lambdaSmin,vsmin_local / (distance_max_local / (NGLLX - 1)))
- lambdaSmax = max(lambdaSmax,vsmin_local / (distance_max_local / (NGLLX - 1)))
- endif
-
- lambdaPImin = min(lambdaPImin,vpImin_local / (distance_max_local / (NGLLX - 1)))
- lambdaPImax = max(lambdaPImax,vpImin_local / (distance_max_local / (NGLLX - 1)))
-
- if(cpIIloc > 0.0001d0) then
- lambdaPIImin = min(lambdaPIImin,vpIImin_local / (distance_max_local / (NGLLX - 1)))
- lambdaPIImax = max(lambdaPIImax,vpIImin_local / (distance_max_local / (NGLLX - 1)))
- endif
-
- enddo
-
- any_elastic_glob = any_elastic
- any_poroelastic_glob = any_poroelastic
-#ifdef USE_MPI
- call MPI_ALLREDUCE (vpImin, vpImin_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (vpImax, vpImax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (vpIImin, vpIImin_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (vpIImax, vpIImax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (vsmin, vsmin_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (vsmax, vsmax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (densmin, densmin_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (densmax, densmax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (distance_min, distance_min_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (distance_max, distance_max_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (courant_stability_number_max, courant_stability_max_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPImin, lambdaPImin_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPImax, lambdaPImax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPIImin, lambdaPIImin_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPIImax, lambdaPIImax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaSmin, lambdaSmin_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaSmax, lambdaSmax_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (any_elastic, any_elastic_glob, 1, MPI_LOGICAL, &
- MPI_LOR, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, &
- MPI_LOR, MPI_COMM_WORLD, ier)
- vpImin = vpImin_glob
- vpImax = vpImax_glob
- vpIImin = vpIImin_glob
- vpIImax = vpIImax_glob
- vsmin = vsmin_glob
- vsmax = vsmax_glob
- densmin = densmin_glob
- densmax = densmax_glob
- distance_min = distance_min_glob
- distance_max = distance_max_glob
- courant_stability_number_max = courant_stability_max_glob
- lambdaPImin = lambdaPImin_glob
- lambdaPImax = lambdaPImax_glob
- lambdaPIImin = lambdaPIImin_glob
- lambdaPIImax = lambdaPIImax_glob
- lambdaSmin = lambdaSmin_glob
- lambdaSmax = lambdaSmax_glob
-
-#endif
-
- if ( myrank == 0 ) then
- if(.not. all_anisotropic) then
- write(IOUT,*)
- write(IOUT,*) '********'
- write(IOUT,*) 'Model: P (or PI) velocity min,max = ',vpImin,vpImax
- write(IOUT,*) 'Model: PII velocity min,max = ',vpIImin,vpIImax
- write(IOUT,*) 'Model: S velocity min,max = ',vsmin,vsmax
- write(IOUT,*) 'Model: density min,max = ',densmin,densmax
- write(IOUT,*) '********'
- write(IOUT,*)
-
- write(IOUT,*)
- write(IOUT,*) '*********************************************'
- write(IOUT,*) '*** Verification of simulation parameters ***'
- write(IOUT,*) '*********************************************'
- write(IOUT,*)
- write(IOUT,*) '*** Max grid size = ',distance_max
- write(IOUT,*) '*** Min grid size = ',distance_min
- write(IOUT,*) '*** Max/min ratio = ',distance_max/distance_min
- write(IOUT,*)
- write(IOUT,*) '*** Max stability for P wave velocity = ',courant_stability_number_max
- write(IOUT,*)
- end if
-
-! only if time source is not a Dirac or Heaviside (otherwise maximum frequency of spectrum undefined)
-! and if source is not an initial field, for the same reason
- if(.not. initialfield) then
- f0max = -HUGEVAL
- f0min = HUGEVAL
-! write(IOUT,*) ' USER_T0 = ',USER_T0
-
- do i = 1,NSOURCES
-
- ! excludes Dirac and Heaviside sources
- if(time_function_type(i) /= 4 .and. time_function_type(i) /= 5) then
-! write(IOUT,*) ' Onset time = ',t0+tshift_src(i)
-! write(IOUT,*) ' Fundamental period = ',1.d0/f0(i)
-! write(IOUT,*) ' Fundamental frequency = ',f0(i)
-! ! checks source onset time
-! if( t0+tshift_src(i) <= 1.d0/f0(i)) then
-! call exit_MPI('Onset time too small')
-! else
-! write(IOUT,*) ' --> onset time ok'
-! endif
-
- ! sets min/max frequency
- if(f0(i) > f0max) f0max = f0(i)
- if(f0(i) < f0min) f0min = f0(i)
-
- if( i == NSOURCES ) then
- write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambdaPImin_fmax max = ',lambdaPImax/(2.5d0*f0min)
- write(IOUT,*) ' Nb pts / lambdaPImin_fmax min = ',lambdaPImin/(2.5d0*f0max)
- write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambdaPIImin_fmax max = ',lambdaPIImax/(2.5d0*f0min)
- write(IOUT,*) ' Nb pts / lambdaPIImin_fmax min = ',lambdaPIImin/(2.5d0*f0max)
- write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambdaSmin_fmax max = ',lambdaSmax/(2.5d0*f0min)
- write(IOUT,*) ' Nb pts / lambdaSmin_fmax min = ',lambdaSmin/(2.5d0*f0max)
- write(IOUT,*) '----'
- endif
-
- endif
- enddo
- endif
- endif
-
-!
-!--------------------------------------------------------------------------------
-!
-
-! A4 or US letter paper
- if(US_LETTER) then
- usoffset = 1.75d0
- sizex = 27.94d0
- sizez = 21.59d0
- else
- usoffset = 0.d0
- sizex = 29.7d0
- sizez = 21.d0
- endif
-
-! height of domain numbers in centimeters
- height = 0.25d0
-
-! get minimum and maximum values of mesh coordinates
- xmin = minval(coord(1,:))
- zmin = minval(coord(2,:))
- xmax = maxval(coord(1,:))
- zmax = maxval(coord(2,:))
-
-#ifdef USE_MPI
- call MPI_ALLREDUCE (xmin, xmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (xmax, xmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (zmin, zmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (zmax, zmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- xmin = xmin_glob
- xmax = xmax_glob
- zmin = zmin_glob
- zmax = zmax_glob
-
-#endif
-
-! ratio of physical page size/size of the domain meshed
- ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
-
-
- if (myrank == 0) then
-
- write(IOUT,*)
- write(IOUT,*) 'Creating PostScript file with stability condition'
-
-!
-!---- open PostScript file
-!
- open(unit=24,file='OUTPUT_FILES/mesh_stability.ps',status='unknown')
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- write(24,*) '%'
- write(24,*) '/vshift ',-height/2,' CM def'
- write(24,*) '/Rshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop neg vshift MR show } def'
- write(24,*) '/Cshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
- write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
- !
- !--- write captions of PostScript figure
- !
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- write(24,*) '.4 .9 .9 setrgbcolor'
- write(24,*) '11 CM 1.1 CM MV'
- write(24,*) '(X axis) show'
- write(24,*) '%'
- write(24,*) '1.4 CM 9.5 CM MV'
- write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
- write(24,*) '(Z axis) show'
- write(24,*) 'grestore'
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.7 CM scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- write(24,*) '24.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(Mesh stability condition \(red = bad\)) show'
- write(24,*) 'grestore'
- write(24,*) '25.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
- !
- !---- draw the spectral element mesh
- !
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- num_ispec = 0
- endif
-
- do ispec = 1, nspec
- if ( myrank == 0 ) then
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- endif
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- if ( myrank == 0 ) then
- write(24,*) 'mark'
- write(24,681) x1,z1
- else
- coorg_send(1,(ispec-1)*5+1) = x1
- coorg_send(2,(ispec-1)*5+1) = z1
- endif
-
- ! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+2) = x2
- coorg_send(2,(ispec-1)*5+2) = z2
- endif
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+3) = x2
- coorg_send(2,(ispec-1)*5+3) = z2
- endif
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+4) = x2
- coorg_send(2,(ispec-1)*5+4) = z2
- endif
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- write(24,*) 'CO'
- else
- coorg_send(1,(ispec-1)*5+5) = x2
- coorg_send(2,(ispec-1)*5+5) = z2
- endif
-
- material = kmato(ispec)
-
- if(poroelastic(ispec)) then
-
- ! poroelastic material
-
- phi=porosity(material)
- tort=tortuosity(material)
- perm=permeability(1,material)
- ! solid properties
- mu_s = poroelastcoef(2,1,material)
- kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
- denst_s = density(1,material)
- denst = denst_s
- ! fluid properties
- kappa_f = poroelastcoef(1,2,material)
- denst_f = density(2,material)
- eta_f = poroelastcoef(2,2,material)
- ! frame properties
- mu_fr = poroelastcoef(2,3,material)
- kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
- ! Biot coefficients for the input phi
- D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
- H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
- C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
- M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
- tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIloc = sqrt(cpIsquare)
- else
- lambdaplus2mu = poroelastcoef(3,1,material)
- denst = density(1,material)
-
- cpIloc = sqrt(lambdaplus2mu/denst)
- endif
-
- vpImax_local = -HUGEVAL
-
- distance_min_local = HUGEVAL
- distance_max_local = -HUGEVAL
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
- !--- if heterogeneous formulation with external velocity model
- if(assign_external_model) then
- cpIloc = vpext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- endif
-
- vpImax_local = max(vpImax_local,cpIloc)
-
- enddo
- enddo
-
-! compute minimum and maximum size of edges of this grid cell
- distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
- (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
-
- distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
-
- distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
-
- distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
- (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
-
- distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
- distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
-
- distance_min = min(distance_min,distance_min_local)
- distance_max = max(distance_max,distance_max_local)
-
- courant_stability_number = vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX))
-
-! display bad elements that are above 80% of the threshold
- if(courant_stability_number >= 0.80 * courant_stability_number_max) then
- if ( myrank == 0 ) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- else
- RGB_send(ispec) = 1
- endif
- else
-! do not color the elements if below the threshold
- if ( myrank == 0 ) then
- write(24,*) 'ST'
- else
- RGB_send(ispec) = 0
- endif
- endif
-
- enddo ! end of loop on all the spectral elements
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- allocate(coorg_recv(2,nspec_recv*5))
- allocate(RGB_recv(nspec_recv))
- call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (RGB_recv(1), nspec_recv, MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- do ispec = 1, nspec_recv
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- write(24,*) 'mark'
- write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
- write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
- write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
- write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
- write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
- write(24,*) 'CO'
- if ( RGB_recv(ispec) == 1) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- else
- write(24,*) 'ST'
- endif
- enddo
- deallocate(coorg_recv)
- deallocate(RGB_recv)
-
- enddo
-
- else
- call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (coorg_send, nspec*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (RGB_send, nspec, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- endif
-
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- write(IOUT,*) 'End of creation of PostScript file with stability condition'
- endif
-
-!
-!--------------------------------------------------------------------------------
-!
-
- if (myrank == 0) then
-
- write(IOUT,*)
- write(IOUT,*) 'Creating PostScript file with mesh dispersion'
-
-!
-!---- open PostScript file
-!
- if(any_elastic_glob .or. any_poroelastic) then
- open(unit=24,file='OUTPUT_FILES/mesh_S_wave_dispersion.ps',status='unknown')
- else
- open(unit=24,file='OUTPUT_FILES/mesh_P_wave_dispersion.ps',status='unknown')
- endif
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- write(24,*) '%'
- write(24,*) '/vshift ',-height/2,' CM def'
- write(24,*) '/Rshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop neg vshift MR show } def'
- write(24,*) '/Cshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
- write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- write(24,*) '.4 .9 .9 setrgbcolor'
- write(24,*) '11 CM 1.1 CM MV'
- write(24,*) '(X axis) show'
- write(24,*) '%'
- write(24,*) '1.4 CM 9.5 CM MV'
- write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
- write(24,*) '(Z axis) show'
- write(24,*) 'grestore'
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.7 CM scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- write(24,*) '24.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- if(any_elastic_glob) then
- write(24,*) '(Mesh elastic S-wave dispersion \(red = good, blue = bad\)) show'
- else
- write(24,*) '(Mesh acoustic P-wave dispersion \(red = good, blue = bad\)) show'
- endif
- write(24,*) 'grestore'
- write(24,*) '25.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- draw the spectral element mesh
-!
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- num_ispec = 0
- endif
-
- do ispec = 1, nspec
- if ( myrank == 0 ) then
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- endif
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- if ( myrank == 0 ) then
- write(24,*) 'mark'
- write(24,681) x1,z1
- else
- coorg_send(1,(ispec-1)*5+1) = x1
- coorg_send(2,(ispec-1)*5+1) = z1
- endif
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+2) = x2
- coorg_send(2,(ispec-1)*5+2) = z2
- endif
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+3) = x2
- coorg_send(2,(ispec-1)*5+3) = z2
- endif
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+4) = x2
- coorg_send(2,(ispec-1)*5+4) = z2
- endif
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- write(24,*) 'CO'
- else
- coorg_send(1,(ispec-1)*5+5) = x2
- coorg_send(2,(ispec-1)*5+5) = z2
- endif
-
- material = kmato(ispec)
-
- if(poroelastic(ispec)) then
- phi = porosity(material)
- tort = tortuosity(material)
- perm = permeability(1,material)
-!solid properties
- mu_s = poroelastcoef(2,1,material)
- kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
- denst_s = density(1,material)
- denst = denst_s
-!fluid properties
- kappa_f = poroelastcoef(1,2,material)
- denst_f = density(2,material)
- eta_f = poroelastcoef(2,2,material)
-!frame properties
- mu_fr = poroelastcoef(2,3,material)
- kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
-!Biot coefficients for the input phi
- D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
- H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
- C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
- M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
- tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIloc = sqrt(cpIsquare)
- csloc = sqrt(cssquare)
- else
- mu = poroelastcoef(2,1,material)
- lambdaplus2mu = poroelastcoef(3,1,material)
- denst = density(1,material)
-
- cpIloc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
- endif
-
- vpImax_local = -HUGEVAL
- vpImin_local = HUGEVAL
- vsmin_local = HUGEVAL
-
- distance_min_local = HUGEVAL
- distance_max_local = -HUGEVAL
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
-!--- if heterogeneous formulation with external velocity model
- if(assign_external_model) then
- cpIloc = vpext(i,j,ispec)
- csloc = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- endif
-
- vpImax_local = max(vpImax_local,cpIloc)
- vpImin_local = min(vpImin_local,cpIloc)
- vsmin_local = min(vsmin_local,csloc)
-
- enddo
- enddo
-
-! compute minimum and maximum size of edges of this grid cell
- distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
- (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
-
- distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
-
- distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
-
- distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
- (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
-
- distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
- distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
-
- distance_min = min(distance_min,distance_min_local)
- distance_max = max(distance_max,distance_max_local)
-
-! display mesh dispersion for S waves if there is at least one elastic element in the mesh
- if(any_elastic_glob .or. any_poroelastic_glob) then
-
-! ignore fluid regions with Vs = 0
- if(csloc > 0.0001d0) then
-
- lambdaS_local = vsmin_local / (distance_max_local / (NGLLX - 1))
-
-! display very good elements that are above 80% of the threshold in red
- if(lambdaS_local >= 0.80 * lambdaSmax) then
- if ( myrank == 0 ) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- else
- RGB_send(ispec) = 1
- endif
-
-! display bad elements that are below 120% of the threshold in blue
- else if(lambdaS_local <= 1.20 * lambdaSmin) then
- if ( myrank == 0 ) then
- write(24,*) '0 0 1 RG GF 0 setgray ST'
- else
- RGB_send(ispec) = 3
- endif
-
- else
-! do not color the elements if not close to the threshold
- if ( myrank == 0 ) then
- write(24,*) 'ST'
- else
- RGB_send(ispec) = 0
- endif
- endif
-
- else
-! do not color the elements if S-wave velocity undefined
- if ( myrank == 0 ) then
- write(24,*) 'ST'
- else
- RGB_send(ispec) = 0
- endif
- endif
-
-! display mesh dispersion for P waves if there is no elastic element in the mesh
- else
-
- lambdaPI_local = vpImin_local / (distance_max_local / (NGLLX - 1))
-
-! display very good elements that are above 80% of the threshold in red
- if(lambdaPI_local >= 0.80 * lambdaPImax) then
- if ( myrank == 0 ) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- else
- RGB_send(ispec) = 1
- endif
-
-! display bad elements that are below 120% of the threshold in blue
- else if(lambdaPI_local <= 1.20 * lambdaPImin) then
- if ( myrank == 0 ) then
- write(24,*) '0 0 1 RG GF 0 setgray ST'
- else
- RGB_send(ispec) = 3
- endif
-
- else
-! do not color the elements if not close to the threshold
- if ( myrank == 0 ) then
- write(24,*) 'ST'
- else
- RGB_send(ispec) = 0
- endif
- endif
-
- endif
-
- enddo ! end of loop on all the spectral elements
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- allocate(coorg_recv(2,nspec_recv*5))
- allocate(RGB_recv(nspec_recv))
- call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (RGB_recv(1), nspec_recv, MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- do ispec = 1, nspec_recv
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- write(24,*) 'mark'
- write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
- write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
- write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
- write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
- write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
- write(24,*) 'CO'
- if ( RGB_recv(ispec) == 1) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- endif
- if ( RGB_recv(ispec) == 3) then
- write(24,*) '0 0 1 RG GF 0 setgray ST'
- endif
- if ( RGB_recv(ispec) == 0) then
- write(24,*) 'ST'
- endif
-
- enddo
- deallocate(coorg_recv)
- deallocate(RGB_recv)
-
- enddo
-
- else
- call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (coorg_send, nspec*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (RGB_send, nspec, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
-
- endif
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- write(IOUT,*) 'End of creation of PostScript file with mesh dispersion'
-
- endif
-
-!
-!--------------------------------------------------------------------------------
-!
-
- if (myrank == 0) then
-
- write(IOUT,*)
- write(IOUT,*) 'Creating PostScript file with velocity model'
-
-!
-!---- open PostScript file
-!
- open(unit=24,file='OUTPUT_FILES/P_velocity_model.ps',status='unknown')
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- write(24,*) '%'
- write(24,*) '/vshift ',-height/2,' CM def'
- write(24,*) '/Rshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop neg vshift MR show } def'
- write(24,*) '/Cshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
- write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- write(24,*) '.4 .9 .9 setrgbcolor'
- write(24,*) '11 CM 1.1 CM MV'
- write(24,*) '(X axis) show'
- write(24,*) '%'
- write(24,*) '1.4 CM 9.5 CM MV'
- write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
- write(24,*) '(Z axis) show'
- write(24,*) 'grestore'
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.7 CM scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- write(24,*) '24.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(P-velocity model \(dark = fast, light = slow\)) show'
- write(24,*) 'grestore'
- write(24,*) '25.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- draw the spectral element mesh
-!
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- num_ispec = 0
-endif
-
- do ispec = 1, UPPER_LIMIT_DISPLAY
- if ( myrank == 0 ) then
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- endif
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- if ( myrank == 0 ) then
- write(24,*) 'mark'
- write(24,681) x1,z1
- else
- coorg_send(1,(ispec-1)*5+1) = x1
- coorg_send(2,(ispec-1)*5+1) = z1
- endif
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+2) = x2
- coorg_send(2,(ispec-1)*5+2) = z2
- endif
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+3) = x2
- coorg_send(2,(ispec-1)*5+3) = z2
- endif
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+4) = x2
- coorg_send(2,(ispec-1)*5+4) = z2
- endif
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- write(24,*) 'CO'
- else
- coorg_send(1,(ispec-1)*5+5) = x2
- coorg_send(2,(ispec-1)*5+5) = z2
- endif
-
- if((vpImax-vpImin)/vpImin > 0.02d0) then
- if(assign_external_model) then
-! use lower-left corner
- x1 = (vpext(1,1,ispec)-vpImin) / (vpImax-vpImin)
- else
- material = kmato(ispec)
- if(poroelastic(ispec)) then
- phi = porosity(material)
- tort = tortuosity(material)
- perm = permeability(1,material)
-!solid properties
- mu_s = poroelastcoef(2,1,material)
- kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
- denst_s = density(1,material)
-!fluid properties
- kappa_f = poroelastcoef(1,2,material)
- denst_f = density(2,material)
- eta_f = poroelastcoef(2,2,material)
-!frame properties
- mu_fr = poroelastcoef(2,3,material)
- kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
-!Biot coefficients for the input phi
- D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
- H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
- C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
- M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
- tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIloc = sqrt(cpIsquare)
- else
- lambdaplus2mu = poroelastcoef(3,1,material)
- denst = density(1,material)
- cpIloc = sqrt(lambdaplus2mu/denst)
- endif
- x1 = (cpIloc-vpImin)/(vpImax-vpImin)
- endif
- else
- x1 = 0.5d0
- endif
-
-! rescale to avoid very dark gray levels
- x1 = x1*0.7 + 0.2
- if(x1 > 1.d0) x1=1.d0
-
-! invert scale: white = vpmin, dark gray = vpmax
- x1 = 1.d0 - x1
-
-! display P-velocity model using gray levels
- if ( myrank == 0 ) then
- write(24,*) sngl(x1),' setgray GF 0 setgray ST'
- else
- greyscale_send(ispec) = sngl(x1)
- endif
- enddo ! end of loop on all the spectral elements
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- allocate(coorg_recv(2,nspec_recv*5))
- allocate(greyscale_recv(nspec_recv))
- call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (greyscale_recv(1), nspec_recv, MPI_REAL, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- do ispec = 1, nspec_recv
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- write(24,*) 'mark'
- write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
- write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
- write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
- write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
- write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
- write(24,*) 'CO'
- write(24,*) greyscale_recv(ispec), ' setgray GF 0 setgray ST'
-
- enddo
- deallocate(coorg_recv)
- deallocate(greyscale_recv)
-
- enddo
-
- else
- call MPI_SEND (UPPER_LIMIT_DISPLAY, 1, MPI_INTEGER, &
- 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (coorg_send, UPPER_LIMIT_DISPLAY*5*2, MPI_DOUBLE_PRECISION, &
- 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (greyscale_send, UPPER_LIMIT_DISPLAY, MPI_INTEGER, &
- 0, 42, MPI_COMM_WORLD, ier)
- endif
-#endif
-
- if (myrank == 0) then
-
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- write(IOUT,*) 'End of creation of PostScript file with velocity model'
-
- endif
-
- if (myrank == 0) then
-
- write(IOUT,*)
- write(IOUT,*) 'Creating PostScript file with mesh partitioning'
-
-!
-!---- open PostScript file
-!
- open(unit=24,file='OUTPUT_FILES/mesh_partitioning.ps',status='unknown')
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- write(24,*) '%'
- write(24,*) '/vshift ',-height/2,' CM def'
- write(24,*) '/Rshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop neg vshift MR show } def'
- write(24,*) '/Cshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
- write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- write(24,*) '.4 .9 .9 setrgbcolor'
- write(24,*) '11 CM 1.1 CM MV'
- write(24,*) '(X axis) show'
- write(24,*) '%'
- write(24,*) '1.4 CM 9.5 CM MV'
- write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
- write(24,*) '(Z axis) show'
- write(24,*) 'grestore'
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.7 CM scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- write(24,*) '24.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(Mesh partitioning) show'
- write(24,*) 'grestore'
- write(24,*) '25.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- draw the spectral element mesh
-!
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- num_ispec = 0
- endif
-
- do ispec = 1, UPPER_LIMIT_DISPLAY
-
- if ( myrank == 0 ) then
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- endif
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- if ( myrank == 0 ) then
- write(24,*) 'mark'
- write(24,681) x1,z1
- else
- coorg_send(1,(ispec-1)*5+1) = x1
- coorg_send(2,(ispec-1)*5+1) = z1
- endif
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+2) = x2
- coorg_send(2,(ispec-1)*5+2) = z2
- endif
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+3) = x2
- coorg_send(2,(ispec-1)*5+3) = z2
- endif
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- coorg_send(1,(ispec-1)*5+4) = x2
- coorg_send(2,(ispec-1)*5+4) = z2
- endif
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- write(24,*) 'CO'
- else
- coorg_send(1,(ispec-1)*5+5) = x2
- coorg_send(2,(ispec-1)*5+5) = z2
- endif
-
- if ( myrank == 0 ) then
- write(24,*) red(1), green(1), blue(1), 'RG GF 0 setgray ST'
- endif
-
- enddo ! end of loop on all the spectral elements
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
-
-! use a different color for each material set
- icol = mod(iproc, NUM_COLORS) + 1
-
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- allocate(coorg_recv(2,nspec_recv*5))
- call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- do ispec = 1, nspec_recv
- num_ispec = num_ispec + 1
- write(24,*) '% elem ',num_ispec
- write(24,*) 'mark'
- write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
- write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
- write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
- write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
- write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
- write(24,*) 'CO'
-
- write(24,*) red(icol), green(icol), blue(icol), ' RG GF 0 setgray ST'
-
- enddo
- deallocate(coorg_recv)
-
- enddo
-
- else
- call MPI_SEND (UPPER_LIMIT_DISPLAY, 1, MPI_INTEGER, &
- 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (coorg_send, UPPER_LIMIT_DISPLAY*5*2, MPI_DOUBLE_PRECISION, &
- 0, 42, MPI_COMM_WORLD, ier)
-
- endif
-#endif
-
- if (myrank == 0) then
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- write(IOUT,*) 'End of creation of PostScript file with partitioning'
- write(IOUT,*)
- endif
-
- 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a100,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
-
- 681 format(f6.2,1x,f6.2)
-
- end subroutine checkgrid
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine checkgrid_setup_GLLper(percent_GLL,NGLLX_MAX_STABILITY)
-
- implicit none
- include "constants.h"
-
- integer :: NGLLX_MAX_STABILITY
- double precision :: percent_GLL(NGLLX_MAX_STABILITY)
-
- if( NGLLX_MAX_STABILITY /= 15 ) call exit_MPI('check NGLLX_MAX_STABILITY in checkgrid.f90')
-
-! define percentage of smallest distance between GLL points for NGLLX points
-! percentages were computed by calling the GLL points routine for each degree
-
- percent_GLL(2) = 100.d0
- percent_GLL(3) = 50.d0
- percent_GLL(4) = 27.639320225002102d0
- percent_GLL(5) = 17.267316464601141d0
- percent_GLL(6) = 11.747233803526763d0
- percent_GLL(7) = 8.4888051860716516d0
- percent_GLL(8) = 6.4129925745196719d0
- percent_GLL(9) = 5.0121002294269914d0
- percent_GLL(10) = 4.0233045916770571d0
- percent_GLL(11) = 3.2999284795970416d0
- percent_GLL(12) = 2.7550363888558858d0
- percent_GLL(13) = 2.3345076678918053d0
- percent_GLL(14) = 2.0032477366369594d0
- percent_GLL(15) = 1.7377036748080721d0
-
-! convert to real percentage
- percent_GLL(:) = percent_GLL(:) / 100.d0
-
- if(NGLLX > NGLLX_MAX_STABILITY) then
- call exit_MPI('cannot estimate the stability condition for that degree')
- endif
-
- end subroutine checkgrid_setup_GLLper
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine checkgrid_setup_colorp(red,green,blue,NUM_COLORS)
-
-! color palette
-
- implicit none
- integer :: NUM_COLORS
- double precision, dimension(NUM_COLORS) :: red,green,blue
-
- if( NUM_COLORS /= 236 ) call exit_MPI('check NUM_COLORS in checkgrid.f90')
-
-! red
- red(1) = 1.00000000000000
- green(1) = 0.000000000000000E+000
- blue(1) = 0.000000000000000E+000
-
-! DodgerBlue2
- red(2) = 0.109803921568627
- green(2) = 0.525490196078431
- blue(2) = 0.933333333333333
-
-! gold
- red(3) = 1.00000000000000
- green(3) = 0.840000000000000
- blue(3) = 0.000000000000000E+000
-
-! springgreen
- red(4) = 0.000000000000000E+000
- green(4) = 1.00000000000000
- blue(4) = 0.500000000000000
-
-! NavajoWhite
- red(5) = 1.00000000000000
- green(5) = 0.870588235294118
- blue(5) = 0.678431372549020
-
-! SteelBlue3
- red(6) = 0.309803921568627
- green(6) = 0.580392156862745
- blue(6) = 0.803921568627451
-
-! Ivory3
- red(7) = 0.803921568627451
- green(7) = 0.803921568627451
- blue(7) = 0.756862745098039
-
-! SkyBlue4
- red(8) = 0.290196078431373
- green(8) = 0.439215686274510
- blue(8) = 0.545098039215686
-
-! Snow
- red(9) = 0.980392156862745
- green(9) = 0.980392156862745
- blue(9) = 0.980392156862745
-
-! SteelBlue
- red(10) = 0.274509803921569
- green(10) = 0.509803921568627
- blue(10) = 0.705882352941177
-
-! Bisque3
- red(11) = 0.803921568627451
- green(11) = 0.717647058823529
- blue(11) = 0.619607843137255
-
-! Salmon
- red(12) = 0.980392156862745
- green(12) = 0.501960784313725
- blue(12) = 0.447058823529412
-
-! SlateBlue2
- red(13) = 0.478431372549020
- green(13) = 0.403921568627451
- blue(13) = 0.933333333333333
-
-! NavajoWhite2
- red(14) = 0.933333333333333
- green(14) = 0.811764705882353
- blue(14) = 0.631372549019608
-
-! MediumBlue
- red(15) = 0.000000000000000E+000
- green(15) = 0.000000000000000E+000
- blue(15) = 0.803921568627451
-
-! LightCoral
- red(16) = 0.941176470588235
- green(16) = 0.501960784313725
- blue(16) = 0.501960784313725
-
-! FloralWhite
- red(17) = 1.00000000000000
- green(17) = 0.980392156862745
- blue(17) = 0.941176470588235
-
-! Cornsilk3
- red(18) = 0.803921568627451
- green(18) = 0.784313725490196
- blue(18) = 0.694117647058824
-
-! GhostWhite
- red(19) = 0.972549019607843
- green(19) = 0.972549019607843
- blue(19) = 1.00000000000000
-
-! blue
- red(20) = 0.000000000000000E+000
- green(20) = 0.000000000000000E+000
- blue(20) = 1.00000000000000
-
-! Linen
- red(21) = 0.980392156862745
- green(21) = 0.941176470588235
- blue(21) = 0.901960784313726
-
-! peachpuff
- red(22) = 1.00000000000000
- green(22) = 0.850000000000000
- blue(22) = 0.730000000000000
-
-! Cornsilk1
- red(23) = 1.00000000000000
- green(23) = 0.972549019607843
- blue(23) = 0.862745098039216
-
-! LightSalmon
- red(24) = 1.00000000000000
- green(24) = 0.627450980392157
- blue(24) = 0.478431372549020
-
-! DeepSkyBlue1
- red(25) = 0.000000000000000E+000
- green(25) = 0.749019607843137
- blue(25) = 1.00000000000000
-
-! LemonChiffon4
- red(26) = 0.545098039215686
- green(26) = 0.537254901960784
- blue(26) = 0.439215686274510
-
-! PeachPuff1
- red(27) = 1.00000000000000
- green(27) = 0.854901960784314
- blue(27) = 0.725490196078431
-
-! BlanchedAlmond
- red(28) = 1.00000000000000
- green(28) = 0.921568627450980
- blue(28) = 0.803921568627451
-
-! SlateBlue3
- red(29) = 0.411764705882353
- green(29) = 0.349019607843137
- blue(29) = 0.803921568627451
-
-! LightSkyBlue1
- red(30) = 0.690196078431373
- green(30) = 0.886274509803922
- blue(30) = 1.00000000000000
-
-! DarkViolet
- red(31) = 0.580392156862745
- green(31) = 0.000000000000000E+000
- blue(31) = 0.827450980392157
-
-! Azure3
- red(32) = 0.756862745098039
- green(32) = 0.803921568627451
- blue(32) = 0.803921568627451
-
-! LavenderBlush3
- red(33) = 0.803921568627451
- green(33) = 0.756862745098039
- blue(33) = 0.772549019607843
-
-! Honeydew1
- red(34) = 0.941176470588235
- green(34) = 1.00000000000000
- blue(34) = 0.941176470588235
-
-! Ivory2
- red(35) = 0.933333333333333
- green(35) = 0.933333333333333
- blue(35) = 0.878431372549020
-
-! RosyBrown
- red(36) = 0.737254901960784
- green(36) = 0.560784313725490
- blue(36) = 0.560784313725490
-
-! Thistle
- red(37) = 0.847058823529412
- green(37) = 0.749019607843137
- blue(37) = 0.847058823529412
-
-! Orange
- red(38) = 1.00000000000000
- green(38) = 0.647058823529412
- blue(38) = 0.000000000000000E+000
-
-! DarkSeaGreen
- red(39) = 0.560784313725490
- green(39) = 0.737254901960784
- blue(39) = 0.560784313725490
-
-! Moccasin
- red(40) = 1.00000000000000
- green(40) = 0.894117647058824
- blue(40) = 0.709803921568627
-
-! DeepSkyBlue2
- red(41) = 0.000000000000000E+000
- green(41) = 0.698039215686274
- blue(41) = 0.933333333333333
-
-! SlateGray4
- red(42) = 0.423529411764706
- green(42) = 0.482352941176471
- blue(42) = 0.545098039215686
-
-! Beige
- red(43) = 0.960784313725490
- green(43) = 0.960784313725490
- blue(43) = 0.862745098039216
-
-! Gold
- red(44) = 1.00000000000000
- green(44) = 0.843137254901961
- blue(44) = 0.000000000000000E+000
-
-! SlateBlue
- red(45) = 0.415686274509804
- green(45) = 0.352941176470588
- blue(45) = 0.803921568627451
-
-! SteelBlue1
- red(46) = 0.388235294117647
- green(46) = 0.721568627450980
- blue(46) = 1.00000000000000
-
-! SaddleBrown
- red(47) = 0.545098039215686
- green(47) = 0.270588235294118
- blue(47) = 7.450980392156863E-002
-
-! Pink
- red(48) = 1.00000000000000
- green(48) = 0.752941176470588
- blue(48) = 0.796078431372549
-
-! Black
- red(49) = 0.000000000000000E+000
- green(49) = 0.000000000000000E+000
- blue(49) = 0.000000000000000E+000
-
-! SlateGrey
- red(50) = 0.439215686274510
- green(50) = 0.501960784313725
- blue(50) = 0.564705882352941
-
-! Ivory
- red(51) = 1.00000000000000
- green(51) = 1.00000000000000
- blue(51) = 0.941176470588235
-
-! OliveDrab
- red(52) = 0.419607843137255
- green(52) = 0.556862745098039
- blue(52) = 0.137254901960784
-
-! Ivory1
- red(53) = 1.00000000000000
- green(53) = 1.00000000000000
- blue(53) = 0.941176470588235
-
-! SkyBlue
- red(54) = 0.529411764705882
- green(54) = 0.807843137254902
- blue(54) = 0.921568627450980
-
-! MistyRose3
- red(55) = 0.803921568627451
- green(55) = 0.717647058823529
- blue(55) = 0.709803921568627
-
-! LimeGreen
- red(56) = 0.196078431372549
- green(56) = 0.803921568627451
- blue(56) = 0.196078431372549
-
-! Purple
- red(57) = 0.627450980392157
- green(57) = 0.125490196078431
- blue(57) = 0.941176470588235
-
-! SkyBlue2
- red(58) = 0.494117647058824
- green(58) = 0.752941176470588
- blue(58) = 0.933333333333333
-
-! Red
- red(59) = 1.00000000000000
- green(59) = 0.000000000000000E+000
- blue(59) = 0.000000000000000E+000
-
-! DarkKhaki
- red(60) = 0.741176470588235
- green(60) = 0.717647058823529
- blue(60) = 0.419607843137255
-
-! MediumTurquoise
- red(61) = 0.282352941176471
- green(61) = 0.819607843137255
- blue(61) = 0.800000000000000
-
-! Grey
- red(62) = 0.745098039215686
- green(62) = 0.745098039215686
- blue(62) = 0.745098039215686
-
-! Coral
- red(63) = 1.00000000000000
- green(63) = 0.498039215686275
- blue(63) = 0.313725490196078
-
-! NavajoWhite4
- red(64) = 0.545098039215686
- green(64) = 0.474509803921569
- blue(64) = 0.368627450980392
-
-! SlateBlue4
- red(65) = 0.278431372549020
- green(65) = 0.235294117647059
- blue(65) = 0.545098039215686
-
-! RoyalBlue4
- red(66) = 0.152941176470588
- green(66) = 0.250980392156863
- blue(66) = 0.545098039215686
-
-! YellowGreen
- red(67) = 0.603921568627451
- green(67) = 0.803921568627451
- blue(67) = 0.196078431372549
-
-! DeepSkyBlue3
- red(68) = 0.000000000000000E+000
- green(68) = 0.603921568627451
- blue(68) = 0.803921568627451
-
-! goldenrod
- red(69) = 0.854901960784314
- green(69) = 0.647058823529412
- blue(69) = 0.125490196078431
-
-! AntiqueWhite4
- red(70) = 0.545098039215686
- green(70) = 0.513725490196078
- blue(70) = 0.470588235294118
-
-! lemonchiffon
- red(71) = 1.00000000000000
- green(71) = 0.980000000000000
- blue(71) = 0.800000000000000
-
-! GreenYellow
- red(72) = 0.678431372549020
- green(72) = 1.00000000000000
- blue(72) = 0.184313725490196
-
-! LightSlateGray
- red(73) = 0.466666666666667
- green(73) = 0.533333333333333
- blue(73) = 0.600000000000000
-
-! RoyalBlue
- red(74) = 0.254901960784314
- green(74) = 0.411764705882353
- blue(74) = 0.882352941176471
-
-! DarkGreen
- red(75) = 0.000000000000000E+000
- green(75) = 0.392156862745098
- blue(75) = 0.000000000000000E+000
-
-! NavajoWhite3
- red(76) = 0.803921568627451
- green(76) = 0.701960784313725
- blue(76) = 0.545098039215686
-
-! Azure1
- red(77) = 0.941176470588235
- green(77) = 1.00000000000000
- blue(77) = 1.00000000000000
-
-! PowderBlue
- red(78) = 0.690196078431373
- green(78) = 0.878431372549020
- blue(78) = 0.901960784313726
-
-! slateblue
- red(79) = 0.420000000000000
- green(79) = 0.350000000000000
- blue(79) = 0.800000000000000
-
-! MediumOrchid
- red(80) = 0.729411764705882
- green(80) = 0.333333333333333
- blue(80) = 0.827450980392157
-
-! turquoise
- red(81) = 0.250000000000000
- green(81) = 0.880000000000000
- blue(81) = 0.820000000000000
-
-! Snow1
- red(82) = 1.00000000000000
- green(82) = 0.980392156862745
- blue(82) = 0.980392156862745
-
-! violet
- red(83) = 0.930000000000000
- green(83) = 0.510000000000000
- blue(83) = 0.930000000000000
-
-! DeepPink
- red(84) = 1.00000000000000
- green(84) = 7.843137254901961E-002
- blue(84) = 0.576470588235294
-
-! MistyRose4
- red(85) = 0.545098039215686
- green(85) = 0.490196078431373
- blue(85) = 0.482352941176471
-
-! PeachPuff3
- red(86) = 0.803921568627451
- green(86) = 0.686274509803922
- blue(86) = 0.584313725490196
-
-! MediumSeaGreen
- red(87) = 0.235294117647059
- green(87) = 0.701960784313725
- blue(87) = 0.443137254901961
-
-! Honeydew4
- red(88) = 0.513725490196078
- green(88) = 0.545098039215686
- blue(88) = 0.513725490196078
-
-! Tan
- red(89) = 0.823529411764706
- green(89) = 0.705882352941177
- blue(89) = 0.549019607843137
-
-! DarkGoldenrod
- red(90) = 0.721568627450980
- green(90) = 0.525490196078431
- blue(90) = 4.313725490196078E-002
-
-! Blue2
- red(91) = 0.000000000000000E+000
- green(91) = 0.000000000000000E+000
- blue(91) = 0.933333333333333
-
-! Maroon
- red(92) = 0.690196078431373
- green(92) = 0.188235294117647
- blue(92) = 0.376470588235294
-
-! LightSkyBlue3
- red(93) = 0.552941176470588
- green(93) = 0.713725490196078
- blue(93) = 0.803921568627451
-
-! LemonChiffon2
- red(94) = 0.933333333333333
- green(94) = 0.913725490196078
- blue(94) = 0.749019607843137
-
-! Snow3
- red(95) = 0.803921568627451
- green(95) = 0.788235294117647
- blue(95) = 0.788235294117647
-
-! Ivory4
- red(96) = 0.545098039215686
- green(96) = 0.545098039215686
- blue(96) = 0.513725490196078
-
-! AntiqueWhite3
- red(97) = 0.803921568627451
- green(97) = 0.752941176470588
- blue(97) = 0.690196078431373
-
-! Bisque4
- red(98) = 0.545098039215686
- green(98) = 0.490196078431373
- blue(98) = 0.419607843137255
-
-! Snow2
- red(99) = 0.933333333333333
- green(99) = 0.913725490196078
- blue(99) = 0.913725490196078
-
-! SlateGray1
- red(100) = 0.776470588235294
- green(100) = 0.886274509803922
- blue(100) = 1.00000000000000
-
-! Seashell2
- red(101) = 0.933333333333333
- green(101) = 0.898039215686275
- blue(101) = 0.870588235294118
-
-! Aquamarine
- red(102) = 0.498039215686275
- green(102) = 1.00000000000000
- blue(102) = 0.831372549019608
-
-! SlateGray2
- red(103) = 0.725490196078431
- green(103) = 0.827450980392157
- blue(103) = 0.933333333333333
-
-! White
- red(104) = 1.00000000000000
- green(104) = 1.00000000000000
- blue(104) = 1.00000000000000
-
-! LavenderBlush
- red(105) = 1.00000000000000
- green(105) = 0.941176470588235
- blue(105) = 0.960784313725490
-
-! DodgerBlue3
- red(106) = 9.411764705882353E-002
- green(106) = 0.454901960784314
- blue(106) = 0.803921568627451
-
-! RoyalBlue3
- red(107) = 0.227450980392157
- green(107) = 0.372549019607843
- blue(107) = 0.803921568627451
-
-! LightYellow
- red(108) = 1.00000000000000
- green(108) = 1.00000000000000
- blue(108) = 0.878431372549020
-
-! DeepSkyBlue
- red(109) = 0.000000000000000E+000
- green(109) = 0.749019607843137
- blue(109) = 1.00000000000000
-
-! AntiqueWhite2
- red(110) = 0.933333333333333
- green(110) = 0.874509803921569
- blue(110) = 0.800000000000000
-
-! CornflowerBlue
- red(111) = 0.392156862745098
- green(111) = 0.584313725490196
- blue(111) = 0.929411764705882
-
-! PeachPuff4
- red(112) = 0.545098039215686
- green(112) = 0.466666666666667
- blue(112) = 0.396078431372549
-
-! SpringGreen
- red(113) = 0.000000000000000E+000
- green(113) = 1.00000000000000
- blue(113) = 0.498039215686275
-
-! Honeydew
- red(114) = 0.941176470588235
- green(114) = 1.00000000000000
- blue(114) = 0.941176470588235
-
-! Honeydew2
- red(115) = 0.878431372549020
- green(115) = 0.933333333333333
- blue(115) = 0.878431372549020
-
-! LightSeaGreen
- red(116) = 0.125490196078431
- green(116) = 0.698039215686274
- blue(116) = 0.666666666666667
-
-! NavyBlue
- red(117) = 0.000000000000000E+000
- green(117) = 0.000000000000000E+000
- blue(117) = 0.501960784313725
-
-! Azure4
- red(118) = 0.513725490196078
- green(118) = 0.545098039215686
- blue(118) = 0.545098039215686
-
-! MediumAquamarine
- red(119) = 0.400000000000000
- green(119) = 0.803921568627451
- blue(119) = 0.666666666666667
-
-! SkyBlue3
- red(120) = 0.423529411764706
- green(120) = 0.650980392156863
- blue(120) = 0.803921568627451
-
-! LavenderBlush2
- red(121) = 0.933333333333333
- green(121) = 0.878431372549020
- blue(121) = 0.898039215686275
-
-! Bisque1
- red(122) = 1.00000000000000
- green(122) = 0.894117647058824
- blue(122) = 0.768627450980392
-
-! DarkOrange
- red(123) = 1.00000000000000
- green(123) = 0.549019607843137
- blue(123) = 0.000000000000000E+000
-
-! LightSteelBlue
- red(124) = 0.690196078431373
- green(124) = 0.768627450980392
- blue(124) = 0.870588235294118
-
-! SteelBlue2
- red(125) = 0.360784313725490
- green(125) = 0.674509803921569
- blue(125) = 0.933333333333333
-
-! LemonChiffon3
- red(126) = 0.803921568627451
- green(126) = 0.788235294117647
- blue(126) = 0.647058823529412
-
-! DarkSlateBlue
- red(127) = 0.282352941176471
- green(127) = 0.239215686274510
- blue(127) = 0.545098039215686
-
-! Seashell
- red(128) = 1.00000000000000
- green(128) = 0.960784313725490
- blue(128) = 0.933333333333333
-
-! Firebrick
- red(129) = 0.698039215686274
- green(129) = 0.133333333333333
- blue(129) = 0.133333333333333
-
-! LightGray
- red(130) = 0.827450980392157
- green(130) = 0.827450980392157
- blue(130) = 0.827450980392157
-
-! Blue
- red(131) = 0.000000000000000E+000
- green(131) = 0.000000000000000E+000
- blue(131) = 1.00000000000000
-
-! Bisque2
- red(132) = 0.933333333333333
- green(132) = 0.835294117647059
- blue(132) = 0.717647058823529
-
-! WhiteSmoke
- red(133) = 0.960784313725490
- green(133) = 0.960784313725490
- blue(133) = 0.960784313725490
-
-! SeaGreen
- red(134) = 0.180392156862745
- green(134) = 0.545098039215686
- blue(134) = 0.341176470588235
-
-! Burlywood
- red(135) = 0.870588235294118
- green(135) = 0.721568627450980
- blue(135) = 0.529411764705882
-
-! RoyalBlue2
- red(136) = 0.262745098039216
- green(136) = 0.431372549019608
- blue(136) = 0.933333333333333
-
-! RoyalBlue1
- red(137) = 0.282352941176471
- green(137) = 0.462745098039216
- blue(137) = 1.00000000000000
-
-! SteelBlue4
- red(138) = 0.211764705882353
- green(138) = 0.392156862745098
- blue(138) = 0.545098039215686
-
-! AliceBlue
- red(139) = 0.941176470588235
- green(139) = 0.972549019607843
- blue(139) = 1.00000000000000
-
-! LightSlateBlue
- red(140) = 0.517647058823529
- green(140) = 0.439215686274510
- blue(140) = 1.00000000000000
-
-! MistyRose1
- red(141) = 1.00000000000000
- green(141) = 0.894117647058824
- blue(141) = 0.882352941176471
-
-! SandyBrown
- red(142) = 0.956862745098039
- green(142) = 0.643137254901961
- blue(142) = 0.376470588235294
-
-! DarkOliveGreen
- red(143) = 0.333333333333333
- green(143) = 0.419607843137255
- blue(143) = 0.184313725490196
-
-! Yellow
- red(144) = 1.00000000000000
- green(144) = 1.00000000000000
- blue(144) = 0.000000000000000E+000
-
-! SlateGray3
- red(145) = 0.623529411764706
- green(145) = 0.713725490196078
- blue(145) = 0.803921568627451
-
-! HotPink
- red(146) = 1.00000000000000
- green(146) = 0.411764705882353
- blue(146) = 0.705882352941177
-
-! Violet
- red(147) = 0.933333333333333
- green(147) = 0.509803921568627
- blue(147) = 0.933333333333333
-
-! LightSkyBlue
- red(148) = 0.529411764705882
- green(148) = 0.807843137254902
- blue(148) = 0.980392156862745
-
-! Cornsilk2
- red(149) = 0.933333333333333
- green(149) = 0.909803921568627
- blue(149) = 0.803921568627451
-
-! MidnightBlue
- red(150) = 9.803921568627451E-002
- green(150) = 9.803921568627451E-002
- blue(150) = 0.439215686274510
-
-! AntiqueWhite
- red(151) = 0.980392156862745
- green(151) = 0.921568627450980
- blue(151) = 0.843137254901961
-
-! PaleGreen
- red(152) = 0.596078431372549
- green(152) = 0.984313725490196
- blue(152) = 0.596078431372549
-
-! MedSpringGreen
- red(153) = 0.000000000000000E+000
- green(153) = 0.980392156862745
- blue(153) = 0.603921568627451
-
-! DodgerBlue1
- red(154) = 0.117647058823529
- green(154) = 0.564705882352941
- blue(154) = 1.00000000000000
-
-! Blue3
- red(155) = 0.000000000000000E+000
- green(155) = 0.000000000000000E+000
- blue(155) = 0.803921568627451
-
-! Cyan
- red(156) = 0.000000000000000E+000
- green(156) = 1.00000000000000
- blue(156) = 1.00000000000000
-
-! LemonChiffon
- red(157) = 1.00000000000000
- green(157) = 0.980392156862745
- blue(157) = 0.803921568627451
-
-! mediumorchid
- red(158) = 0.730000000000000
- green(158) = 0.330000000000000
- blue(158) = 0.830000000000000
-
-! Turquoise
- red(159) = 0.250980392156863
- green(159) = 0.878431372549020
- blue(159) = 0.815686274509804
-
-! IndianRed
- red(160) = 0.803921568627451
- green(160) = 0.360784313725490
- blue(160) = 0.360784313725490
-
-! DodgerBlue
- red(161) = 0.117647058823529
- green(161) = 0.564705882352941
- blue(161) = 1.00000000000000
-
-! Seashell3
- red(162) = 0.803921568627451
- green(162) = 0.772549019607843
- blue(162) = 0.749019607843137
-
-! BlueViolet
- red(163) = 0.541176470588235
- green(163) = 0.168627450980392
- blue(163) = 0.886274509803922
-
-! DeepSkyBlue4
- red(164) = 0.000000000000000E+000
- green(164) = 0.407843137254902
- blue(164) = 0.545098039215686
-
-! PaleVioletRed
- red(165) = 0.858823529411765
- green(165) = 0.439215686274510
- blue(165) = 0.576470588235294
-
-! Azure2
- red(166) = 0.878431372549020
- green(166) = 0.933333333333333
- blue(166) = 0.933333333333333
-
-! greenyellow
- red(167) = 0.680000000000000
- green(167) = 1.00000000000000
- blue(167) = 0.180000000000000
-
-! LightGoldenrod
- red(168) = 0.933333333333333
- green(168) = 0.866666666666667
- blue(168) = 0.509803921568627
-
-! MistyRose
- red(169) = 1.00000000000000
- green(169) = 0.894117647058824
- blue(169) = 0.882352941176471
-
-! LightSkyBlue4
- red(170) = 0.376470588235294
- green(170) = 0.482352941176471
- blue(170) = 0.545098039215686
-
-! OrangeRed
- red(171) = 1.00000000000000
- green(171) = 0.270588235294118
- blue(171) = 0.000000000000000E+000
-
-! DimGrey
- red(172) = 0.411764705882353
- green(172) = 0.411764705882353
- blue(172) = 0.411764705882353
-
-! MediumVioletRed
- red(173) = 0.780392156862745
- green(173) = 8.235294117647059E-002
- blue(173) = 0.521568627450980
-
-! DarkSlateGray
- red(174) = 0.184313725490196
- green(174) = 0.309803921568627
- blue(174) = 0.309803921568627
-
-! yellow
- red(175) = 1.00000000000000
- green(175) = 1.00000000000000
- blue(175) = 0.000000000000000E+000
-
-! Plum
- red(176) = 0.866666666666667
- green(176) = 0.627450980392157
- blue(176) = 0.866666666666667
-
-! DarkTurquoise
- red(177) = 0.000000000000000E+000
- green(177) = 0.807843137254902
- blue(177) = 0.819607843137255
-
-! DodgerBlue4
- red(178) = 6.274509803921569E-002
- green(178) = 0.305882352941176
- blue(178) = 0.545098039215686
-
-! Cornsilk
- red(179) = 1.00000000000000
- green(179) = 0.972549019607843
- blue(179) = 0.862745098039216
-
-! SkyBlue1
- red(180) = 0.529411764705882
- green(180) = 0.807843137254902
- blue(180) = 1.00000000000000
-
-! Seashell1
- red(181) = 1.00000000000000
- green(181) = 0.960784313725490
- blue(181) = 0.933333333333333
-
-! lavender
- red(182) = 0.901960784313726
- green(182) = 0.901960784313726
- blue(182) = 0.980392156862745
-
-! Snow4
- red(183) = 0.545098039215686
- green(183) = 0.537254901960784
- blue(183) = 0.537254901960784
-
-! Peru
- red(184) = 0.803921568627451
- green(184) = 0.521568627450980
- blue(184) = 0.247058823529412
-
-! PeachPuff
- red(185) = 1.00000000000000
- green(185) = 0.854901960784314
- blue(185) = 0.725490196078431
-
-! Green
- red(186) = 0.000000000000000E+000
- green(186) = 1.00000000000000
- blue(186) = 0.000000000000000E+000
-
-! Blue1
- red(187) = 0.000000000000000E+000
- green(187) = 0.000000000000000E+000
- blue(187) = 1.00000000000000
-
-! Seashell4
- red(188) = 0.545098039215686
- green(188) = 0.525490196078431
- blue(188) = 0.509803921568627
-
-! dodgerblue
- red(189) = 0.120000000000000
- green(189) = 0.560000000000000
- blue(189) = 1.00000000000000
-
-! MistyRose2
- red(190) = 0.933333333333333
- green(190) = 0.835294117647059
- blue(190) = 0.823529411764706
-
-! Tomato
- red(191) = 1.00000000000000
- green(191) = 0.388235294117647
- blue(191) = 0.278431372549020
-
-! Wheat
- red(192) = 0.960784313725490
- green(192) = 0.870588235294118
- blue(192) = 0.701960784313725
-
-! LightBlue
- red(193) = 0.678431372549020
- green(193) = 0.847058823529412
- blue(193) = 0.901960784313726
-
-! Chocolate
- red(194) = 0.823529411764706
- green(194) = 0.411764705882353
- blue(194) = 0.117647058823529
-
-! Blue4
- red(195) = 0.000000000000000E+000
- green(195) = 0.000000000000000E+000
- blue(195) = 0.545098039215686
-
-! LavenderBlush1
- red(196) = 1.00000000000000
- green(196) = 0.941176470588235
- blue(196) = 0.960784313725490
-
-! Magenta
- red(197) = 1.00000000000000
- green(197) = 0.000000000000000E+000
- blue(197) = 1.00000000000000
-
-! darkturquoise
- red(198) = 0.000000000000000E+000
- green(198) = 0.810000000000000
- blue(198) = 0.820000000000000
-
-! blueviolet
- red(199) = 0.540000000000000
- green(199) = 0.170000000000000
- blue(199) = 0.890000000000000
-
-! MintCream
- red(200) = 0.960784313725490
- green(200) = 1.00000000000000
- blue(200) = 0.980392156862745
-
-! PaleGoldenrod
- red(201) = 0.933333333333333
- green(201) = 0.909803921568627
- blue(201) = 0.666666666666667
-
-! MediumPurple
- red(202) = 0.576470588235294
- green(202) = 0.439215686274510
- blue(202) = 0.858823529411765
-
-! PapayaWhip
- red(203) = 1.00000000000000
- green(203) = 0.937254901960784
- blue(203) = 0.835294117647059
-
-! LavenderBlush4
- red(204) = 0.545098039215686
- green(204) = 0.513725490196078
- blue(204) = 0.525490196078431
-
-! Cornsilk4
- red(205) = 0.545098039215686
- green(205) = 0.533333333333333
- blue(205) = 0.470588235294118
-
-! LtGoldenrodYello
- red(206) = 0.980392156862745
- green(206) = 0.980392156862745
- blue(206) = 0.823529411764706
-
-! limegreen
- red(207) = 0.200000000000000
- green(207) = 0.800000000000000
- blue(207) = 0.200000000000000
-
-! LemonChiffon1
- red(208) = 1.00000000000000
- green(208) = 0.980392156862745
- blue(208) = 0.803921568627451
-
-! DarkOrchid
- red(209) = 0.600000000000000
- green(209) = 0.196078431372549
- blue(209) = 0.800000000000000
-
-! SlateBlue1
- red(210) = 0.513725490196078
- green(210) = 0.435294117647059
- blue(210) = 1.00000000000000
-
-! chartreuse
- red(211) = 0.500000000000000
- green(211) = 1.00000000000000
- blue(211) = 0.000000000000000E+000
-
-! PaleTurquoise
- red(212) = 0.686274509803922
- green(212) = 0.933333333333333
- blue(212) = 0.933333333333333
-
-! NavajoWhite1
- red(213) = 1.00000000000000
- green(213) = 0.870588235294118
- blue(213) = 0.678431372549020
-
-! LightSkyBlue2
- red(214) = 0.643137254901961
- green(214) = 0.827450980392157
- blue(214) = 0.933333333333333
-
-! VioletRed
- red(215) = 0.815686274509804
- green(215) = 0.125490196078431
- blue(215) = 0.564705882352941
-
-! mocassin
- red(216) = 1.00000000000000
- green(216) = 0.890000000000000
- blue(216) = 0.710000000000000
-
-! OldLace
- red(217) = 0.992156862745098
- green(217) = 0.960784313725490
- blue(217) = 0.901960784313726
-
-! deeppink
- red(218) = 1.00000000000000
- green(218) = 8.000000000000000E-002
- blue(218) = 0.580000000000000
-
-! Honeydew3
- red(219) = 0.756862745098039
- green(219) = 0.803921568627451
- blue(219) = 0.756862745098039
-
-! Gainsboro
- red(220) = 0.862745098039216
- green(220) = 0.862745098039216
- blue(220) = 0.862745098039216
-
-! DarkSalmon
- red(221) = 0.913725490196078
- green(221) = 0.588235294117647
- blue(221) = 0.478431372549020
-
-! AntiqueWhite1
- red(222) = 1.00000000000000
- green(222) = 0.937254901960784
- blue(222) = 0.858823529411765
-
-! LightCyan
- red(223) = 0.878431372549020
- green(223) = 1.00000000000000
- blue(223) = 1.00000000000000
-
-! ForestGreen
- red(224) = 0.133333333333333
- green(224) = 0.545098039215686
- blue(224) = 0.133333333333333
-
-! Orchid
- red(225) = 0.854901960784314
- green(225) = 0.439215686274510
- blue(225) = 0.839215686274510
-
-! PeachPuff2
- red(226) = 0.933333333333333
- green(226) = 0.796078431372549
- blue(226) = 0.678431372549020
-
-! LightPink
- red(227) = 1.00000000000000
- green(227) = 0.713725490196078
- blue(227) = 0.756862745098039
-
-! Sienna
- red(228) = 0.627450980392157
- green(228) = 0.321568627450980
- blue(228) = 0.176470588235294
-
-! darkorchid
- red(229) = 0.600000000000000
- green(229) = 0.200000000000000
- blue(229) = 0.800000000000000
-
-! MediumSlateBlue
- red(230) = 0.482352941176471
- green(230) = 0.407843137254902
- blue(230) = 0.933333333333333
-
-! CadetBlue
- red(231) = 0.372549019607843
- green(231) = 0.619607843137255
- blue(231) = 0.627450980392157
-
-! LawnGreen
- red(232) = 0.486274509803922
- green(232) = 0.988235294117647
- blue(232) = 0.000000000000000E+000
-
-! Chartreuse
- red(233) = 0.498039215686275
- green(233) = 1.00000000000000
- blue(233) = 0.000000000000000E+000
-
-! Brown
- red(234) = 0.647058823529412
- green(234) = 0.164705882352941
- blue(234) = 0.164705882352941
-
-! Azure
- red(235) = 0.941176470588235
- green(235) = 1.00000000000000
- blue(235) = 1.00000000000000
-
-! Bisque
- red(236) = 1.00000000000000
- green(236) = 0.894117647058824
- blue(236) = 0.768627450980392
-
- end subroutine checkgrid_setup_colorp
Deleted: seismo/2D/SPECFEM2D/trunk/compute_Bielak_conditions.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_Bielak_conditions.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_Bielak_conditions.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,237 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! compute analytical initial plane wave for Bielak's conditions
-
-subroutine compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: iglob,npoin,it
-
- double precision, intent(in) :: deltat
-
- double precision, intent(out) :: dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert
-
- double precision, dimension(NDIM,npoin), intent(in) :: coord
-
- double precision :: time_veloc,time_traction,t,x,z
-
- double precision, external :: ricker_Bielak_veloc
-
- double precision x0_source, z0_source, angleforce, angleforce_refl
- double precision c_inc, c_refl, time_offset, f0
- double precision, dimension(NDIM) :: A_plane, B_plane, C_plane
-
-
-! get the coordinates of the mesh point
- x = coord(1,iglob) - x0_source
- z = z0_source - coord(2,iglob)
-
-! times for velocity and traction are staggered i.e. separated by deltat/2.d0
- time_veloc = (it-1)*deltat + deltat/2.d0 + time_offset
- time_traction = time_veloc + deltat/2.d0
-
- t = time_traction
-
-!!$!SV30
-!!$
-!!$!analytical expression of the displacement for a SV 30 degrees and 0.3333 poisson ratio
-!!$! Ux = sqrt(3.d0)/2.d0 * rickertest(t - x/2.d0 + (9 - z) * sqrt(3.d0)/2.d0) &
-!!$! + sqrt(3.d0)/2.d0 * rickertest(t - x/2.d0 - (9 - z) * sqrt(3.d0)/2.d0) &
-!!$! + sqrt(3.d0) * rickertest(t - x/2.d0)
-!!$! Uz = - HALF * rickertest(t - x/2.d0 + (9 - z) * sqrt(3.d0)/2.d0) &
-!!$! + HALF * rickertest(t - x/2.d0 - (9 - z) * sqrt(3.d0)/2.d0)
-!!$
-!!$
-!!$! derivatives of analytical expression of horizontal and vertical displacements,
-!!$! computed using the "Mathematica" script in UTILS/deriv_ricker_spatial.m
-!!$ dxUx = (sqrt(3.d0)*a*((-8*t + 4*x)*exp(-a*(t - x/2.d0)**2) + &
-!!$ ((2*t - x)*(-2 + a*(-2*t + x)**2))*exp(-a*(t - x/2.d0)**2) + &
-!!$ (2*(-2*t + x - sqrt(3.d0)*(-9 + z)))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ ((1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (-2*t + x - sqrt(3.d0)*(-9 + z)))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (2*(-2*t + x + sqrt(3.d0)*(-9 + z)))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (-2*t + x + sqrt(3.d0)*(-9 + z)))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/4.d0
-!!$
-!!$ dzUx = (3*a*(((t + (-x + sqrt(3.d0)*(-9 + z))/2.d0)* &
-!!$ (1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) - &
-!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (t - x/2.d0 - (sqrt(3.d0)*(-9 + z))/2.d0))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (2*t - x + sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (-2*t + x + sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
-!!$
-!!$ dxUz = (a*((2*t - x - sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (-2*t + x - sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ ((1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (-2*t + x - sqrt(3.d0)*(-9 + z)))/2.d0*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) - &
-!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (-2*t + x + sqrt(3.d0)*(-9 + z)))/2.d0*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
-!!$
-!!$ dzUz = (sqrt(3.d0)*a*(((t + (-x + sqrt(3.d0)*(-9 + z))/2.d0)* &
-!!$ (1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (2*t - x - sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
-!!$ (t - x/2.d0 - (sqrt(3.d0)*(-9 + z))/2.d0))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
-!!$ (2*t - x + sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
-
-! to ompute the derivative of the displacement, we take the velocity ricker expression and we multiply by
-! the derivative of the interior argument of ricker_Bielak_veloc
-
- dxUx = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
- + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
- + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
- * (-sin(angleforce_refl)/c_refl)
-
- dzUx = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-cos(angleforce)/c_inc)&
- + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (cos(angleforce)/c_inc)&
- + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
- * (cos(angleforce_refl)/c_refl)
-
- dxUz = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
- + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
- + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
- * (-sin(angleforce_refl)/c_refl)
-
- dzUz = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-cos(angleforce)/c_inc)&
- + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (cos(angleforce)/c_inc)&
- + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
- * (cos(angleforce_refl)/c_refl)
-
- t = time_veloc
-
-!!$!SV30
-!!$! analytical expression of the two components of the velocity vector
-!!$ veloc_horiz = (sqrt(3.d0)/2.d0) * ricker_Bielak_veloc(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
-!!$ + (sqrt(3.d0)/2.d0) * ricker_Bielak_veloc(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0)) &
-!!$ + sqrt(3.d0) * ricker_Bielak_veloc(t - x/2.d0)
-!!$ veloc_vert = - HALF * ricker_Bielak_veloc(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
-!!$ + HALF * ricker_Bielak_veloc(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0))
-
- veloc_horiz = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- veloc_vert = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
-
-end subroutine compute_Bielak_conditions
-
-! ********
-
-! compute time variation of the source for analytical initial plane wave
-double precision function ricker_Bielak_integrale_displ(t,f0)
-
- implicit none
-
- include "constants.h"
-
- double precision :: t,f0,a
-
- a = pi*pi*f0*f0
-
-! Ricker
- ricker_Bielak_integrale_displ = t*exp(-a*t**2)
-
-end function ricker_Bielak_integrale_displ
-
-! ********
-
-! compute time variation of the source for analytical initial plane wave
-double precision function ricker_Bielak_displ(t,f0)
-
- implicit none
-
- include "constants.h"
-
- double precision :: t,f0,a
-
- a = pi*pi*f0*f0
-
-! Ricker
- ricker_Bielak_displ = (1 - 2*a*t**2)*exp(-a*t**2)
-
-end function ricker_Bielak_displ
-
-! *******
-
-! compute time variation of the source for analytical initial plane wave
-double precision function ricker_Bielak_veloc(t,f0)
-
- implicit none
-
- include "constants.h"
-
- double precision :: t,f0,a
-
- a = pi*pi*f0*f0
-
-! first time derivative of a Ricker
- ricker_Bielak_veloc = - 2*a*t*(3 - 2*a*t**2)*exp(-a*t**2)
-
-end function ricker_Bielak_veloc
-
-! *******
-
-! compute time variation of the source for analytical initial plane wave
-double precision function ricker_Bielak_accel(t,f0)
-
- implicit none
-
- include "constants.h"
-
- double precision :: t,f0,a
-
- a = pi*pi*f0*f0
-
-! second time derivative of a Ricker
- ricker_Bielak_accel = - 2*a*(3 - 12*a*t**2 + 4*a**2*t**4)* exp(-a*t**2)
-
-end function ricker_Bielak_accel
-
Deleted: seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,190 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
- Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer ispec_selected_source
- integer nspec
-
- double precision xi_source,gamma_source
- double precision Mxx,Mzz,Mxz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
-
- double precision xixd,xizd,gammaxd,gammazd
-
-! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLZ) :: zigll
-
-! source arrays
- double precision, dimension(NGLLX,NGLLZ) :: G11,G13,G31,G33
- double precision, dimension(NGLLX) :: hxis,hpxis
- double precision, dimension(NGLLZ) :: hgammas,hpgammas
-
- integer k,m
- integer ir,iv
-
-! calculate G_ij for general source location
-! the source does not necessarily correspond to a Gauss-Lobatto point
- do m=1,NGLLZ
- do k=1,NGLLX
-
- xixd = xix(k,m,ispec_selected_source)
- xizd = xiz(k,m,ispec_selected_source)
- gammaxd = gammax(k,m,ispec_selected_source)
- gammazd = gammaz(k,m,ispec_selected_source)
-
- G11(k,m) = Mxx*xixd+Mxz*xizd
- G13(k,m) = Mxx*gammaxd+Mxz*gammazd
- G31(k,m) = Mxz*xixd+Mzz*xizd
- G33(k,m) = Mxz*gammaxd+Mzz*gammazd
-
-!!!! G21(k,m) = Mxy*xixd+Myz*xizd
-!!!! G23(k,m) = Mxy*gammaxd+Myz*gammazd
-
- enddo
- enddo
-
-! compute Lagrange polynomials at the source location
- call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
- call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
-
-! calculate source array
- do m=1,NGLLZ
- do k=1,NGLLX
-
- sourcearray(:,k,m) = ZERO
-
- do iv=1,NGLLZ
- do ir=1,NGLLX
-
- sourcearray(1,k,m) = sourcearray(1,k,m) + hxis(ir)*hgammas(iv) &
- *(G11(ir,iv)*hpxis(k)*hgammas(m) &
- +G13(ir,iv)*hxis(k)*hpgammas(m))
-
-! sourcearray(2,k,m) = sourcearray(2,k,m) + hxis(ir)*hgammas(iv) &
-! *(G21(ir,iv)*hpxis(k)*hgammas(m) &
-! +G23(ir,iv)*hxis(k)*hpgammas(m))
-
- sourcearray(2,k,m) = sourcearray(2,k,m) + hxis(ir)*hgammas(iv) &
- *(G31(ir,iv)*hpxis(k)*hgammas(m) &
- +G33(ir,iv)*hxis(k)*hpgammas(m))
-
- enddo
- enddo
-
- enddo
- enddo
-
- end subroutine compute_arrays_source
-
-! ------------------------------------------------------------------------------------------------------
-
-
- subroutine compute_arrays_adj_source(adj_source_file,xi_receiver,gamma_receiver,adj_sourcearray, &
- xigll,zigll,NSTEP)
-
- implicit none
-
- include 'constants.h'
-
-! input
- integer NSTEP
-
- double precision xi_receiver, gamma_receiver
-
- character(len=*) adj_source_file
-
-! output
- real(kind=CUSTOM_REAL), dimension(NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearray
-
-! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLZ) :: zigll
-
-
- double precision :: hxir(NGLLX), hpxir(NGLLX), hgammar(NGLLZ), hpgammar(NGLLZ)
- real(kind=CUSTOM_REAL) :: adj_src_s(NSTEP,3)
-
- integer icomp, itime, i, k, ios
- double precision :: junk
- character(len=3) :: comp(3)
- character(len=150) :: filename
-
- call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
- call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
-
- adj_sourcearray(:,:,:,:) = 0.
-
- comp = (/"BHX","BHY","BHZ"/)
-
- do icomp = 1,3
-
- filename = 'OUTPUT_FILES/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
- open(unit = IIN, file = trim(filename), iostat = ios)
- if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')
-
- do itime = 1, NSTEP
- read(IIN,*) junk, adj_src_s(itime,icomp)
- enddo
- close(IIN)
-
- enddo
-
- do k = 1, NGLLZ
- do i = 1, NGLLX
- adj_sourcearray(:,:,i,k) = hxir(i) * hgammar(k) * adj_src_s(:,:)
- enddo
- enddo
-
-
-end subroutine compute_arrays_adj_source
Deleted: seismo/2D/SPECFEM2D/trunk/compute_curl_one_element.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_curl_one_element.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_curl_one_element.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,164 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_curl_one_element(curl_element,displ_elastic, &
- displs_poroelastic,elastic,poroelastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
- nspec,npoin_elastic,npoin_poroelastic,ispec)
-
- ! compute curl in (poro)elastic elements (for rotational study)
-
- implicit none
-
- include "constants.h"
-
- integer nspec,ispec
-
- integer, dimension(NGLLX,NGLLX,nspec) :: ibool
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
- ! curl in this element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
-
- logical, dimension(nspec) :: elastic,poroelastic
-
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic
-
- ! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
- ! local variables
- integer :: i,j,k
-
- ! jacobian
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
-
- ! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
- real(kind=CUSTOM_REAL) :: duz_dxl,dux_dzl
-
- if(elastic(ispec)) then
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- ! derivative along x and along z
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- ! derivatives of displacement
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
-
- ! store pressure
- curl_element(i,j) = - 0.5d0 * (dux_dzl - duz_dxl)
-
- enddo
- enddo
-
- elseif(poroelastic(ispec)) then
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- ! derivative along x and along z
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- ! derivatives of displacement
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
-
- ! store pressure
- curl_element(i,j) = - 0.5d0 * (dux_dzl - duz_dxl)
-
- enddo
- enddo
-
- else
-
- call exit_MPI('no curl in acoustic')
-
- endif ! end of test if acoustic or elastic element
-
-end subroutine compute_curl_one_element
-
Deleted: seismo/2D/SPECFEM2D/trunk/compute_energy.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_energy.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_energy.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,403 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_energy(displ_elastic,veloc_elastic, &
- displs_poroelastic,velocs_poroelastic, &
- displw_poroelastic,velocw_poroelastic, &
- xix,xiz,gammax,gammaz,jacobian,ibool, &
- elastic,poroelastic,hprime_xx,hprime_zz, &
- nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- assign_external_model,it,deltat,t0,kmato,poroelastcoef,density, &
- porosity,tortuosity, &
- vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext, &
- anisotropic,anisotropy,wxgll,wzgll,numat, &
- pressure_element,vector_field_element,e1,e11, &
- potential_dot_acoustic,potential_dot_dot_acoustic, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS,p_sv)
-
-! compute kinetic and potential energy in the solid (acoustic elements are excluded)
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,numat
-
-! vector field in an element
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
-
-! pressure in an element
- integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
-
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: &
- potential_dot_acoustic,potential_dot_dot_acoustic
-
- logical :: TURN_ATTENUATION_ON,p_sv
-
- integer :: it
- double precision :: t0,deltat
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- logical, dimension(nspec) :: elastic,poroelastic,anisotropic
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- integer, dimension(nspec) :: kmato
- logical :: assign_external_model
- double precision, dimension(2,numat) :: density
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(6,numat) :: anisotropy
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
- double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext, &
- c33ext,c35ext,c55ext
-
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic,veloc_elastic
-
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,velocs_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displw_poroelastic,velocw_poroelastic
-
-! Gauss-Lobatto-Legendre points and weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
-! local variables
- integer :: i,j,k,ispec
-
-! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
- real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
- real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
-
-! jacobian
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
- real(kind=CUSTOM_REAL) :: kinetic_energy,potential_energy
- real(kind=CUSTOM_REAL) :: cpl,csl,rhol,mul_relaxed,lambdal_relaxed, &
- lambdalplus2mul_relaxed,kappal
- real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
- real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
- real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
- real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
- real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
-
- kinetic_energy = ZERO
- potential_energy = ZERO
-
-! loop over spectral elements
- do ispec = 1,nspec
-
- !---
- !--- elastic spectral element
- !---
- if(elastic(ispec)) then
-
- ! checks wave type
- if( .not. p_sv ) then
- call exit_MPI('output energy for SH waves not implemented yet')
- endif
-
- ! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec))
- rhol = density(1,kmato(ispec))
-
- ! double loop over GLL points
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- !--- if external medium, get elastic parameters of current grid point
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- csl = vsext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- mul_relaxed = rhol*csl*csl
- lambdal_relaxed = rhol*cpl*cpl - TWO*mul_relaxed
- lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
- endif
-
- ! derivative along x and along z
- dux_dxi = 0._CUSTOM_REAL
- duz_dxi = 0._CUSTOM_REAL
-
- dux_dgamma = 0._CUSTOM_REAL
- duz_dgamma = 0._CUSTOM_REAL
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
- jacobianl = jacobian(i,j,ispec)
-
- ! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- ! compute kinetic energy
- kinetic_energy = kinetic_energy &
- + rhol*(veloc_elastic(1,ibool(i,j,ispec))**2 &
- + veloc_elastic(3,ibool(i,j,ispec))**2) *wxgll(i)*wzgll(j)*jacobianl / TWO
-
- ! compute potential energy
- potential_energy = potential_energy &
- + (lambdalplus2mul_relaxed*dux_dxl**2 &
- + lambdalplus2mul_relaxed*duz_dzl**2 &
- + two*lambdal_relaxed*dux_dxl*duz_dzl &
- + mul_relaxed*(dux_dzl + duz_dxl)**2)*wxgll(i)*wzgll(j)*jacobianl / TWO
-
- enddo
- enddo
-
- !---
- !--- poroelastic spectral element
- !---
- elseif(poroelastic(ispec)) then
-
- ! get relaxed elastic parameters of current spectral element
- !for now replaced by solid, fluid, and frame parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- !solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
- rhol_s = density(1,kmato(ispec))
- !fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
- !frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
- rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
- !Biot coefficients for the input phi
- D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
- + kappal_fr + FOUR_THIRDS*mul_fr
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
- !The RHS has the form : div T -phi/c div T_f + phi/ceta_fk^-1.partial t w
- !where T = G:grad u_s + C div w I
- !and T_f = C div u_s I + M div w I
- !we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
- mul_G = mul_fr
- lambdal_G = H_biot - TWO*mul_fr
- lambdalplus2mul_G = lambdal_G + TWO*mul_G
-
- ! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- ! derivative along x and along z
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
- jacobianl = jacobian(i,j,ispec)
-
- ! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
-
- dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
- ! compute potential energy
- potential_energy = potential_energy &
- + ( lambdalplus2mul_G*dux_dxl**2 &
- + lambdalplus2mul_G*duz_dzl**2 &
- + two*lambdal_G*dux_dxl*duz_dzl + mul_G*(dux_dzl + duz_dxl)**2 &
- + two*C_biot*dwx_dxl*dux_dxl + two*C_biot*dwz_dzl*duz_dzl &
- + two*C_biot*(dwx_dxl*duz_dzl + dwz_dzl*dux_dxl) &
- + M_biot*dwx_dxl**2 + M_biot*dwz_dzl**2 &
- + two*M_biot*dwx_dxl*dwz_dzl )*wxgll(i)*wzgll(j)*jacobianl / TWO
-
- ! compute kinetic energy
- if(phil > 0.0d0) then
- kinetic_energy = kinetic_energy &
- + ( rhol_bar*(velocs_poroelastic(1,ibool(i,j,ispec))**2 &
- + velocs_poroelastic(2,ibool(i,j,ispec))**2) &
- + rhol_f*tortl/phil*(velocw_poroelastic(1,ibool(i,j,ispec))**2 &
- + velocw_poroelastic(2,ibool(i,j,ispec))**2) &
- + rhol_f*(velocs_poroelastic(1,ibool(i,j,ispec))*velocw_poroelastic(1,ibool(i,j,ispec)) &
- + velocs_poroelastic(2,ibool(i,j,ispec))*velocw_poroelastic(2,ibool(i,j,ispec))) &
- )*wxgll(i)*wzgll(j)*jacobianl / TWO
- else
- kinetic_energy = kinetic_energy &
- + rhol_s*(velocs_poroelastic(1,ibool(i,j,ispec))**2 &
- + velocs_poroelastic(2,ibool(i,j,ispec))**2)*wxgll(i)*wzgll(j)*jacobianl / TWO
- endif
- enddo
- enddo
-
- !---
- !--- acoustic spectral element
- !---
- else
-
- ! for the definition of potential energy in an acoustic fluid, see for instance
- ! equation (23) of M. Maess et al., Journal of Sound and Vibration 296 (2006) 264-276
-
- ! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
- ! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
- ! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
- ! This permits acoustic-elastic coupling based on a non-iterative time scheme.
- ! Displacement is then: u = grad(Chi) / rho
- ! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
- ! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
-
- ! compute pressure in this element
- call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic, &
- displs_poroelastic,displw_poroelastic,elastic,poroelastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
- npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
-
- ! compute velocity vector field in this element
- call compute_vector_one_element(vector_field_element,potential_dot_acoustic, &
- veloc_elastic,velocs_poroelastic, &
- elastic,poroelastic,xix,xiz,gammax,gammaz, &
- ibool,hprime_xx,hprime_zz, &
- nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- ispec,numat,kmato,density,rhoext,assign_external_model)
-
- ! get density of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- rhol = density(1,kmato(ispec))
- kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
- cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
-
- ! double loop over GLL points
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- !--- if external medium, get density of current grid point
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
-
- jacobianl = jacobian(i,j,ispec)
-
- ! compute kinetic energy
- kinetic_energy = kinetic_energy &
- + rhol*(vector_field_element(1,i,j)**2 &
- + vector_field_element(2,i,j)**2) *wxgll(i)*wzgll(j)*jacobianl / TWO
-
- ! compute potential energy
- potential_energy = potential_energy &
- + (pressure_element(i,j)**2)*wxgll(i)*wzgll(j)*jacobianl / (TWO * rhol * cpl**2)
-
- enddo
- enddo
-
- endif
-
- enddo
-
- ! save kinetic, potential and total energy for this time step in external file
- write(IOUT_ENERGY,*) real(dble(it-1)*deltat - t0,4),real(kinetic_energy,4), &
- real(potential_energy,4),real(kinetic_energy + potential_energy,4)
-
- end subroutine compute_energy
-
Deleted: seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,762 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_forces_acoustic(npoin,nspec,nelemabs,numat,it,NSTEP, &
- anyabs,assign_external_model,ibool,kmato,numabs, &
- elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,b_potential_dot_dot_acoustic,b_potential_acoustic, &
- density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
- vpext,rhoext,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll, &
- ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right,SIMULATION_TYPE,SAVE_FORWARD,b_absorb_acoustic_left,&
- b_absorb_acoustic_right,b_absorb_acoustic_bottom,&
- b_absorb_acoustic_top,nspec_xmin,nspec_xmax,&
- nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top)
-
-! compute forces for the acoustic elements
-
- implicit none
-
- include "constants.h"
-
- integer :: npoin,nspec,nelemabs,numat,it,NSTEP,SIMULATION_TYPE
-
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(nelemabs) :: ib_left
- integer, dimension(nelemabs) :: ib_right
- integer, dimension(nelemabs) :: ib_bottom
- integer, dimension(nelemabs) :: ib_top
-
- logical :: anyabs,assign_external_model
- logical :: SAVE_FORWARD
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: kmato
- integer, dimension(nelemabs) :: numabs,ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right
-
- logical, dimension(nspec) :: elastic,poroelastic
- logical, dimension(4,nelemabs) :: codeabs
-
- real(kind=CUSTOM_REAL), dimension(npoin) :: &
- potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin) :: &
- b_potential_dot_dot_acoustic,b_potential_acoustic
- double precision, dimension(2,numat) :: density
- double precision, dimension(4,3,numat) :: poroelastcoef
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
-
- double precision, dimension(NGLLZ,nspec_xmin,NSTEP) :: b_absorb_acoustic_left
- double precision, dimension(NGLLZ,nspec_xmax,NSTEP) :: b_absorb_acoustic_right
- double precision, dimension(NGLLX,nspec_zmax,NSTEP) :: b_absorb_acoustic_top
- double precision, dimension(NGLLX,nspec_zmin,NSTEP) :: b_absorb_acoustic_bottom
-
-! derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-
-! Gauss-Lobatto-Legendre weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-!---
-!--- local variables
-!---
-
- integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend
-
-! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,dux_dxl,dux_dzl
- real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_dux_dxl,b_dux_dzl
- real(kind=CUSTOM_REAL) :: weight,xxi,zxi,xgamma,zgamma,jacobian1D
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2
-
-! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,kappal,cpl,rhol
-
- integer :: ifirstelem,ilastelem
-
- ifirstelem = 1
- ilastelem = nspec
-
-! loop over spectral elements
- do ispec = ifirstelem,ilastelem
-
-!---
-!--- acoustic spectral element
-!---
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
-
- rhol = density(1,kmato(ispec))
-
-! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
-! derivative along x and along z
- dux_dxi = ZERO
- dux_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = ZERO
- b_dux_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = b_dux_dxi + b_potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
- b_dux_dgamma = b_dux_dgamma + b_potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
-! derivatives of potential
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
- endif
-
- jacobianl = jacobian(i,j,ispec)
-
-! if external density model
- if(assign_external_model) rhol = rhoext(i,j,ispec)
-
-! for acoustic medium
-! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl) / rhol
- tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl) / rhol
-
- if(SIMULATION_TYPE == 2) then
- b_tempx1(i,j) = wzgll(j)*jacobianl*(xixl*b_dux_dxl + xizl*b_dux_dzl) /rhol
- b_tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*b_dux_dxl + gammazl*b_dux_dzl) /rhol
- endif
-
- enddo
- enddo
-
-!
-! second double-loop over GLL to compute all the terms
-!
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
-! along x direction and z direction
-! and assemble the contributions
- do k = 1,NGLLX
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - &
- (tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
-
- if(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
- (b_tempx1(k,j)*hprimewgll_xx(k,i) + b_tempx2(i,k)*hprimewgll_zz(k,j))
- endif
- enddo
-
- enddo ! second loop over the GLL points
- enddo
-
- endif ! end of test if acoustic element
-
- enddo ! end of loop over all spectral elements
-
-!
-!--- absorbing boundaries
-!
- if(anyabs) then
-
- do ispecabs=1,nelemabs
-
- ispec = numabs(ispecabs)
-
-! get elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
- rhol = density(1,kmato(ispec))
-
- cpl = sqrt(kappal/rhol)
-
-!--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
-
- i = 1
-
- jbegin = jbegin_left(ispecabs)
- jend = jend_left(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
-! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
-
- xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
-
- weight = jacobian1D * wzgll(j)
-
-! Sommerfeld condition if acoustic
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob)*weight/cpl/rhol
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- b_absorb_acoustic_left(j,ib_left(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = &
- b_potential_dot_dot_acoustic(iglob) - &
- b_absorb_acoustic_left(j,ib_left(ispecabs),NSTEP-it+1)
- endif
- endif
-
- enddo
-
- endif ! end of left absorbing boundary
-
-!--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
-
- i = NGLLX
-
- jbegin = jbegin_right(ispecabs)
- jend = jend_right(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
-! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
-
- xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
-
- weight = jacobian1D * wzgll(j)
-
-! Sommerfeld condition if acoustic
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
-
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- b_absorb_acoustic_right(j,ib_right(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = &
- b_potential_dot_dot_acoustic(iglob) - &
- b_absorb_acoustic_right(j,ib_right(ispecabs),NSTEP-it+1)
- endif
- endif
-
- enddo
-
- endif ! end of right absorbing boundary
-
-!--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
-
- j = 1
-
- ibegin = ibegin_bottom(ispecabs)
- iend = iend_bottom(ispecabs)
-
-! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
-! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
-
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xxi**2 + zxi**2)
-
- weight = jacobian1D * wxgll(i)
-
-! Sommerfeld condition if acoustic
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = &
- b_potential_dot_dot_acoustic(iglob) - &
- b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),NSTEP-it+1)
- endif
- endif
-
- enddo
-
- endif ! end of bottom absorbing boundary
-
-!--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
-
- j = NGLLZ
-
- ibegin = ibegin_top(ispecabs)
- iend = iend_top(ispecabs)
-
-! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
-! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
-
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xxi**2 + zxi**2)
-
- weight = jacobian1D * wxgll(i)
-
-! Sommerfeld condition if acoustic
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- b_absorb_acoustic_top(i,ib_top(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = &
- b_potential_dot_dot_acoustic(iglob) - &
- b_absorb_acoustic_top(i,ib_top(ispecabs),NSTEP-it+1)
- endif
- endif
-
- enddo
-
- endif ! end of top absorbing boundary
-
- enddo
-
- endif ! end of absorbing boundaries
-
- end subroutine compute_forces_acoustic
-
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine compute_forces_acoustic_2(npoin,nspec,nelemabs,numat,it,NSTEP, &
- anyabs,assign_external_model,ibool,kmato,numabs, &
- elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic, &
- density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
- vpext,rhoext,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll, &
- ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right, &
- SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
- nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
- b_absorb_acoustic_left,b_absorb_acoustic_right, &
- b_absorb_acoustic_bottom,b_absorb_acoustic_top)
-
-! compute forces for the acoustic elements
-
- implicit none
-
- include "constants.h"
-
- integer :: npoin,nspec,nelemabs,numat,it,NSTEP,SIMULATION_TYPE
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: kmato
- integer, dimension(nelemabs) :: numabs,ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right
-
- logical, dimension(nspec) :: elastic,poroelastic
- logical, dimension(4,nelemabs) :: codeabs
-
- real(kind=CUSTOM_REAL), dimension(npoin) :: &
- potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
-
- double precision, dimension(2,numat) :: density
- double precision, dimension(4,3,numat) :: poroelastcoef
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
-
- logical :: anyabs,assign_external_model
- logical :: SAVE_FORWARD
-
-! derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-
-! Gauss-Lobatto-Legendre weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(nelemabs) :: ib_left
- integer, dimension(nelemabs) :: ib_right
- integer, dimension(nelemabs) :: ib_bottom
- integer, dimension(nelemabs) :: ib_top
-
- double precision, dimension(NGLLZ,nspec_xmin,NSTEP) :: b_absorb_acoustic_left
- double precision, dimension(NGLLZ,nspec_xmax,NSTEP) :: b_absorb_acoustic_right
- double precision, dimension(NGLLX,nspec_zmax,NSTEP) :: b_absorb_acoustic_top
- double precision, dimension(NGLLX,nspec_zmin,NSTEP) :: b_absorb_acoustic_bottom
-
-!---
-!--- local variables
-!---
-
- integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend
-
-! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,dux_dxl,dux_dzl
- real(kind=CUSTOM_REAL) :: weight,xxi,zxi,xgamma,zgamma,jacobian1D
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2
-
-! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,kappal,cpl,rhol
-
- integer :: ifirstelem,ilastelem
-
- ifirstelem = 1
- ilastelem = nspec
-
-! loop over spectral elements
- do ispec = ifirstelem,ilastelem
-
-!---
-!--- acoustic spectral element
-!---
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
-
- rhol = density(1,kmato(ispec))
-
- ! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- ! derivative along x and along z
- dux_dxi = ZERO
- dux_dgamma = ZERO
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- ! derivatives of potential
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
- jacobianl = jacobian(i,j,ispec)
-
- ! if external density model
- if(assign_external_model) rhol = rhoext(i,j,ispec)
-
- ! for acoustic medium
- ! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl) / rhol
- tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl) / rhol
- enddo
- enddo
-
-!
-! second double-loop over GLL to compute all the terms
-!
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- ! along x direction and z direction
- ! and assemble the contributions
- do k = 1,NGLLX
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - &
- (tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
- enddo
-
- enddo ! second loop over the GLL points
- enddo
-
- endif ! end of test if acoustic element
-
- enddo ! end of loop over all spectral elements
-
-!
-!--- absorbing boundaries
-!
- if(anyabs) then
-
- do ispecabs=1,nelemabs
-
- ispec = numabs(ispecabs)
-
- ! Sommerfeld condition if acoustic
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
-
- ! get elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
- rhol = density(1,kmato(ispec))
-
- cpl = sqrt(kappal/rhol)
-
- !--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
- i = 1
- jbegin = jbegin_left(ispecabs)
- jend = jend_left(ispecabs)
- do j = jbegin,jend
- iglob = ibool(i,j,ispec)
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
- xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- weight = jacobian1D * wzgll(j)
-
- if( SIMULATION_TYPE == 1 ) then
- ! adds absorbing boundary contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- ! adds (previously) stored contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - b_absorb_acoustic_left(j,ib_left(ispecabs),NSTEP-it+1)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- ! saves contribution
- b_absorb_acoustic_left(j,ib_left(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- endif
-
- enddo
-
- endif ! end of left absorbing boundary
-
- !--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
- i = NGLLX
- jbegin = jbegin_right(ispecabs)
- jend = jend_right(ispecabs)
- do j = jbegin,jend
- iglob = ibool(i,j,ispec)
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
- xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- weight = jacobian1D * wzgll(j)
-
- if( SIMULATION_TYPE == 1 ) then
- ! adds absorbing boundary contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - b_absorb_acoustic_right(j,ib_right(ispecabs),NSTEP-it+1)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- ! saves contribution
- b_absorb_acoustic_right(j,ib_right(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- endif
- enddo
- endif ! end of right absorbing boundary
-
- !--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
- j = 1
- ibegin = ibegin_bottom(ispecabs)
- iend = iend_bottom(ispecabs)
- ! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
- do i = ibegin,iend
- iglob = ibool(i,j,ispec)
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- weight = jacobian1D * wxgll(i)
-
- if( SIMULATION_TYPE == 1 ) then
- ! adds absorbing boundary contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),NSTEP-it+1)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- ! saves contribution
- b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- endif
- enddo
- endif ! end of bottom absorbing boundary
-
- !--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
- j = NGLLZ
- ibegin = ibegin_top(ispecabs)
- iend = iend_top(ispecabs)
- ! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
- do i = ibegin,iend
- iglob = ibool(i,j,ispec)
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- weight = jacobian1D * wxgll(i)
-
- if( SIMULATION_TYPE == 1 ) then
- ! adds absorbing boundary contribution
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - potential_dot_acoustic(iglob)*weight/cpl/rhol
- elseif(SIMULATION_TYPE == 2) then
- potential_dot_dot_acoustic(iglob) = &
- potential_dot_dot_acoustic(iglob) &
- - b_absorb_acoustic_top(i,ib_top(ispecabs),NSTEP-it+1)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- ! saves contribution
- b_absorb_acoustic_top(i,ib_top(ispecabs),it) = &
- potential_dot_acoustic(iglob)*weight/cpl/rhol
- endif
- enddo
- endif ! end of top absorbing boundary
-
- endif ! acoustic ispec
- enddo
- endif ! end of absorbing boundaries
-
- end subroutine compute_forces_acoustic_2
-
Deleted: seismo/2D/SPECFEM2D/trunk/compute_forces_poro_fluid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_forces_poro_fluid.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_forces_poro_fluid.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,940 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.3
-! ------------------------------
-!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_forces_poro_fluid(npoin,nspec,myrank,nelemabs,numat, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
- source_type,it,NSTEP,anyabs, &
- initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
- accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
- b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
- density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
- jacobian,source_time_function,sourcearray,adj_sourcearrays,e11, &
- e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
- dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
- phi_nu2,Mu_nu2,N_SLS, &
- rx_viscous,rz_viscous,theta_e,theta_s,&
- b_viscodampx,b_viscodampz,&
- ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
- jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
- C_k,M_k,NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD,&
- b_absorb_poro_w_left,b_absorb_poro_w_right,b_absorb_poro_w_bottom,b_absorb_poro_w_top,&
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,f0,freq0,Q0)
-
-! compute forces for the fluid poroelastic part
-
- implicit none
-
- include "constants.h"
- integer :: NSOURCES, i_source
- integer, dimension(NSOURCES) ::ispec_selected_source,source_type,is_proc_source
- integer :: npoin,nspec,nelemabs,numat,it,NSTEP
- integer :: nrec,SIMULATION_TYPE,myrank
- integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(nelemabs) :: ib_left
- integer, dimension(nelemabs) :: ib_right
- integer, dimension(nelemabs) :: ib_bottom
- integer, dimension(nelemabs) :: ib_top
-
- logical :: anyabs,initialfield,TURN_ATTENUATION_ON
- logical :: SAVE_FORWARD
-
- double precision ::deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: kmato
- integer, dimension(nelemabs) :: numabs,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
- ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro
-
- logical, dimension(nspec) :: poroelastic
- logical, dimension(4,nelemabs) :: codeabs
-
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: accelw_poroelastic,velocw_poroelastic,displw_poroelastic,&
- displs_poroelastic,velocs_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic
- double precision, dimension(2,numat) :: density
- double precision, dimension(3,numat) :: permeability
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(4,3,numat) :: poroelastcoef
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
- real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
- real(kind=CUSTOM_REAL), dimension(npoin) :: C_k,M_k
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_poro_w_left
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_poro_w_right
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmax,NSTEP) :: b_absorb_poro_w_top
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmin,NSTEP) :: b_absorb_poro_w_bottom
- real(kind=CUSTOM_REAL), dimension(npoin) :: b_viscodampx,b_viscodampz
-
- integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e11,e13
- double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu2,phi_nu2
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu2
- real(kind=CUSTOM_REAL) :: e11_sum,e13_sum
- integer :: i_sls
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: &
- dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
-
-! viscous attenuation
- double precision, dimension(NGLLX,NGLLZ,nspec) :: rx_viscous
- double precision, dimension(NGLLX,NGLLZ,nspec) :: rz_viscous
- double precision :: theta_e,theta_s
- logical TURN_VISCATTENUATION_ON
- double precision, dimension(3):: bl_unrelaxed,bl_relaxed
-
-! derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-
-! Gauss-Lobatto-Legendre weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-!
- double precision :: f0,freq0,Q0,w_c
-
-
-!---
-!--- local variables
-!---
-
- integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend,irec,irec_local
-
-! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
- real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
- real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
- real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
- real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
- real(kind=CUSTOM_REAL) :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
- real(kind=CUSTOM_REAL) :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
- real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xz,sigma_zz
- real(kind=CUSTOM_REAL) :: sigmap
- real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xz,b_sigma_zz
- real(kind=CUSTOM_REAL) :: b_sigmap
- real(kind=CUSTOM_REAL) :: nx,nz,vx,vz,vn,vxf,vzf,vnf,rho_vpI,rho_vpII,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1p,tempx2p,tempz1p,tempz2p
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempz1,b_tempz2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1p,b_tempx2p,b_tempz1p,b_tempz2p
-
-
-! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the poroelastic medium
- real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
- real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
- real(kind=CUSTOM_REAL) :: etal_f,kappal_f,rhol_f
- real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl,viscodampx,viscodampz
- real(kind=CUSTOM_REAL) :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
- real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
-
- real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
- real(kind=CUSTOM_REAL) :: cpIsquare,cpIIsquare,cssquare,cpIl,cpIIl,csl
-
-! for attenuation
- real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
-
-! compute Grad(displs_poroelastic) at time step n for attenuation
- if(TURN_ATTENUATION_ON) call compute_gradient_attenuation(displs_poroelastic,dux_dxl_n,duz_dxl_n, &
- dux_dzl_n,duz_dzl_n,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
-
-! loop over spectral elements
- do ispec = 1,nspec
-
-!---
-!--- poroelastic spectral element
-!---
-
- if(poroelastic(ispec)) then
-
-! get poroelastic properties of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) -4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
- rhol_s = density(1,kmato(ispec))
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
-!frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-!Biot coefficients for the input phi
- D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
- kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
-!The RHS has the form : div T_f -rho_f/rho_bar div T - eta_fk^-1.partial t w
-!where T = G:grad u_s + C_biot div w I
-!and T_f = C_biot div u_s I + M_biot div w I
- mul_G = mul_fr
- lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
- lambdalplus2mul_G = lambdal_G + TWO*mul_G
-
-! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
-
-! derivative along x and along z for u_s and w
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
-
- b_dwx_dxi = ZERO
- b_dwz_dxi = ZERO
-
- b_dwx_dgamma = ZERO
- b_dwz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
-
- dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
-
- b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
- b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
-
- b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
- b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
- endif
-
-! compute stress tensor (include attenuation if needed)
-
- if(TURN_ATTENUATION_ON) then
-! Dissipation only controlled by frame share attenuation in poroelastic (see Morency & Tromp, GJI 2008).
-! attenuation is implemented following the memory variable formulation of
-! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
-! vol. 58(1), p. 110-120 (1993). More details can be found in
-! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
-! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
-
-! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_G + mul_G) - mul_G * Mu_nu2(i,j,ispec)
- mul_unrelaxed = mul_G * Mu_nu2(i,j,ispec)
- lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
-
-! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
- sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
-
-! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
-! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
- e11_sum = 0._CUSTOM_REAL
- e13_sum = 0._CUSTOM_REAL
-
- do i_sls = 1,N_SLS
- e11_sum = e11_sum + e11(i,j,ispec,i_sls)
- e13_sum = e13_sum + e13(i,j,ispec,i_sls)
- enddo
-
- sigma_xx = sigma_xx + TWO * mul_G * e11_sum
- sigma_xz = sigma_xz + mul_G * e13_sum
- sigma_zz = sigma_zz - TWO * mul_G * e11_sum
-
- else
-
-! no attenuation
- sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = mul_G*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
- b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
-
- b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
- endif
- endif
-
-! kernels calculation
- if(SIMULATION_TYPE == 2) then
- iglob = ibool(i,j,ispec)
- C_k(iglob) = ((dux_dxl + duz_dzl) * (b_dwx_dxl + b_dwz_dzl) + &
- (dwx_dxl + dwz_dzl) * (b_dux_dxl + b_duz_dzl)) * C_biot
- M_k(iglob) = (dwx_dxl + dwz_dzl) * (b_dwx_dxl + b_dwz_dzl) * M_biot
- endif
-
- jacobianl = jacobian(i,j,ispec)
-
-! weak formulation term based on stress tensor (non-symmetric form)
-! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
- tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
-
- tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
- tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
-
- tempx1p(i,j) = wzgll(j)*jacobianl*sigmap*xixl
- tempz1p(i,j) = wzgll(j)*jacobianl*sigmap*xizl
-
- tempx2p(i,j) = wxgll(i)*jacobianl*sigmap*gammaxl
- tempz2p(i,j) = wxgll(i)*jacobianl*sigmap*gammazl
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
- b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
-
- b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
- b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
-
- b_tempx1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xixl
- b_tempz1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xizl
-
- b_tempx2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammaxl
- b_tempz2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammazl
- endif
-
- enddo
- enddo
-
-!
-! second double-loop over GLL to compute all the terms
-!
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
-! along x direction and z direction
-! and assemble the contributions
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) + ( (rhol_f/rhol_bar*tempx1(k,j) - tempx1p(k,j)) &
- *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*tempx2(i,k) - tempx2p(i,k))*hprimewgll_zz(k,j) )
-
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + ( (rhol_f/rhol_bar*tempz1(k,j) - tempz1p(k,j)) &
- *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*tempz2(i,k) - tempz2p(i,k))*hprimewgll_zz(k,j) )
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) + ( (rhol_f/rhol_bar*b_tempx1(k,j) - b_tempx1p(k,j)) &
- *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*b_tempx2(i,k) - b_tempx2p(i,k))*hprimewgll_zz(k,j) )
-
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + ( (rhol_f/rhol_bar*b_tempz1(k,j) - b_tempz1p(k,j)) &
- *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*b_tempz2(i,k) - b_tempz2p(i,k))*hprimewgll_zz(k,j) )
- endif
-
- enddo
-
- enddo ! second loop over the GLL points
- enddo
-
- endif ! end of test if poroelastic element
-
- enddo ! end of loop over all spectral elements
-
-!
-!---- viscous damping
-!
-! add - eta_f k^-1 dot(w)
-
-! loop over spectral elements
- do ispec = 1,nspec
-
- etal_f = poroelastcoef(2,2,kmato(ispec))
-
- if(poroelastic(ispec) .and. etal_f > 0.d0) then
-
- permlxx = permeability(1,kmato(ispec))
- permlxz = permeability(2,kmato(ispec))
- permlzz = permeability(3,kmato(ispec))
-
-! calcul of the inverse of k
- detk = permlxx*permlzz - permlxz*permlxz
-
- if(detk /= ZERO) then
- invpermlxx = permlzz/detk
- invpermlxz = -permlxz/detk
- invpermlzz = permlxx/detk
- else
- stop 'Permeability matrix is not invertible'
- endif
-
-! relaxed viscous coef
- bl_relaxed(1) = etal_f*invpermlxx
- bl_relaxed(2) = etal_f*invpermlxz
- bl_relaxed(3) = etal_f*invpermlzz
-
- if(TURN_VISCATTENUATION_ON) then
- bl_unrelaxed(1) = etal_f*invpermlxx*theta_e/theta_s
- bl_unrelaxed(2) = etal_f*invpermlxz*theta_e/theta_s
- bl_unrelaxed(3) = etal_f*invpermlzz*theta_e/theta_s
- endif
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- if(TURN_VISCATTENUATION_ON) then
-! compute the viscous damping term with the unrelaxed viscous coef and add memory variable
- viscodampx = velocw_poroelastic(1,iglob)*bl_unrelaxed(1) + velocw_poroelastic(2,iglob)*bl_unrelaxed(2)&
- - rx_viscous(i,j,ispec)
- viscodampz = velocw_poroelastic(1,iglob)*bl_unrelaxed(2) + velocw_poroelastic(2,iglob)*bl_unrelaxed(3)&
- - rz_viscous(i,j,ispec)
- else
-! no viscous attenuation
- viscodampx = velocw_poroelastic(1,iglob)*bl_relaxed(1) + velocw_poroelastic(2,iglob)*bl_relaxed(2)
- viscodampz = velocw_poroelastic(1,iglob)*bl_relaxed(2) + velocw_poroelastic(2,iglob)*bl_relaxed(3)
- endif
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
- viscodampx
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
- viscodampz
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_viscodampx(iglob) = wxgll(i)*wzgll(j)*jacobian(i,j,ispec) * viscodampx
- b_viscodampz(iglob) = wxgll(i)*wzgll(j)*jacobian(i,j,ispec) * viscodampz
- elseif(SIMULATION_TYPE == 2) then ! kernels calculation
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - b_viscodampx(iglob)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - b_viscodampz(iglob)
- endif
-
- enddo
- enddo
-
- endif ! end of test if poroelastic element
-
- enddo ! end of loop over all spectral elements
-
-
-!
-!--- absorbing boundaries
-!
- if(anyabs) then
-
- do ispecabs=1,nelemabs
-
- ispec = numabs(ispecabs)
-
- if (poroelastic(ispec)) then
-! get poroelastic parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- permlxx = permeability(1,kmato(ispec))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
- rhol_s = density(1,kmato(ispec))
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
- etal_f = poroelastcoef(2,2,kmato(ispec))
-!frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-!Biot coefficients for the input phi
- D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
- tortl,rhol_s,rhol_f,etal_f,permlxx,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIl = sqrt(cpIsquare)
- cpIIl = sqrt(cpIIsquare)
- csl = sqrt(cssquare)
-
-!--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
-
- i = 1
-
- jbegin = jbegin_left_poro(ispecabs)
- jend = jend_left_poro(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
- xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
-
- weight = jacobian1D * wzgll(j)
-
- rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
- rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
- rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
- tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_w_left(1,j,ib_left(ispecabs),it) = tx*weight
- b_absorb_poro_w_left(2,j,ib_left(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
- b_absorb_poro_w_left(1,j,ib_left(ispecabs),NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
- b_absorb_poro_w_left(2,j,ib_left(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of left absorbing boundary
-
-!--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
-
- i = NGLLX
-
- jbegin = jbegin_right_poro(ispecabs)
- jend = jend_right_poro(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
- xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
-
- weight = jacobian1D * wzgll(j)
-
-
- rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
- rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
- rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
- tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_w_right(1,j,ib_right(ispecabs),it) = tx*weight
- b_absorb_poro_w_right(2,j,ib_right(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
- b_absorb_poro_w_right(1,j,ib_right(ispecabs),NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
- b_absorb_poro_w_right(2,j,ib_right(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of right absorbing boundary
-
-!--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
-
- j = 1
-
- ibegin = ibegin_bottom_poro(ispecabs)
- iend = iend_bottom_poro(ispecabs)
-
-! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
-
- weight = jacobian1D * wxgll(i)
-
-
- rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
- rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
- rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
- tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_w_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
- b_absorb_poro_w_bottom(2,i,ib_bottom(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
- b_absorb_poro_w_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
- b_absorb_poro_w_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of bottom absorbing boundary
-
-!--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
-
- j = NGLLZ
-
- ibegin = ibegin_top_poro(ispecabs)
- iend = iend_top_poro(ispecabs)
-
-! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
-
- weight = jacobian1D * wxgll(i)
-
-
- rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
- rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
- rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
- tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
-
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_w_top(1,i,ib_top(ispecabs),it) = tx*weight
- b_absorb_poro_w_top(2,i,ib_top(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
- b_absorb_poro_w_top(1,i,ib_top(ispecabs),NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
- b_absorb_poro_w_top(2,i,ib_top(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of top absorbing boundary
-
- endif ! if poroelastic(ispec)
- enddo
-
- endif ! end of absorbing boundaries
-
-
-! --- add the source
- if(.not. initialfield) then
- do i_source=1,NSOURCES
-! if this processor carries the source and the source element is poroelastic
- if (is_proc_source(i_source) == 1 .and. poroelastic(ispec_selected_source(i_source))) then
-
- phil = porosity(kmato(ispec_selected_source(i_source)))
- rhol_s = density(1,kmato(ispec_selected_source(i_source)))
- rhol_f = density(2,kmato(ispec_selected_source(i_source)))
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-
-! moment tensor
- if(source_type(i_source) == 2) then
-
-! add source array
- if(SIMULATION_TYPE == 1) then ! forward wavefield
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- accelw_poroelastic(:,iglob) = accelw_poroelastic(:,iglob) + &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
- enddo
- enddo
- else ! backward wavefield
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- b_accelw_poroelastic(:,iglob) = b_accelw_poroelastic(:,iglob) + &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*sourcearray(i_source,:,i,j)*source_time_function(i_source,NSTEP-it+1)
- enddo
- enddo
- endif !endif SIMULATION_TYPE == 1
-
- endif !if(source_type(i_source) == 2)
-
- endif ! if this processor carries the source and the source element is poroelastic
- enddo
-
- if(SIMULATION_TYPE == 2) then ! adjoint wavefield
- irec_local = 0
- do irec = 1,nrec
-! add the source (only if this proc carries the source)
- if(myrank == which_proc_receiver(irec)) then
-
- irec_local = irec_local + 1
- if(poroelastic(ispec_selected_rec(irec))) then
- phil = porosity(kmato(ispec_selected_rec(irec)))
- rhol_s = density(1,kmato(ispec_selected_rec(irec)))
- rhol_f = density(2,kmato(ispec_selected_rec(irec)))
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-! add source array
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_rec(irec))
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - &
- rhol_f/rhol_bar*adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - &
- rhol_f/rhol_bar*adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
- enddo
- enddo
- endif ! if element is poroelastic
-
- endif ! if this processor carries the adjoint source and the source element is poroelastic
- enddo ! irec = 1,nrec
- endif ! SIMULATION_TYPE == 2 adjoint wavefield
-
- endif ! if not using an initial field
-
-! implement attenuation
- if(TURN_ATTENUATION_ON) then
-
-! compute Grad(displs_poroelastic) at time step n+1 for attenuation
- call compute_gradient_attenuation(displs_poroelastic,dux_dxl_np1,duz_dxl_np1, &
- dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
-
-! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
-! loop over spectral elements
- do ispec = 1,nspec
-
- if (poroelastic(ispec)) then
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
- theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
- theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
-
-! loop on all the standard linear solids
- do i_sls = 1,N_SLS
-
-! evolution e1 ! no need since we are just considering shear attenuation
-! Un = e1(i,j,ispec,i_sls)
-! tauinv = - inv_tau_sigma_nu1(i,j,ispec,i_sls)
-! tauinvsquare = tauinv * tauinv
-! tauinvcube = tauinvsquare * tauinv
-! tauinvUn = tauinv * Un
-! Sn = theta_n * phi_nu1(i,j,ispec,i_sls)
-! Snp1 = theta_np1 * phi_nu1(i,j,ispec,i_sls)
-! Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
-! twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
-! fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
-! deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
-! e1(i,j,ispec,i_sls) = Unp1
-
-! evolution e11
- Un = e11(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i,j,ispec,i_sls)
- Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i,j,ispec,i_sls)
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e11(i,j,ispec,i_sls) = Unp1
-
-! evolution e13
- Un = e13(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
- Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e13(i,j,ispec,i_sls) = Unp1
-
- enddo
-
- enddo
- enddo
- endif
- enddo
-
- endif ! end of test on attenuation
-
- end subroutine compute_forces_poro_fluid
-
Deleted: seismo/2D/SPECFEM2D/trunk/compute_forces_poro_solid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_forces_poro_solid.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_forces_poro_solid.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,957 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.3
-! ------------------------------
-!
-! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_forces_poro_solid(npoin,nspec,myrank,nelemabs,numat, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
- source_type,it,NSTEP,anyabs, &
- initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
- accels_poroelastic,velocs_poroelastic,velocw_poroelastic,displs_poroelastic,displw_poroelastic,&
- b_accels_poroelastic,b_displs_poroelastic,b_displw_poroelastic,&
- density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
- jacobian,source_time_function,sourcearray,adj_sourcearrays,e11, &
- e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
- dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
- phi_nu2,Mu_nu2,N_SLS, &
- rx_viscous,rz_viscous,theta_e,theta_s,&
- b_viscodampx,b_viscodampz,&
- ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
- jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
- mufr_k,B_k,NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD,&
- b_absorb_poro_s_left,b_absorb_poro_s_right,b_absorb_poro_s_bottom,b_absorb_poro_s_top,&
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,f0,freq0,Q0)
-
-! compute forces for the solid poroelastic part
-
- implicit none
-
- include "constants.h"
- integer :: NSOURCES, i_source
- integer, dimension(NSOURCES) :: ispec_selected_source,source_type,is_proc_source
- integer :: npoin,nspec,nelemabs,numat,it,NSTEP
- integer :: nrec,SIMULATION_TYPE,myrank
- integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(nelemabs) :: ib_left
- integer, dimension(nelemabs) :: ib_right
- integer, dimension(nelemabs) :: ib_bottom
- integer, dimension(nelemabs) :: ib_top
-
- logical :: anyabs,initialfield,TURN_ATTENUATION_ON
- logical :: SAVE_FORWARD
-
- double precision :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: kmato
- integer, dimension(nelemabs) :: numabs,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
- ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro
-
- logical, dimension(nspec) :: poroelastic
- logical, dimension(4,nelemabs) :: codeabs
-
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: accels_poroelastic,velocs_poroelastic,displs_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: velocw_poroelastic,displw_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accels_poroelastic,b_displs_poroelastic,b_displw_poroelastic
- double precision, dimension(2,numat) :: density
- double precision, dimension(3,numat) :: permeability
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(4,3,numat) :: poroelastcoef
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
- real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
- real(kind=CUSTOM_REAL), dimension(npoin) :: mufr_k,B_k
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_poro_s_left
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_poro_s_right
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmax,NSTEP) :: b_absorb_poro_s_top
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmin,NSTEP) :: b_absorb_poro_s_bottom
- real(kind=CUSTOM_REAL), dimension(npoin) :: b_viscodampx,b_viscodampz
-
- integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e11,e13
- double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu2,phi_nu2
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu2
- real(kind=CUSTOM_REAL) :: e11_sum,e13_sum
- integer :: i_sls
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: &
- dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
-
-! viscous attenuation (poroelastic media)
- double precision, dimension(NGLLX,NGLLZ,nspec) :: rx_viscous
- double precision, dimension(NGLLX,NGLLZ,nspec) :: rz_viscous
- double precision :: theta_e,theta_s
- logical TURN_VISCATTENUATION_ON
- double precision, dimension(3):: bl_unrelaxed,bl_relaxed
-
-! derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-
-! Gauss-Lobatto-Legendre weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-!
- double precision :: f0,freq0,Q0,w_c
-
-!---
-!--- local variables
-!---
-
- integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend,irec,irec_local
-
-! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
- real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
- real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
- real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
- real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
- real(kind=CUSTOM_REAL) :: dsxx,dsxz,dszz
- real(kind=CUSTOM_REAL) :: b_dsxx,b_dsxz,b_dszz
- real(kind=CUSTOM_REAL) :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
- real(kind=CUSTOM_REAL) :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
- real(kind=CUSTOM_REAL) :: dwxx,dwxz,dwzz
- real(kind=CUSTOM_REAL) :: b_dwxx,b_dwxz,b_dwzz
- real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xz,sigma_zz
- real(kind=CUSTOM_REAL) :: sigmap
- real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xz,b_sigma_zz
- real(kind=CUSTOM_REAL) :: b_sigmap
- real(kind=CUSTOM_REAL) :: nx,nz,vx,vz,vn,vxf,vzf,vnf,rho_vpI,rho_vpII,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1p,tempx2p,tempz1p,tempz2p
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempz1,b_tempz2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1p,b_tempx2p,b_tempz1p,b_tempz2p
-
-! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the poroelastic medium
- real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
- real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
- real(kind=CUSTOM_REAL) :: etal_f,kappal_f,rhol_f
- real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl,viscodampx,viscodampz
- real(kind=CUSTOM_REAL) :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
- real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
-
- real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
- real(kind=CUSTOM_REAL) :: cpIsquare,cpIIsquare,cssquare,cpIl,cpIIl,csl
-
-! for attenuation
- real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
-
-! compute Grad(displs_poroelastic) at time step n for attenuation
- if(TURN_ATTENUATION_ON) call compute_gradient_attenuation(displs_poroelastic,dux_dxl_n,duz_dxl_n, &
- dux_dzl_n,duz_dzl_n,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
-
-! loop over spectral elements
- do ispec = 1,nspec
-
-!---
-!--- poroelastic spectral element
-!---
-
- if(poroelastic(ispec)) then
-
-! get poroelastic parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
- rhol_s = density(1,kmato(ispec))
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
-!frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-!Biot coefficients for the input phi
- D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
- kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
-!The RHS has the form : div T -phi/c div T_f + phi/ceta_fk^-1.partial t w
-!where T = G:grad u_s + C_biot div w I
-!and T_f = C_biot div u_s I + M_biot div w I
- mul_G = mul_fr
- lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
- lambdalplus2mul_G = lambdal_G + TWO*mul_G
-
-! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
-! derivative along x and along z for u_s and w
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
-
- b_dwx_dxi = ZERO
- b_dwz_dxi = ZERO
-
- b_dwx_dgamma = ZERO
- b_dwz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
-
- dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
-
- b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
- b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
-
- b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
- b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
- endif
-
-! compute stress tensor (include attenuation or anisotropy if needed)
-
- if(TURN_ATTENUATION_ON) then
-! Dissipation only controlled by frame share attenuation in poroelastic (see Morency & Tromp, GJI 2008).
-! attenuation is implemented following the memory variable formulation of
-! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
-! vol. 58(1), p. 110-120 (1993). More details can be found in
-! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
-! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
-
-! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_G + mul_G) - mul_G * Mu_nu2(i,j,ispec)
- mul_unrelaxed = mul_G * Mu_nu2(i,j,ispec)
- lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
-
-! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
- sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
-
-! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
-! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
- e11_sum = 0._CUSTOM_REAL
- e13_sum = 0._CUSTOM_REAL
-
- do i_sls = 1,N_SLS
- e11_sum = e11_sum + e11(i,j,ispec,i_sls)
- e13_sum = e13_sum + e13(i,j,ispec,i_sls)
- enddo
-
- sigma_xx = sigma_xx + TWO * mul_G * e11_sum
- sigma_xz = sigma_xz + mul_G * e13_sum
- sigma_zz = sigma_zz - TWO * mul_G * e11_sum
-
- else
-
-! no attenuation
- sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = mul_G*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
- b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
-
- b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
- endif
- endif
-
-! kernels calculation
- if(SIMULATION_TYPE == 2) then
- iglob = ibool(i,j,ispec)
- dsxx = dux_dxl
- dsxz = HALF * (duz_dxl + dux_dzl)
- dszz = duz_dzl
-
- dwxx = dwx_dxl
- dwxz = HALF * (dwz_dxl + dwx_dzl)
- dwzz = dwz_dzl
-
- b_dsxx = b_dux_dxl
- b_dsxz = HALF * (b_duz_dxl + b_dux_dzl)
- b_dszz = b_duz_dzl
-
- b_dwxx = b_dwx_dxl
- b_dwxz = HALF * (b_dwz_dxl + b_dwx_dzl)
- b_dwzz = b_dwz_dzl
-
- B_k(iglob) = (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl) * (H_biot - FOUR_THIRDS * mul_fr)
- mufr_k(iglob) = (dsxx * b_dsxx + dszz * b_dszz + &
- 2._CUSTOM_REAL * dsxz * b_dsxz - &
- 1._CUSTOM_REAL/3._CUSTOM_REAL * (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl) ) * mul_fr
- endif
-
- jacobianl = jacobian(i,j,ispec)
-
-! weak formulation term based on stress tensor (non-symmetric form)
-! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
- tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
-
- tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
- tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
-
- tempx1p(i,j) = wzgll(j)*jacobianl*sigmap*xixl
- tempz1p(i,j) = wzgll(j)*jacobianl*sigmap*xizl
-
- tempx2p(i,j) = wxgll(i)*jacobianl*sigmap*gammaxl
- tempz2p(i,j) = wxgll(i)*jacobianl*sigmap*gammazl
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
- b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
-
- b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
- b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
-
- b_tempx1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xixl
- b_tempz1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xizl
-
- b_tempx2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammaxl
- b_tempz2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammazl
- endif
-
- enddo
- enddo
-
-!
-! second double-loop over GLL to compute all the terms
-!
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
-! along x direction and z direction
-! and assemble the contributions
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - ( (tempx1(k,j) - phil/tortl*tempx1p(k,j)) &
- *hprimewgll_xx(k,i) + (tempx2(i,k) - phil/tortl*tempx2p(i,k))*hprimewgll_zz(k,j) )
-
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - ( (tempz1(k,j) - phil/tortl*tempz1p(k,j)) &
- *hprimewgll_xx(k,i) + (tempz2(i,k) - phil/tortl*tempz2p(i,k))*hprimewgll_zz(k,j) )
-
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - ( (b_tempx1(k,j) - phil/tortl*b_tempx1p(k,j)) &
- *hprimewgll_xx(k,i) + (b_tempx2(i,k) - phil/tortl*b_tempx2p(i,k))*hprimewgll_zz(k,j) )
-
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - ( (b_tempz1(k,j) - phil/tortl*b_tempz1p(k,j)) &
- *hprimewgll_xx(k,i) + (b_tempz2(i,k) - phil/tortl*b_tempz2p(i,k))*hprimewgll_zz(k,j) )
- endif
-
- enddo
-
- enddo ! second loop over the GLL points
- enddo
-
- endif ! end of test if poroelastic element
-
- enddo ! end of loop over all spectral elements
-
-!
-!---- viscous damping
-!
-! add + phi/tort eta_f k^-1 dot(w)
-
-! loop over spectral elements
- do ispec = 1,nspec
-
- etal_f = poroelastcoef(2,2,kmato(ispec))
-
- if(poroelastic(ispec) .and. etal_f >0.d0) then
-
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- permlxx = permeability(1,kmato(ispec))
- permlxz = permeability(2,kmato(ispec))
- permlzz = permeability(3,kmato(ispec))
-
-! calcul of the inverse of k
- detk = permlxx*permlzz - permlxz*permlxz
-
- if(detk /= ZERO) then
- invpermlxx = permlzz/detk
- invpermlxz = -permlxz/detk
- invpermlzz = permlxx/detk
- else
- stop 'Permeability matrix is not invertible'
- endif
-
-! relaxed viscous coef
- bl_relaxed(1) = etal_f*invpermlxx
- bl_relaxed(2) = etal_f*invpermlxz
- bl_relaxed(3) = etal_f*invpermlzz
-
- if(TURN_VISCATTENUATION_ON) then
- bl_unrelaxed(1) = etal_f*invpermlxx*theta_e/theta_s
- bl_unrelaxed(2) = etal_f*invpermlxz*theta_e/theta_s
- bl_unrelaxed(3) = etal_f*invpermlzz*theta_e/theta_s
- endif
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- if(TURN_VISCATTENUATION_ON) then
-! compute the viscous damping term with the unrelaxed viscous coef and add memory variable
- viscodampx = velocw_poroelastic(1,iglob)*bl_unrelaxed(1) + velocw_poroelastic(2,iglob)*bl_unrelaxed(2)&
- - rx_viscous(i,j,ispec)
- viscodampz = velocw_poroelastic(1,iglob)*bl_unrelaxed(2) + velocw_poroelastic(2,iglob)*bl_unrelaxed(3)&
- - rz_viscous(i,j,ispec)
- else
-! no viscous attenuation
- viscodampx = velocw_poroelastic(1,iglob)*bl_relaxed(1) + velocw_poroelastic(2,iglob)*bl_relaxed(2)
- viscodampz = velocw_poroelastic(1,iglob)*bl_relaxed(2) + velocw_poroelastic(2,iglob)*bl_relaxed(3)
- endif
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + phil/tortl*wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
- viscodampx
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + phil/tortl*wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
- viscodampz
-
-! if SIMULATION_TYPE == 1 .and. SAVE_FORWARD then b_viscodamp is saved in compute_forces_poro_fluid.f90
- if(SIMULATION_TYPE == 2) then ! kernels calculation
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + phil/tortl*b_viscodampx(iglob)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + phil/tortl*b_viscodampz(iglob)
- endif
-
- enddo
- enddo
-
- endif ! end of test if poroelastic element
-
- enddo ! end of loop over all spectral elements
-
-
-!
-!--- absorbing boundaries
-!
- if(anyabs) then
-
- do ispecabs = 1,nelemabs
-
- ispec = numabs(ispecabs)
-
- if (poroelastic(ispec)) then
-
-! get poroelastic parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- permlxx = permeability(1,kmato(ispec))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
- rhol_s = density(1,kmato(ispec))
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
- etal_f = poroelastcoef(2,2,kmato(ispec))
-!frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-!Biot coefficients for the input phi
- D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
- tortl,rhol_s,rhol_f,etal_f,permlxx,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- cpIl = sqrt(cpIsquare)
- cpIIl = sqrt(cpIIsquare)
- csl = sqrt(cssquare)
-
-!--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
-
- i = 1
-
- jbegin = jbegin_left_poro(ispecabs)
- jend = jend_left_poro(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
-
- xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
-
-
- weight = jacobian1D * wzgll(j)
-
- rho_vpI = (rhol_bar - phil/tortl*rhol_f)*cpIl
- rho_vpII = (rhol_bar - phil/tortl*rhol_f)*cpIIl
- rho_vs = (rhol_bar - phil/tortl*rhol_f)*csl
-
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
- tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_s_left(1,j,ib_left(ispecabs),it) = tx*weight
- b_absorb_poro_s_left(2,j,ib_left(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
- b_absorb_poro_s_left(1,j,ib_left(ispecabs),NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
- b_absorb_poro_s_left(2,j,ib_left(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of left absorbing boundary
-
-!--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
-
- i = NGLLX
-
- jbegin = jbegin_right_poro(ispecabs)
- jend = jend_right_poro(ispecabs)
-
- do j = jbegin,jend
-
- iglob = ibool(i,j,ispec)
-
- xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
-
- weight = jacobian1D * wzgll(j)
-
-
- rho_vpI = (rhol_bar - phil/tortl*rhol_f)*cpIl
- rho_vpII = (rhol_bar - phil/tortl*rhol_f)*cpIIl
- rho_vs = (rhol_bar - phil/tortl*rhol_f)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
- tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_s_right(1,j,ib_right(ispecabs),it) = tx*weight
- b_absorb_poro_s_right(2,j,ib_right(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
- b_absorb_poro_s_right(1,j,ib_right(ispecabs),NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
- b_absorb_poro_s_right(2,j,ib_right(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of right absorbing boundary
-
-!--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
-
- j = 1
-
- ibegin = ibegin_bottom_poro(ispecabs)
- iend = iend_bottom_poro(ispecabs)
-
-! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
-
- weight = jacobian1D * wxgll(i)
-
-
- rho_vpI = (rhol_bar - phil/tortl*rhol_f)*cpIl
- rho_vpII = (rhol_bar - phil/tortl*rhol_f)*cpIIl
- rho_vs = (rhol_bar - phil/tortl*rhol_f)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
- tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_s_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
- b_absorb_poro_s_bottom(2,i,ib_bottom(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
- b_absorb_poro_s_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
- b_absorb_poro_s_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of bottom absorbing boundary
-
-!--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
-
- j = NGLLZ
-
- ibegin = ibegin_top_poro(ispecabs)
- iend = iend_top_poro(ispecabs)
-
-! exclude corners to make sure there is no contradiction on the normal
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
-
- weight = jacobian1D * wxgll(i)
-
-
- rho_vpI = (rhol_bar - phil/tortl*rhol_f)*cpIl
- rho_vpII = (rhol_bar - phil/tortl*rhol_f)*cpIIl
- rho_vs = (rhol_bar - phil/tortl*rhol_f)*csl
-
- if(poroelastic(ispec)) then
- vx = velocs_poroelastic(1,iglob)
- vz = velocs_poroelastic(2,iglob)
- vxf = velocw_poroelastic(1,iglob)
- vzf = velocw_poroelastic(2,iglob)
-
- vn = nx*vx+nz*vz
- vnf = nx*vxf+nz*vzf
-
- tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
- tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
-
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
-
- if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- b_absorb_poro_s_top(1,i,ib_top(ispecabs),it) = tx*weight
- b_absorb_poro_s_top(2,i,ib_top(ispecabs),it) = tz*weight
- elseif(SIMULATION_TYPE == 2) then
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
- b_absorb_poro_s_top(1,i,ib_top(ispecabs),NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
- b_absorb_poro_s_top(2,i,ib_top(ispecabs),NSTEP-it+1)
- endif
-
- endif
-
- enddo
-
- endif ! end of top absorbing boundary
-
- endif ! if poroelastic(ispec)
-
- enddo
-
- endif ! end of absorbing boundaries
-
-
-! --- add the source
- if(.not. initialfield) then
- do i_source=1,NSOURCES
-
-! if this processor carries the source and the source element is poroelastic
- if (is_proc_source(i_source) == 1 .and. poroelastic(ispec_selected_source(i_source))) then
-
- phil = porosity(kmato(ispec_selected_source(i_source)))
- tortl = tortuosity(kmato(ispec_selected_source(i_source)))
-
-! moment tensor
- if(source_type(i_source) == 2) then
-
-! add source array
- if(SIMULATION_TYPE == 1) then ! forward wavefield
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- accels_poroelastic(:,iglob) = accels_poroelastic(:,iglob) + &
- (1._CUSTOM_REAL - phil/tortl)*sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
- enddo
- enddo
- else ! backward wavefield
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- b_accels_poroelastic(:,iglob) = b_accels_poroelastic(:,iglob) + &
- (1._CUSTOM_REAL - phil/tortl)*sourcearray(i_source,:,i,j)*source_time_function(i_source,NSTEP-it+1)
- enddo
- enddo
- endif !endif SIMULATION_TYPE == 1
-
- endif !if(source_type(i_source) == 2)
-
- endif ! if this processor carries the source and the source element is poroelastic
- enddo
-
- if(SIMULATION_TYPE == 2) then ! adjoint wavefield
- irec_local = 0
- do irec = 1,nrec
-! add the source (only if this proc carries the source)
- if(myrank == which_proc_receiver(irec)) then
-
- irec_local = irec_local + 1
- if(poroelastic(ispec_selected_rec(irec))) then
-! add source array
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_rec(irec))
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
- enddo
- enddo
- endif ! if element is poroelastic
-
- endif ! if this processor carries the adjoint source and the source element is poroelastic
- enddo ! irec = 1,nrec
- endif ! SIMULATION_TYPE == 2 adjoint wavefield
-
- endif ! if not using an initial field
-
-! implement attenuation
- if(TURN_ATTENUATION_ON) then
-
-! compute Grad(displs_poroelastic) at time step n+1 for attenuation
- call compute_gradient_attenuation(displs_poroelastic,dux_dxl_np1,duz_dxl_np1, &
- dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
-
-! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
-! loop over spectral elements
- do ispec = 1,nspec
-
- if (poroelastic(ispec)) then
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
- theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
- theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
-
-! loop on all the standard linear solids
- do i_sls = 1,N_SLS
-
-! evolution e1 ! no need since we are just considering shear attenuation
-! Un = e1(i,j,ispec,i_sls)
-! tauinv = - inv_tau_sigma_nu1(i,j,ispec,i_sls)
-! tauinvsquare = tauinv * tauinv
-! tauinvcube = tauinvsquare * tauinv
-! tauinvUn = tauinv * Un
-! Sn = theta_n * phi_nu1(i,j,ispec,i_sls)
-! Snp1 = theta_np1 * phi_nu1(i,j,ispec,i_sls)
-! Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
-! twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
-! fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
-! deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
-! e1(i,j,ispec,i_sls) = Unp1
-
-! evolution e11
- Un = e11(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i,j,ispec,i_sls)
- Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i,j,ispec,i_sls)
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e11(i,j,ispec,i_sls) = Unp1
-
-! evolution e13
- Un = e13(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
- Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e13(i,j,ispec,i_sls) = Unp1
-
- enddo
-
- enddo
- enddo
- endif
- enddo
-
- endif ! end of test on attenuation
-
-
- end subroutine compute_forces_poro_solid
-
Deleted: seismo/2D/SPECFEM2D/trunk/compute_forces_viscoelastic.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_forces_viscoelastic.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_forces_viscoelastic.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,988 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-subroutine compute_forces_viscoelastic(p_sv,npoin,nspec,myrank,nelemabs,numat, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver, &
- source_type,it,NSTEP,anyabs,assign_external_model, &
- initialfield,TURN_ATTENUATION_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
- accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic, &
- density,poroelastcoef,xix,xiz,gammax,gammaz, &
- jacobian,vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy, &
- source_time_function,sourcearray,adj_sourcearrays,e1,e11, &
- e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
- dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
- deltat,coord,add_Bielak_conditions, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset,f0, &
- v0x_left,v0z_left,v0x_right,v0z_right,v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot,&
- nleft,nright,nbot,over_critical_angle,NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD,b_absorb_elastic_left,&
- b_absorb_elastic_right,b_absorb_elastic_bottom,b_absorb_elastic_top,nspec_xmin,nspec_xmax,&
- nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,mu_k,kappa_k)
-
- ! compute forces for the elastic elements
-
- implicit none
-
- include "constants.h"
-
- logical :: p_sv
- integer :: NSOURCES, i_source
- integer :: npoin,nspec,myrank,nelemabs,numat,it,NSTEP
- integer, dimension(NSOURCES) :: ispec_selected_source,is_proc_source,source_type
-
- integer :: nrec,SIMULATION_TYPE
- integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(nelemabs) :: ib_left
- integer, dimension(nelemabs) :: ib_right
- integer, dimension(nelemabs) :: ib_bottom
- integer, dimension(nelemabs) :: ib_top
-
- logical :: anyabs,assign_external_model,initialfield,TURN_ATTENUATION_ON,add_Bielak_conditions
-
- logical :: SAVE_FORWARD
-
- double precision :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
- double precision, dimension(NSOURCES) :: angleforce
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: kmato
- integer, dimension(nelemabs) :: numabs
-
- logical, dimension(nspec) :: elastic,anisotropic
- logical, dimension(4,nelemabs) :: codeabs
-
- real(kind=CUSTOM_REAL), dimension(3,npoin) :: accel_elastic,veloc_elastic,displ_elastic
- double precision, dimension(2,numat) :: density
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(6,numat) :: anisotropy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
- double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
- double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
-
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
-
- real(kind=CUSTOM_REAL), dimension(3,npoin) :: b_accel_elastic,b_displ_elastic
- real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
- real(kind=CUSTOM_REAL), dimension(npoin) :: mu_k,kappa_k
- real(kind=CUSTOM_REAL), dimension(3,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_elastic_left
- real(kind=CUSTOM_REAL), dimension(3,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_elastic_right
- real(kind=CUSTOM_REAL), dimension(3,NGLLX,nspec_zmax,NSTEP) :: b_absorb_elastic_top
- real(kind=CUSTOM_REAL), dimension(3,NGLLX,nspec_zmin,NSTEP) :: b_absorb_elastic_bottom
-
- integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11,e13
- double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
- real(kind=CUSTOM_REAL) :: e1_sum,e11_sum,e13_sum
- integer :: i_sls
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: &
- dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
-
- ! derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-
- ! Gauss-Lobatto-Legendre weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-
- !---
- !--- local variables
- !---
-
- integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,irec,irec_local
-
- ! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duy_dxi,duy_dgamma,duz_dxi,duz_dgamma
- real(kind=CUSTOM_REAL) :: dux_dxl,duy_dxl,duz_dxl,dux_dzl,duy_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duy_dxi,b_duy_dgamma,b_duz_dxi,b_duz_dgamma
- real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duy_dxl,b_duz_dxl,b_dux_dzl,b_duy_dzl,b_duz_dzl
- real(kind=CUSTOM_REAL) :: dsxx,dsxz,dszz
- real(kind=CUSTOM_REAL) :: b_dsxx,b_dsxz,b_dszz
- real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xy,sigma_xz,sigma_zy,sigma_zz
- real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xy,b_sigma_xz,b_sigma_zy,b_sigma_zz
- real(kind=CUSTOM_REAL) :: nx,nz,vx,vy,vz,vn,rho_vp,rho_vs,tx,ty,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempy1,tempy2,tempz1,tempz2
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempy1,b_tempy2,b_tempz1,b_tempz2
-
- ! Jacobian matrix and determinant
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
-
- ! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal,cpl,csl,rhol, &
- lambdal_unrelaxed,mul_unrelaxed,lambdalplus2mul_unrelaxed
-
- ! for attenuation
- real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
-
- ! for anisotropy
- double precision :: c11,c15,c13,c33,c35,c55
-
- ! for analytical initial plane wave for Bielak's conditions
- double precision :: veloc_horiz,veloc_vert,dxUx,dzUx,dxUz,dzUz,traction_x_t0,traction_z_t0,deltat
- double precision, dimension(NDIM,npoin), intent(in) :: coord
- double precision x0_source, z0_source, angleforce_refl, c_inc, c_refl, time_offset, f0
- double precision, dimension(NDIM) :: A_plane, B_plane, C_plane
- !over critical angle
- logical :: over_critical_angle
- integer :: nleft, nright, nbot
- double precision, dimension(nleft) :: v0x_left,v0z_left,t0x_left,t0z_left
- double precision, dimension(nright) :: v0x_right,v0z_right,t0x_right,t0z_right
- double precision, dimension(nbot) :: v0x_bot,v0z_bot,t0x_bot,t0z_bot
- integer count_left,count_right,count_bottom
-
- integer :: ifirstelem,ilastelem
-
- ! compute Grad(displ_elastic) at time step n for attenuation
- if(TURN_ATTENUATION_ON) then
- call compute_gradient_attenuation(displ_elastic,dux_dxl_n,duz_dxl_n, &
- dux_dzl_n,duz_dzl_n,xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
- endif
-
- ifirstelem = 1
- ilastelem = nspec
-
- ! loop over spectral elements
- do ispec = ifirstelem,ilastelem
-
- tempx1(:,:) = ZERO
- tempy1(:,:) = ZERO
- tempz1(:,:) = ZERO
- tempx2(:,:) = ZERO
- tempy2(:,:) = ZERO
- tempz2(:,:) = ZERO
- if(SIMULATION_TYPE ==2)then
- b_tempx1(:,:) = ZERO
- b_tempy1(:,:) = ZERO
- b_tempz1(:,:) = ZERO
- b_tempx2(:,:) = ZERO
- b_tempy2(:,:) = ZERO
- b_tempz2(:,:) = ZERO
- endif
-
- !---
- !--- elastic spectral element
- !---
- if(elastic(ispec)) then
-
- ! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec))
-
- ! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- !--- if external medium, get elastic parameters of current grid point
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- csl = vsext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- mul_relaxed = rhol*csl*csl
- lambdal_relaxed = rhol*cpl*cpl - TWO*mul_relaxed
- lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
- endif
-
- ! derivative along x and along z
- dux_dxi = ZERO
- duy_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duy_dgamma = ZERO
- duz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
- b_dux_dxi = ZERO
- b_duy_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duy_dgamma = ZERO
- b_duz_dgamma = ZERO
- endif
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duy_dxi = duy_dxi + displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duy_dgamma = duy_dgamma + displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
- b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- b_duy_dxi = b_duy_dxi + b_displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- b_duz_dxi = b_duz_dxi + b_displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
- b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- b_duy_dgamma = b_duy_dgamma + b_displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- ! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duy_dxl = duy_dxi*xixl + duy_dgamma*gammaxl
- duy_dzl = duy_dxi*xizl + duy_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duy_dxl = b_duy_dxi*xixl + b_duy_dgamma*gammaxl
- b_duy_dzl = b_duy_dxi*xizl + b_duy_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
- endif
-
- ! compute stress tensor (include attenuation or anisotropy if needed)
-
- if(TURN_ATTENUATION_ON) then
-
- ! attenuation is implemented following the memory variable formulation of
- ! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
- ! vol. 58(1), p. 110-120 (1993). More details can be found in
- ! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
- ! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
-
- ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(i,j,ispec) - mul_relaxed * Mu_nu2(i,j,ispec)
- mul_unrelaxed = mul_relaxed * Mu_nu2(i,j,ispec)
- lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
-
- ! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
- sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
- sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
-
- ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
- ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
- e1_sum = 0._CUSTOM_REAL
- e11_sum = 0._CUSTOM_REAL
- e13_sum = 0._CUSTOM_REAL
-
- do i_sls = 1,N_SLS
- e1_sum = e1_sum + e1(i,j,ispec,i_sls)
- e11_sum = e11_sum + e11(i,j,ispec,i_sls)
- e13_sum = e13_sum + e13(i,j,ispec,i_sls)
- enddo
-
- sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum + TWO * mul_relaxed * e11_sum
- sigma_xz = sigma_xz + mul_relaxed * e13_sum
- sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum - TWO * mul_relaxed * e11_sum
-
- else
-
- ! no attenuation
- sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
- sigma_xy = mul_relaxed*duy_dxl
- sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
- sigma_zy = mul_relaxed*duy_dzl
- sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
- b_sigma_xx = lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
- b_sigma_xy = mul_relaxed*b_duy_dxl
- b_sigma_xz = mul_relaxed*(b_duz_dxl + b_dux_dzl)
- b_sigma_zy = mul_relaxed*b_duy_dzl
- b_sigma_zz = lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
- endif
-
- endif
-
- ! full anisotropy
- if(anisotropic(ispec)) then
- if(assign_external_model) then
- c11 = c11ext(i,j,ispec)
- c13 = c13ext(i,j,ispec)
- c15 = c15ext(i,j,ispec)
- c33 = c33ext(i,j,ispec)
- c35 = c35ext(i,j,ispec)
- c55 = c55ext(i,j,ispec)
- else
- c11 = anisotropy(1,kmato(ispec))
- c13 = anisotropy(2,kmato(ispec))
- c15 = anisotropy(3,kmato(ispec))
- c33 = anisotropy(4,kmato(ispec))
- c35 = anisotropy(5,kmato(ispec))
- c55 = anisotropy(6,kmato(ispec))
- end if
-
- ! implement anisotropy in 2D
- sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
- sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
- sigma_xz = c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
-
- endif
-
- ! Pre-kernels calculation
- if(SIMULATION_TYPE == 2) then
- iglob = ibool(i,j,ispec)
- if(p_sv)then !P-SV waves
- dsxx = dux_dxl
- dsxz = HALF * (duz_dxl + dux_dzl)
- dszz = duz_dzl
-
- b_dsxx = b_dux_dxl
- b_dsxz = HALF * (b_duz_dxl + b_dux_dzl)
- b_dszz = b_duz_dzl
-
- kappa_k(iglob) = (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl)
- mu_k(iglob) = dsxx * b_dsxx + dszz * b_dszz + &
- 2._CUSTOM_REAL * dsxz * b_dsxz - 1._CUSTOM_REAL/3._CUSTOM_REAL * kappa_k(iglob)
- else !SH (membrane) waves
- mu_k(iglob) = duy_dxl * b_duy_dxl + duy_dzl * b_duy_dzl
- endif
- endif
-
- jacobianl = jacobian(i,j,ispec)
-
- ! weak formulation term based on stress tensor (non-symmetric form)
- ! also add GLL integration weights
- tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
- tempy1(i,j) = wzgll(j)*jacobianl*(sigma_xy*xixl+sigma_zy*xizl)
- tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
-
- tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
- tempy2(i,j) = wxgll(i)*jacobianl*(sigma_xy*gammaxl+sigma_zy*gammazl)
- tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
- b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
- b_tempy1(i,j) = wzgll(j)*jacobianl*(b_sigma_xy*xixl+b_sigma_zy*xizl)
- b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
-
- b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
- b_tempy2(i,j) = wxgll(i)*jacobianl*(b_sigma_xy*gammaxl+b_sigma_zy*gammazl)
- b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
- endif
-
- enddo
- enddo
-
- !
- ! second double-loop over GLL to compute all the terms
- !
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- ! along x direction and z direction
- ! and assemble the contributions
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
- accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tempy1(k,j)*hprimewgll_xx(k,i) + tempy2(i,k)*hprimewgll_zz(k,j))
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tempz1(k,j)*hprimewgll_xx(k,i) + tempz2(i,k)*hprimewgll_zz(k,j))
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
- (b_tempx1(k,j)*hprimewgll_xx(k,i) + b_tempx2(i,k)*hprimewgll_zz(k,j))
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
- (b_tempy1(k,j)*hprimewgll_xx(k,i) + b_tempy2(i,k)*hprimewgll_zz(k,j))
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
- (b_tempz1(k,j)*hprimewgll_xx(k,i) + b_tempz2(i,k)*hprimewgll_zz(k,j))
- endif
- enddo
-
- enddo ! second loop over the GLL points
- enddo
-
- endif ! end of test if elastic element
-
- enddo ! end of loop over all spectral elements
-
- !
- !--- absorbing boundaries
- !
- if(anyabs) then
-
- count_left=1
- count_right=1
- count_bottom=1
-
- do ispecabs = 1,nelemabs
-
- ispec = numabs(ispecabs)
-
- ! get elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- rhol = density(1,kmato(ispec))
- kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
- cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
- csl = sqrt(mul_relaxed/rhol)
-
- !--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
-
- i = 1
-
- do j = 1,NGLLZ
-
- iglob = ibool(i,j,ispec)
-
- ! for analytical initial plane wave for Bielak's conditions
- ! left or right edge, horizontal normal vector
- if(add_Bielak_conditions .and. initialfield) then
- if (.not.over_critical_angle) then
- call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
- traction_z_t0 = mul_relaxed*(dxUz + dzUx)
- else
- veloc_horiz=v0x_left(count_left)
- veloc_vert=v0z_left(count_left)
- traction_x_t0=t0x_left(count_left)
- traction_z_t0=t0z_left(count_left)
- count_left=count_left+1
- end if
- else
- veloc_horiz = 0
- veloc_vert = 0
- traction_x_t0 = 0
- traction_z_t0 = 0
- endif
-
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- csl = vsext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
-
- rho_vp = rhol*cpl
- rho_vs = rhol*csl
-
- xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
-
- weight = jacobian1D * wzgll(j)
-
- ! Clayton-Engquist condition if elastic
- if(elastic(ispec)) then
- vx = veloc_elastic(1,iglob) - veloc_horiz
- vy = veloc_elastic(2,iglob)
- vz = veloc_elastic(3,iglob) - veloc_vert
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- ty = rho_vs*vy
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
- accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz + traction_z_t0)*weight
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- if(p_sv)then !P-SV waves
- b_absorb_elastic_left(1,j,ib_left(ispecabs),it) = tx*weight
- b_absorb_elastic_left(3,j,ib_left(ispecabs),it) = tz*weight
- else !SH (membrane) waves
- b_absorb_elastic_left(2,j,ib_left(ispecabs),it) = ty*weight
- endif
- elseif(SIMULATION_TYPE == 2) then
- if(p_sv)then !P-SV waves
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
- b_absorb_elastic_left(1,j,ib_left(ispecabs),NSTEP-it+1)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
- b_absorb_elastic_left(3,j,ib_left(ispecabs),NSTEP-it+1)
- else !SH (membrane) waves
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
- b_absorb_elastic_left(2,j,ib_left(ispecabs),NSTEP-it+1)
- endif
- endif
-
- endif
-
- enddo
-
- endif ! end of left absorbing boundary
-
- !--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
-
- i = NGLLX
-
- do j = 1,NGLLZ
-
- iglob = ibool(i,j,ispec)
-
- ! for analytical initial plane wave for Bielak's conditions
- ! left or right edge, horizontal normal vector
- if(add_Bielak_conditions .and. initialfield) then
- if (.not.over_critical_angle) then
- call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
- traction_z_t0 = mul_relaxed*(dxUz + dzUx)
- else
- veloc_horiz=v0x_right(count_right)
- veloc_vert=v0z_right(count_right)
- traction_x_t0=t0x_right(count_right)
- traction_z_t0=t0z_right(count_right)
- count_right=count_right+1
- end if
- else
- veloc_horiz = 0
- veloc_vert = 0
- traction_x_t0 = 0
- traction_z_t0 = 0
- endif
-
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- csl = vsext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
-
- rho_vp = rhol*cpl
- rho_vs = rhol*csl
-
- xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
-
- weight = jacobian1D * wzgll(j)
-
- ! Clayton-Engquist condition if elastic
- if(elastic(ispec)) then
- vx = veloc_elastic(1,iglob) - veloc_horiz
- vy = veloc_elastic(2,iglob)
- vz = veloc_elastic(3,iglob) - veloc_vert
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- ty = rho_vs*vy
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
- accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz - traction_z_t0)*weight
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- if(p_sv)then !P-SV waves
- b_absorb_elastic_right(1,j,ib_right(ispecabs),it) = tx*weight
- b_absorb_elastic_right(3,j,ib_right(ispecabs),it) = tz*weight
- else! SH (membrane) waves
- b_absorb_elastic_right(2,j,ib_right(ispecabs),it) = ty*weight
- endif
- elseif(SIMULATION_TYPE == 2) then
- if(p_sv)then !P-SV waves
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
- b_absorb_elastic_right(1,j,ib_right(ispecabs),NSTEP-it+1)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
- b_absorb_elastic_right(3,j,ib_right(ispecabs),NSTEP-it+1)
- else! SH (membrane) waves
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
- b_absorb_elastic_right(2,j,ib_right(ispecabs),NSTEP-it+1)
- endif
- endif
-
- endif
-
- enddo
-
- endif ! end of right absorbing boundary
-
- !--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
-
- j = 1
-
- ! exclude corners to make sure there is no contradiction on the normal
- ibegin = 1
- iend = NGLLX
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
- ! for analytical initial plane wave for Bielak's conditions
- ! top or bottom edge, vertical normal vector
- if(add_Bielak_conditions .and. initialfield) then
- if (.not.over_critical_angle) then
- call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = mul_relaxed*(dxUz + dzUx)
- traction_z_t0 = lambdal_relaxed*dxUx + (lambdal_relaxed+2*mul_relaxed)*dzUz
- else
- veloc_horiz=v0x_bot(count_bottom)
- veloc_vert=v0z_bot(count_bottom)
- traction_x_t0=t0x_bot(count_bottom)
- traction_z_t0=t0z_bot(count_bottom)
- count_bottom=count_bottom+1
- end if
- else
- veloc_horiz = 0
- veloc_vert = 0
- traction_x_t0 = 0
- traction_z_t0 = 0
- endif
-
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- csl = vsext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
-
- rho_vp = rhol*cpl
- rho_vs = rhol*csl
-
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
-
- weight = jacobian1D * wxgll(i)
-
- ! Clayton-Engquist condition if elastic
- if(elastic(ispec)) then
- vx = veloc_elastic(1,iglob) - veloc_horiz
- vy = veloc_elastic(2,iglob)
- vz = veloc_elastic(3,iglob) - veloc_vert
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- ty = rho_vs*vy
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
- accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz + traction_z_t0)*weight
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- if(p_sv)then !P-SV waves
- b_absorb_elastic_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
- b_absorb_elastic_bottom(3,i,ib_bottom(ispecabs),it) = tz*weight
- else!SH (membrane) waves
- b_absorb_elastic_bottom(2,i,ib_bottom(ispecabs),it) = ty*weight
- endif
- elseif(SIMULATION_TYPE == 2) then
- if(p_sv)then !P-SV waves
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
- b_absorb_elastic_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
- b_absorb_elastic_bottom(3,i,ib_bottom(ispecabs),NSTEP-it+1)
- else!SH (membrane) waves
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
- b_absorb_elastic_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
- endif
- endif
-
- endif
-
- enddo
-
- endif ! end of bottom absorbing boundary
-
- !--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
-
- j = NGLLZ
-
- ! exclude corners to make sure there is no contradiction on the normal
- ibegin = 1
- iend = NGLLX
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
-
- do i = ibegin,iend
-
- iglob = ibool(i,j,ispec)
-
- ! for analytical initial plane wave for Bielak's conditions
- ! top or bottom edge, vertical normal vector
- if(add_Bielak_conditions .and. initialfield) then
- call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
- x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
- c_inc, c_refl, time_offset,f0)
- traction_x_t0 = mul_relaxed*(dxUz + dzUx)
- traction_z_t0 = lambdal_relaxed*dxUx + (lambdal_relaxed+2*mul_relaxed)*dzUz
- else
- veloc_horiz = 0
- veloc_vert = 0
- traction_x_t0 = 0
- traction_z_t0 = 0
- endif
-
- ! external velocity model
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- csl = vsext(i,j,ispec)
- rhol = rhoext(i,j,ispec)
- endif
-
- rho_vp = rhol*cpl
- rho_vs = rhol*csl
-
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
-
- weight = jacobian1D * wxgll(i)
-
- ! Clayton-Engquist condition if elastic
- if(elastic(ispec)) then
- vx = veloc_elastic(1,iglob) - veloc_horiz
- vy = veloc_elastic(2,iglob)
- vz = veloc_elastic(3,iglob) - veloc_vert
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- ty = rho_vs*vy
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
- accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz - traction_z_t0)*weight
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
- if(p_sv)then !P-SV waves
- b_absorb_elastic_top(1,i,ib_top(ispecabs),it) = tx*weight
- b_absorb_elastic_top(3,i,ib_top(ispecabs),it) = tz*weight
- else!SH (membrane) waves
- b_absorb_elastic_top(2,i,ib_top(ispecabs),it) = ty*weight
- endif
- elseif(SIMULATION_TYPE == 2) then
- if(p_sv)then !P-SV waves
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_top(1,i,ib_top(ispecabs),NSTEP-it+1)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - b_absorb_elastic_top(3,i,ib_top(ispecabs),NSTEP-it+1)
- else!SH (membrane) waves
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_top(2,i,ib_top(ispecabs),NSTEP-it+1)
- endif
- endif
-
- endif
-
- enddo
-
- endif ! end of top absorbing boundary
-
- enddo
-
- endif ! end of absorbing boundaries
-
- ! --- add the source if it is a moment tensor
- if(.not. initialfield) then
-
- do i_source=1,NSOURCES
- ! if this processor carries the source and the source element is elastic
- if (is_proc_source(i_source) == 1 .and. elastic(ispec_selected_source(i_source))) then
-
- ! moment tensor
- if(source_type(i_source) == 2) then
-
- if(.not.p_sv) call exit_MPI('cannot have moment tensor source in SH (membrane) waves calculation')
-
- if(SIMULATION_TYPE == 1) then ! forward wavefield
- ! add source array
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- accel_elastic(1,iglob) = accel_elastic(1,iglob) + &
- sourcearray(i_source,1,i,j)*source_time_function(i_source,it)
- accel_elastic(3,iglob) = accel_elastic(3,iglob) + &
- sourcearray(i_source,2,i,j)*source_time_function(i_source,it)
- enddo
- enddo
- else ! backward wavefield
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + &
- sourcearray(i_source,1,i,j)*source_time_function(i_source,NSTEP-it+1)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) + &
- sourcearray(i_source,2,i,j)*source_time_function(i_source,NSTEP-it+1)
- enddo
- enddo
- endif !endif SIMULATION_TYPE == 1
-
- endif !if(source_type(i_source) == 2)
-
- endif ! if this processor carries the source and the source element is elastic
- enddo ! do i_source=1,NSOURCES
-
- if(SIMULATION_TYPE == 2) then ! adjoint wavefield
-
- irec_local = 0
- do irec = 1,nrec
- ! add the source (only if this proc carries the source)
- if(myrank == which_proc_receiver(irec)) then
-
- irec_local = irec_local + 1
- if(elastic(ispec_selected_rec(irec))) then
- ! add source array
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_rec(irec))
- if(p_sv)then !P-SH waves
- accel_elastic(1,iglob) = accel_elastic(1,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
- accel_elastic(3,iglob) = accel_elastic(3,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
- else !SH (membrane) waves
- accel_elastic(2,iglob) = accel_elastic(2,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,2,i,j)
- endif
- enddo
- enddo
- endif ! if element is elastic
-
- endif ! if this processor carries the adjoint source and the source element is elastic
- enddo ! irec = 1,nrec
-
- endif ! if SIMULATION_TYPE == 2 adjoint wavefield
-
- endif ! if not using an initial field
-
- ! implement attenuation
- if(TURN_ATTENUATION_ON) then
-
- ! compute Grad(displ_elastic) at time step n+1 for attenuation
- call compute_gradient_attenuation(displ_elastic,dux_dxl_np1,duz_dxl_np1, &
- dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
-
- ! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
- ! loop over spectral elements
- do ispec = 1,nspec
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
- theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
- theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
-
- ! loop on all the standard linear solids
- do i_sls = 1,N_SLS
-
- ! evolution e1
- Un = e1(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu1(i,j,ispec,i_sls)
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = theta_n * phi_nu1(i,j,ispec,i_sls)
- Snp1 = theta_np1 * phi_nu1(i,j,ispec,i_sls)
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e1(i,j,ispec,i_sls) = Unp1
-
- ! evolution e11
- Un = e11(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i,j,ispec,i_sls)
- Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i,j,ispec,i_sls)
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e11(i,j,ispec,i_sls) = Unp1
-
- ! evolution e13
- Un = e13(i,j,ispec,i_sls)
- tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
- Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e13(i,j,ispec,i_sls) = Unp1
-
- enddo
-
- enddo
- enddo
- enddo
-
- endif ! end of test on attenuation
-
-end subroutine compute_forces_viscoelastic
-
Deleted: seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,126 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_gradient_attenuation(displ_elastic,dux_dxl,duz_dxl,dux_dzl,duz_dzl, &
- xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
-
-! compute Grad(displ_elastic) for attenuation
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,npoin
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- logical, dimension(nspec) :: elastic
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
- real(kind=CUSTOM_REAL), dimension(3,npoin) :: displ_elastic
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
-! local variables
- integer :: i,j,k,ispec
-
-! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
-
-! jacobian
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
-
-! loop over spectral elements
- do ispec = 1,nspec
-
-!---
-!--- elastic spectral element
-!---
- if(elastic(ispec)) then
-
-! first double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
-! derivative along x and along z
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
-! derivatives of displacement
- dux_dxl(i,j,ispec) = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl(i,j,ispec) = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl(i,j,ispec) = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl(i,j,ispec) = duz_dxi*xizl + duz_dgamma*gammazl
-
- enddo
- enddo
-
- endif
-
- enddo
-
- end subroutine compute_gradient_attenuation
-
Deleted: seismo/2D/SPECFEM2D/trunk/compute_normal_vector.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_normal_vector.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_normal_vector.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,122 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine compute_normal_vector( angle, n1_x, n2_x, n3_x, n4_x, n1_z, n2_z, n3_z, n4_z )
-
- implicit none
-
- include 'constants.h'
-
- double precision :: angle
- double precision :: n1_x, n2_x, n3_x, n4_x, n1_z, n2_z, n3_z, n4_z
-
- double precision :: theta1, theta2, theta3
- double precision :: costheta1, costheta2, costheta3
-
- if ( abs(n2_z - n1_z) < TINYVAL ) then
- costheta1 = 0
- else
- costheta1 = (n2_z - n1_z) / sqrt((n2_x - n1_x)**2 + (n2_z - n1_z)**2)
- endif
- if ( abs(n3_z - n2_z) < TINYVAL ) then
- costheta2 = 0
- else
- costheta2 = (n3_z - n2_z) / sqrt((n3_x - n2_x)**2 + (n3_z - n2_z)**2)
- endif
- if ( abs(n4_z - n3_z) < TINYVAL ) then
- costheta3 = 0
- else
- costheta3 = (n4_z - n3_z) / sqrt((n4_x - n3_x)**2 + (n4_z - n3_z)**2)
- endif
-
- theta1 = - sign(1.d0,n2_x - n1_x) * acos(costheta1)
- theta2 = - sign(1.d0,n3_x - n2_x) * acos(costheta2)
- theta3 = - sign(1.d0,n4_x - n3_x) * acos(costheta3)
-
- ! a sum is needed here because in the case of a source force vector
- ! users can give an angle with respect to the normal to the topography surface,
- ! in which case we must compute the normal to the topography
- ! and add it the existing rotation angle
- angle = angle + (theta1 + theta2 + theta3) / 3.d0 + PI/2.d0
-
- end subroutine compute_normal_vector
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine tri_quad(n, n1, nnodes)
-
- implicit none
-
- integer :: n1, nnodes
- integer, dimension(4) :: n
-
-
- n(2) = n1
-
- if ( n1 == 1 ) then
- n(1) = nnodes
- else
- n(1) = n1-1
- endif
-
- if ( n1 == nnodes ) then
- n(3) = 1
- else
- n(3) = n1+1
- endif
-
- if ( n(3) == nnodes ) then
- n(4) = 1
- else
- n(4) = n(3)+1
- endif
-
-
- end subroutine tri_quad
-
Deleted: seismo/2D/SPECFEM2D/trunk/compute_pressure.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_pressure.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_pressure.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,493 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,&
- displs_poroelastic,displw_poroelastic,elastic,poroelastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
- npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,e1,e11, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
-
-! compute pressure in acoustic elements and in elastic elements
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,npoin,numat
-
-
- integer, dimension(nspec) :: kmato
- integer, dimension(NGLLX,NGLLX,nspec) :: ibool
-
- double precision, dimension(2,numat) :: density
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(6,numat) :: anisotropy
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
- double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
- logical, dimension(nspec) :: elastic,poroelastic,anisotropic
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_dot_dot_acoustic
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
-
- double precision, dimension(3,npoin) :: vector_field_display
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
- logical :: assign_external_model,TURN_ATTENUATION_ON
-
- integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
-
-! local variables
- integer :: i,j,ispec,iglob
-
-! pressure in this element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
-
-! loop over spectral elements
- do ispec = 1,nspec
-
-! compute pressure in this element
- call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
- displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
- npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
-
-! use vector_field_display as temporary storage, store pressure in its second component
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- vector_field_display(3,iglob) = pressure_element(i,j)
- enddo
- enddo
-
- enddo
-
- end subroutine compute_pressure_whole_medium
-
-!
-!=====================================================================
-!
-
- subroutine compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
- displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
- npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
-
-! compute pressure in acoustic elements and in elastic elements
-
- implicit none
-
- include "constants.h"
-
- integer nspec,numat,ispec
-
- integer, dimension(nspec) :: kmato
- integer, dimension(NGLLX,NGLLX,nspec) :: ibool
-
- double precision, dimension(2,numat) :: density
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(6,numat) :: anisotropy
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
- double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
-! pressure in this element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
-
- logical, dimension(nspec) :: elastic,poroelastic,anisotropic
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_dot_dot_acoustic
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
- logical :: assign_external_model,TURN_ATTENUATION_ON
-
- integer :: N_SLS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
- real(kind=CUSTOM_REAL) :: e1_sum,e11_sum
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
- integer :: i_sls
-
-! local variables
- integer :: i,j,k,iglob
-
-! jacobian
- real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
-
-! spatial derivatives
- real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
- real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: sigma_xx,sigma_zz,sigmap
- real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
- real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dzl
-
-! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,denst
- real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed,cpl,csl
-
- real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
- real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
- real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
- real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
- real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
-
-! for anisotropy
- double precision :: c11,c15,c13,c33,c35,c55
-
-! if elastic element
-!
-! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction,
-! J. Engrg. Mech., vol. 132(11), p. 1205-1214 (2006), below equation (5):
-! for a 3D isotropic solid, pressure is defined in terms of the trace of the stress tensor as
-! p = -1/3 (t11 + t22 + t33) where t is the Cauchy stress tensor.
-
-! to compute pressure in 3D in an elastic solid, one uses pressure = - trace(sigma) / 3
-! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
-! = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_ij
-! sigma_xx = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_xx
-! sigma_yy = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_yy
-! sigma_zz = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_zz
-! pressure = - trace(sigma) / 3 = - (lambda + 2/3 mu) trace(epsilon) = - kappa * trace(epsilon)
-!
-! to compute pressure in 2D in an elastic solid, one uses pressure = - trace(sigma) / 2
-! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
-! = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_ij
-! sigma_xx = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_xx
-! sigma_yy = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_yy
-! pressure = - trace(sigma) / 2 = - (lambda + mu) trace(epsilon)
-!
-
-
- if(elastic(ispec)) then
-
- ! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec))
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- !--- if external medium, get elastic parameters of current grid point
- if(assign_external_model) then
- cpl = vpext(i,j,ispec)
- csl = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- mul_relaxed = denst*csl*csl
- lambdal_relaxed = denst*cpl*cpl - TWO*mul_relaxed
- endif
-
- ! derivative along x and along z
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- ! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
-! compute diagonal components of the stress tensor (include attenuation or anisotropy if needed)
-
- if(TURN_ATTENUATION_ON) then
-
-! attenuation is implemented following the memory variable formulation of
-! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
-! vol. 58(1), p. 110-120 (1993). More details can be found in
-! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
-! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
-
- ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(i,j,ispec) &
- - mul_relaxed * Mu_nu2(i,j,ispec)
- mul_unrelaxed = mul_relaxed * Mu_nu2(i,j,ispec)
- lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
-
- ! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
- sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
- sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
-
- ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
- ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
- e1_sum = 0._CUSTOM_REAL
- e11_sum = 0._CUSTOM_REAL
-
- do i_sls = 1,N_SLS
- e1_sum = e1_sum + e1(i,j,ispec,i_sls)
- e11_sum = e11_sum + e11(i,j,ispec,i_sls)
- enddo
-
- sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum &
- + TWO * mul_relaxed * e11_sum
- sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum &
- - TWO * mul_relaxed * e11_sum
-
- else
-
- ! no attenuation
- sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
- sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
-
- endif
-
- ! full anisotropy
- if(anisotropic(ispec)) then
- if(assign_external_model) then
- c11 = c11ext(i,j,ispec)
- c15 = c15ext(i,j,ispec)
- c13 = c13ext(i,j,ispec)
- c33 = c33ext(i,j,ispec)
- c35 = c35ext(i,j,ispec)
- c55 = c55ext(i,j,ispec)
- else
- c11 = anisotropy(1,kmato(ispec))
- c13 = anisotropy(2,kmato(ispec))
- c15 = anisotropy(3,kmato(ispec))
- c33 = anisotropy(4,kmato(ispec))
- c35 = anisotropy(5,kmato(ispec))
- c55 = anisotropy(6,kmato(ispec))
- endif
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- ! implement anisotropy in 2D
- sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
- sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
-
- endif
-
- ! store pressure
- pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
-
- enddo
- enddo
-
- elseif(poroelastic(ispec)) then
-
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
-
- ! get poroelastic parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- !solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
- rhol_s = density(1,kmato(ispec))
- !fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
- !frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
- rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
- !Biot coefficients for the input phi
- D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
- + kappal_fr + FOUR_THIRDS*mul_fr
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
- !where T = G:grad u_s + C div w I
- !and T_f = C div u_s I + M div w I
- !we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
- mul_G = mul_fr
- lambdal_G = H_biot - TWO*mul_fr
- lambdalplus2mul_G = lambdal_G + TWO*mul_G
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- ! derivative along x and along z
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- ! first double loop over GLL points to compute and store gradients
- ! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
-
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- ! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
-! compute diagonal components of the stress tensor (include attenuation if needed)
-
- if(TURN_ATTENUATION_ON) then
-!-------------------- ATTENTION TO BE DEFINED ------------------------------!
-
-! attenuation is implemented following the memory variable formulation of
-! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
-! vol. 58(1), p. 110-120 (1993). More details can be found in
-! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
-! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
-
- ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(i,j,ispec) &
- - mul_relaxed * Mu_nu2(i,j,ispec)
- mul_unrelaxed = mul_relaxed * Mu_nu2(i,j,ispec)
- lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
-
- ! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
- sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
- sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
-
- ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
- ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
- e1_sum = 0._CUSTOM_REAL
- e11_sum = 0._CUSTOM_REAL
-
- do i_sls = 1,N_SLS
- e1_sum = e1_sum + e1(i,j,ispec,i_sls)
- e11_sum = e11_sum + e11(i,j,ispec,i_sls)
- enddo
-
- sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum &
- + TWO * mul_relaxed * e11_sum
- sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum &
- - TWO * mul_relaxed * e11_sum
-
- else
-
- ! no attenuation
- sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
-
- endif
-
- ! store pressure
- pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
-! pressure_element2(i,j) = - sigmap
- enddo
- enddo
-
-! pressure = - Chi_dot_dot if acoustic element
- else
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- ! store pressure
- pressure_element(i,j) = - potential_dot_dot_acoustic(iglob)
-
- enddo
- enddo
-
- endif ! end of test if acoustic or elastic element
-
- end subroutine compute_pressure_one_element
-
Deleted: seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,235 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine compute_vector_whole_medium(potential_acoustic,veloc_elastic,velocs_poroelastic,&
- elastic,poroelastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
- nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
-! compute Grad(potential) in acoustic elements
-! and combine with existing velocity vector field in elastic elements
-
- implicit none
-
- include "constants.h"
-
- integer nspec,npoin,numat
-
- logical :: assign_external_model
- integer, dimension(nspec) :: kmato
- double precision, dimension(NGLLX,NGLLX,nspec) :: rhoext
- double precision, dimension(2,numat) :: density
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
- logical, dimension(nspec) :: elastic,poroelastic
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: veloc_elastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: velocs_poroelastic
-
- double precision, dimension(3,npoin) :: vector_field_display
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
-! local variables
- integer i,j,ispec,iglob
-
-! vector field in this element
- real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
-
-! loop over spectral elements
- do ispec = 1,nspec
-
-! compute vector field in this element
- call compute_vector_one_element(vector_field_element,potential_acoustic, &
- veloc_elastic,velocs_poroelastic, &
- elastic,poroelastic,xix,xiz,gammax,gammaz, &
- ibool,hprime_xx,hprime_zz, &
- nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- ispec,numat,kmato,density,rhoext,assign_external_model)
-
-! store the result
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- vector_field_display(:,iglob) = vector_field_element(:,i,j)
- enddo
- enddo
-
- enddo
-
- end subroutine compute_vector_whole_medium
-
-!
-!=====================================================================
-!
-
- subroutine compute_vector_one_element(vector_field_element,potential_acoustic, &
- veloc_elastic,velocs_poroelastic,&
- elastic,poroelastic,xix,xiz,gammax,gammaz, &
- ibool,hprime_xx,hprime_zz, &
- nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- ispec,numat,kmato,density,rhoext,assign_external_model)
-
-! compute Grad(potential) if acoustic element or copy existing vector if elastic element
-
- implicit none
-
- include "constants.h"
-
- integer nspec,ispec,numat
-
- logical :: assign_external_model
-
- integer, dimension(nspec) :: kmato
-
- double precision, dimension(NGLLX,NGLLX,nspec) :: rhoext
-
- double precision, dimension(2,numat) :: density
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
-
-! vector field in this element
- real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
-
- logical, dimension(nspec) :: elastic,poroelastic
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: veloc_elastic
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: velocs_poroelastic
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
-
-! local variables
- integer i,j,k,iglob
-
-! space derivatives
- real(kind=CUSTOM_REAL) tempx1l,tempx2l
- real(kind=CUSTOM_REAL) hp1,hp2
-
-! jacobian
- real(kind=CUSTOM_REAL) xixl,xizl,gammaxl,gammazl
-
-! material properties of the elastic medium
- real(kind=CUSTOM_REAL) :: rhol
-
-! simple copy of existing vector if elastic element
- if(elastic(ispec)) then
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- vector_field_element(1,i,j) = veloc_elastic(1,iglob)
- vector_field_element(2,i,j) = veloc_elastic(2,iglob)
- vector_field_element(3,i,j) = veloc_elastic(3,iglob)
- enddo
- enddo
-
- elseif(poroelastic(ispec)) then
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- vector_field_element(1,i,j) = velocs_poroelastic(1,iglob)
- vector_field_element(2,i,j) = 0._CUSTOM_REAL
- vector_field_element(3,i,j) = velocs_poroelastic(2,iglob)
- enddo
- enddo
-
-! compute gradient of potential to calculate vector if acoustic element
-! we then need to divide by density because the potential is a potential of (density * displacement)
- else
-
- rhol = density(1,kmato(ispec))
-
-! double loop over GLL points to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
-! derivative along x
- tempx1l = 0._CUSTOM_REAL
- do k = 1,NGLLX
- hp1 = hprime_xx(i,k)
- iglob = ibool(k,j,ispec)
- tempx1l = tempx1l + potential_acoustic(iglob)*hp1
- enddo
-
-! derivative along z
- tempx2l = 0._CUSTOM_REAL
- do k = 1,NGLLZ
- hp2 = hprime_zz(j,k)
- iglob = ibool(i,k,ispec)
- tempx2l = tempx2l + potential_acoustic(iglob)*hp2
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- if(assign_external_model) rhol = rhoext(i,j,ispec)
-
-! derivatives of potential
- vector_field_element(1,i,j) = (tempx1l*xixl + tempx2l*gammaxl) / rhol
- vector_field_element(2,i,j) = 0._CUSTOM_REAL
- vector_field_element(3,i,j) = (tempx1l*xizl + tempx2l*gammazl) / rhol
-
- enddo
- enddo
-
- endif ! end of test if acoustic or elastic element
-
- end subroutine compute_vector_one_element
-
Deleted: seismo/2D/SPECFEM2D/trunk/config.h.in
===================================================================
--- seismo/2D/SPECFEM2D/trunk/config.h.in 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/config.h.in 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,44 +0,0 @@
-/* config.h.in. Generated from configure.ac by autoheader. */
-
-/* Define to dummy `main' function (if any) required to link to the Fortran
- libraries. */
-#undef FC_DUMMY_MAIN
-
-/* Define if F77 and FC dummy `main' functions are identical. */
-#undef FC_DUMMY_MAIN_EQ_F77
-
-/* Define to a macro mangling the given C identifier (in lower and upper
- case), which must not contain underscores, for linking with Fortran. */
-#undef FC_FUNC
-
-/* As FC_FUNC, but for C identifiers containing underscores. */
-#undef FC_FUNC_
-
-/* Define to alternate name for `main' routine that is called from a `main' in
- the Fortran libraries. */
-#undef FC_MAIN
-
-/* defined if Scotch is installed */
-#undef HAVE_SCOTCH
-
-/* Define to the address where bug reports for this package should be sent. */
-#undef PACKAGE_BUGREPORT
-
-/* Define to the full name of this package. */
-#undef PACKAGE_NAME
-
-/* Define to the full name and version of this package. */
-#undef PACKAGE_STRING
-
-/* Define to the one symbol short name of this package. */
-#undef PACKAGE_TARNAME
-
-/* Define to the home page for this package. */
-#undef PACKAGE_URL
-
-/* Define to the version of this package. */
-#undef PACKAGE_VERSION
-
-/* Define to 1 if `lex' declares `yytext' as a `char *' by default, not a
- `char[]'. */
-#undef YYTEXT_POINTER
Deleted: seismo/2D/SPECFEM2D/trunk/constants.h.in
===================================================================
--- seismo/2D/SPECFEM2D/trunk/constants.h.in 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/constants.h.in 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,183 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 2 D V e r s i o n 6 . 1
-!
-!=====================================================================
-
-! @configure_input@
-
-!
-! solver in single or double precision depending on the machine (4 or 8 bytes)
-!
-! ALSO CHANGE FILE precision_mpi.h ACCORDINGLY
-!
- integer, parameter :: SIZE_REAL = 4
- integer, parameter :: SIZE_DOUBLE = 8
-
-
-! set to SIZE_REAL to run in single precision
-! set to SIZE_DOUBLE to run in double precision (increases memory size by 2)
-!
-! DO CHANGE precision_mpi.h accordingly
-!
- integer, parameter :: CUSTOM_REAL = @CUSTOM_REAL@
-
-!----------- parameters that can be changed by the user -----------
-
-! number of Gauss-Lobatto-Legendre (GLL) points (i.e., polynomial degree + 1)
- integer, parameter :: NGLLX = 5
-! the code does NOT work if NGLLZ /= NGLLX because it then cannot handle a non-structured mesh
-! due to non matching polynomial degrees along common edges
- integer, parameter :: NGLLZ = NGLLX
-
-! further reduce cache misses inner/outer in two passes in the case of an MPI simulation
-! this flag is ignored in the case of a serial simulation
- logical, parameter :: FURTHER_REDUCE_CACHE_MISSES = .true.
-
-! for inverse Cuthill-McKee (1969) permutation
- logical, parameter :: PERFORM_CUTHILL_MCKEE = .true.
- logical, parameter :: INVERSE = .true.
- logical, parameter :: FACE = .false.
- integer, parameter :: NGNOD_QUADRANGLE = 4
-! perform classical or multi-level Cuthill-McKee ordering
- logical, parameter :: CMcK_MULTI = .false.
-! maximum size if multi-level Cuthill-McKee ordering
- integer, parameter :: LIMIT_MULTI_CUTHILL = 50
-
-! implement Cuthill-McKee or replace with identity permutation
- logical, parameter :: ACTUALLY_IMPLEMENT_PERM_OUT = .false.
- logical, parameter :: ACTUALLY_IMPLEMENT_PERM_INN = .false.
- logical, parameter :: ACTUALLY_IMPLEMENT_PERM_WHOLE = .true.
-
-! add MPI barriers and suppress seismograms if we generate traces of the run for analysis with "ParaVer"
- logical, parameter :: GENERATE_PARAVER_TRACES = .false.
-
-! option to display only part of the mesh and not the whole mesh,
-! for instance to analyze Cuthill-McKee mesh partitioning etc.
-! Possible values are:
-! 1: display all the elements (i.e., the whole mesh)
-! 2: display inner elements only
-! 3: display outer elements only
-! 4: display a fixed number of elements (in each partition) only
- integer, parameter :: DISPLAY_SUBSET_OPTION = 1
-! number of spectral elements to display in each subset when a fixed subset size is used (option 4 above)
- integer, parameter :: NSPEC_DISPLAY_SUBSET = 2300
-
-! use this t0 as earliest starting time rather than the automatically calculated one
-! (must be positive and bigger than the automatically one to be effective;
-! simulation will start at t = - t0)
- double precision, parameter :: USER_T0 = 0.0d0
-
-!--- beginning of Nicolas Le Goff's constants for an unstructured CUBIT/METIS/SCOTCH mesh
-
-! maximum number of neighbors per element
- integer, parameter :: MAX_NEIGHBORS = 40
-
-! maximum number of elements that can contain the same node
- integer, parameter :: nsize = 40
-
-!--- end of Nicolas Le Goff's constants for an unstructured CUBIT/METIS/SCOTCH mesh
-
-! output file for energy
- integer, parameter :: IOUT_ENERGY = 77
-
-! select fast (Paul Fischer) or slow (topology only) global numbering algorithm
- logical, parameter :: FAST_NUMBERING = .true.
-
-! mesh tolerance for fast global numbering
- double precision, parameter :: SMALLVALTOL = 0.00001d0
-
-! displacement threshold above which we consider the code became unstable
- double precision, parameter :: STABILITY_THRESHOLD = 1.d+25
-
-! input and output files
- integer, parameter :: IIN = 40
- integer, parameter :: ISTANDARD_OUTPUT = 6
-! uncomment this to write to standard output
- integer, parameter :: IOUT = ISTANDARD_OUTPUT
-! uncomment this to write to file instead
-! integer, parameter :: IOUT = 41
-
-! number of lines per source in SOURCE file
- integer, parameter :: NLINES_PER_SOURCE = 13
-
-! flags for absorbing boundaries
- integer, parameter :: IBOTTOM = 1
- integer, parameter :: IRIGHT = 2
- integer, parameter :: ITOP = 3
- integer, parameter :: ILEFT = 4
-
-! number of edges and corners of each element
- integer, parameter :: NEDGES = 4
- integer, parameter :: NCORNERS = 4
-
-! a few useful constants
- double precision, parameter :: ZERO = 0.d0,ONE = 1.d0
- double precision, parameter :: HALF = 0.5d0,TWO = 2.d0,QUART = 0.25d0
-
-! pi
- double precision, parameter :: PI = 3.141592653589793d0
-
-! 4/3
- double precision, parameter :: FOUR_THIRDS = 4.d0/3.d0
-
-! 1/24
- double precision, parameter :: ONE_OVER_24 = 1.d0 / 24.d0
-
-! parameters to define the Gauss-Lobatto-Legendre points
- double precision, parameter :: GAUSSALPHA = ZERO,GAUSSBETA = ZERO
-
-! very large and very small values
- double precision, parameter :: HUGEVAL = 1.d+30,TINYVAL = 1.d-9
-
-! number of spatial dimensions
- integer, parameter :: NDIM = 2
-
-! maximum length of station and network name for receivers
- integer, parameter :: MAX_LENGTH_STATION_NAME = 32
- integer, parameter :: MAX_LENGTH_NETWORK_NAME = 8
-
-! number of iterations to solve the system for xi and eta
- integer, parameter :: NUM_ITER = 4
-
-! we mimic a triangle of half duration equal to half_duration_triangle
-! using a Gaussian having a very close shape, as explained in Figure 4.2
-! of the manual. This source decay rate to mimic an equivalent triangle
-! was found by trial and error
- double precision, parameter :: SOURCE_DECAY_MIMIC_TRIANGLE = 1.628d0
-
-! non linear display to enhance small amplitudes in color images
- double precision, parameter :: POWER_DISPLAY_COLOR = 0.30d0
-
-! US letter paper or European A4
- logical, parameter :: US_LETTER = .false.
-
-! X and Z axis origin of PostScript plot in centimeters
- double precision, parameter :: ORIG_X = 2.4d0
- double precision, parameter :: ORIG_Z = 2.9d0
-
-! dot to centimeter conversion for PostScript
- double precision, parameter :: CENTIM = 28.5d0
-
-! parameters for arrows for PostScript snapshot
- double precision, parameter :: ARROW_ANGLE = 20.d0
- double precision, parameter :: ARROW_RATIO = 0.40d0
-
-! size of frame used for Postscript display in percentage of the size of the page
- double precision, parameter :: RPERCENTX = 70.0d0,RPERCENTZ = 77.0d0
-
-! flag to indicate an isotropic elastic/acoustic material
- integer, parameter :: ISOTROPIC_MATERIAL = 1
-
-! flag to indicate an anisotropic material
- integer, parameter :: ANISOTROPIC_MATERIAL = 2
-
-! flag to indicate a poroelastic material
- integer, parameter :: POROELASTIC_MATERIAL = 3
-
-! file number for interface file
- integer, parameter :: IIN_INTERFACES = 15
-
-! ignore variable name field (junk) at the beginning of each input line
- logical, parameter :: IGNORE_JUNK = .true.,DONT_IGNORE_JUNK = .false.
-
Deleted: seismo/2D/SPECFEM2D/trunk/construct_acoustic_surface.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/construct_acoustic_surface.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/construct_acoustic_surface.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,194 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! From array 'surface' (element, type : node/edge, node(s) ) that describes the
-! acoustic free surface, determines the points (ixmin, ixmax, izmin and izmax) on the surface
-! for each element.
-! We chose to have ixmin <= ixmax and izmin <= izmax, so as to be able to have DO loops on it with
-! an increment of +1.
-!
-subroutine construct_acoustic_surface ( nspec, ngnod, knods, nsurface, surface, tab_surface )
-
- implicit none
-
- integer, intent(in) :: nspec
- integer, intent(in) :: ngnod
- integer, dimension(ngnod,nspec), intent(in) :: knods
- integer, intent(in) :: nsurface
- integer, dimension(4,nsurface), intent(in) :: surface
- integer, dimension(5,nsurface), intent(out) :: tab_surface
-
- integer :: i, k
- integer :: ixmin, ixmax
- integer :: izmin, izmax
- integer, dimension(ngnod) :: n
- integer :: e1, e2
- integer :: type
-
- do i = 1, nsurface
- tab_surface(1,i) = surface(1,i)
- type = surface(2,i)
- e1 = surface(3,i)
- e2 = surface(4,i)
- do k = 1, ngnod
- n(k) = knods(k,tab_surface(1,i))
- enddo
-
- call get_acoustic_edge ( ngnod, n, type, e1, e2, ixmin, ixmax, izmin, izmax )
-
- tab_surface(2,i) = ixmin
- tab_surface(3,i) = ixmax
- tab_surface(4,i) = izmin
- tab_surface(5,i) = izmax
-
- enddo
-
-end subroutine construct_acoustic_surface
-
-
-!-----------------------------------------------
-! Get the points (ixmin, ixmax, izmin and izmax) on an node/edge for one element.
-!-----------------------------------------------
-subroutine get_acoustic_edge ( ngnod, n, type, e1, e2, ixmin, ixmax, izmin, izmax )
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: ngnod
- integer, dimension(ngnod), intent(in) :: n
- integer, intent(in) :: type, e1, e2
- integer, intent(out) :: ixmin, ixmax, izmin, izmax
-
-
- if ( type == 1 ) then
- if ( e1 == n(1) ) then
- ixmin = 1
- ixmax = 1
- izmin = 1
- izmax = 1
- endif
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- izmin = 1
- izmax = 1
- endif
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- izmin = NGLLZ
- izmax = NGLLZ
- endif
- if ( e1 == n(4) ) then
- ixmin = 1
- ixmax = 1
- izmin = NGLLZ
- izmax = NGLLZ
- endif
-
- else
- if ( e1 == n(1) ) then
- ixmin = 1
- izmin = 1
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- izmax = 1
-
- endif
- if ( e2 == n(4) ) then
- ixmax = 1
- izmax = NGLLZ
-
- endif
- endif
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- izmin = 1
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- izmax = NGLLZ
-
- endif
- if ( e2 == n(1) ) then
- ixmax = ixmin
- ixmin = 1
- izmax = 1
-
- endif
- endif
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- izmin = NGLLZ
- if ( e2 == n(4) ) then
- ixmax = ixmin
- ixmin = 1
- izmax = NGLLZ
-
- endif
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- izmax = izmin
- izmin = 1
-
- endif
- endif
- if ( e1 == n(4) ) then
- ixmin = 1
- izmin = NGLLZ
- if ( e2 == n(1) ) then
- ixmax = 1
- izmax = izmin
- izmin = 1
-
- endif
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- izmax = NGLLZ
-
- endif
- endif
- endif
-
-end subroutine get_acoustic_edge
-
Deleted: seismo/2D/SPECFEM2D/trunk/convert_time.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/convert_time.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/convert_time.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,235 +0,0 @@
-
-! open-source subroutines taken from the World Ocean Circulation Experiment (WOCE)
-! web site at http://www.coaps.fsu.edu/woce/html/wcdtools.htm
-
-! converted to Fortran90 by Dimitri Komatitsch,
-! University of Pau, France, January 2008.
-! Also converted "convtime" from a function to a subroutine.
-! Also used a more complete test to detect leap years (the original version was incomplete).
-
- subroutine convtime(timestamp,yr,mon,day,hr,min)
-
-! Originally written by Shawn Smith (smith AT coaps.fsu.edu)
-! Updated Spring 1999 for Y2K compliance by Anthony Arguez (anthony AT coaps.fsu.edu).
-
-! This subroutine will convert a given year, month, day, hour, and
-! minutes to a minutes from 01 Jan 1980 00:00 time stamp.
-
- implicit none
-
- integer, intent(out) :: timestamp
-
- integer, intent(in) :: yr,mon,day,hr,min
-
- integer :: year(1980:2020),month(12),leap_mon(12)
-
- integer :: min_day,min_hr
-
-! function to determine if year is a leap year
- logical, external :: is_leap_year
-
- data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
- 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
- 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
- 9993600, 10519200, 11046240, 11571840, 12097440, &
- 12623040, 13150080, 13675680, 14201280, 14726880, &
- 15253920, 15779520, 16305120, 16830720, 17357760, &
- 17883360, 18408960, 18934560, 19461600, 19987200, &
- 20512800, 21038400/
-
- data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
- 305280, 349920, 393120, 437760, 480960/
-
- data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
- 306720, 351360, 394560, 439200, 482400/
-
- data min_day, min_hr /1440, 60/
-
-! Test values to see if they fit valid ranges
- if (yr < 1980 .or. yr > 2020) stop 'Error in convtime: year out of range (1980-2020)'
-
- if (mon < 1 .or. mon > 12) stop 'Error in convtime: month out of range (1-12)'
-
- if (mon == 2) then
- if (is_leap_year(yr) .and. (day < 1 .or. day > 29)) then
- stop 'Error in convtime: February day out of range (1-29)'
- elseif (.not. is_leap_year(yr) .and. (day < 1 .or. day > 28)) then
- stop 'Error in convtime: February day out of range (1-28)'
- endif
- elseif (mon == 4 .or. mon == 6 .or. mon == 9 .or. mon == 11) then
- if (day < 1 .or. day > 30) stop 'Error in convtime: day out of range (1-30)'
- else
- if (day < 1 .or. day > 31) stop 'Error in convtime: day out of range (1-31)'
- endif
-
- if (hr < 0 .or. hr > 23) stop 'Error in convtime: hour out of range (0-23)'
-
- if (min < 0 .or. min > 60) stop 'Error in convtime: minute out of range (0-60)'
-
-! convert time (test if leap year)
- if (is_leap_year(yr)) then
- timestamp = year(yr)+leap_mon(mon)+((day-1)*min_day)+(hr*min_hr)+min
- else
- timestamp = year(yr)+month(mon)+((day-1)*min_day)+(hr*min_hr)+min
- endif
-
- end subroutine convtime
-
-!
-!----
-!
-
- subroutine invtime(timestamp,yr,mon,day,hr,min)
-
-! This subroutine will convert a minutes timestamp to a year/month
-! date. Based on the function convtime by Shawn Smith (COAPS).
-!
-! Written the spring of 1995, several iterations.
-! James N. Stricherz (stricherz AT coaps.fsu.edu)
-!
-! Updated for Y2K compliance in July 1999.
-! Shyam Lakshmin (lakshmin AT coaps.fsu.edu)
-!
-! This code returns correct results for the range of 01 Jan 1980 00:00
-! thru 31 Dec 2020 23:59. I know it does, because I tried each minute of that range.
-
- implicit none
-
- integer, intent(in) :: timestamp
-
- integer, intent(out) :: yr,mon,day,hr,min
-
- integer :: year(1980:2021),month(13),leap_mon(13)
-
- integer :: min_day,min_hr,itime,tmon,ttime,thour,iyr,imon,iday,ihour
-
-! function to determine if year is a leap year
- logical, external :: is_leap_year
-
- data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
- 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
- 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
- 9993600, 10519200, 11046240, 11571840, 12097440, &
- 12623040, 13150080, 13675680, 14201280, 14726880, &
- 15253920, 15779520, 16305120, 16830720, 17357760, &
- 17883360, 18408960, 18934560, 19461600, 19987200, &
- 20512800, 21038400, 21565440/
-
- data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
- 305280, 349920, 393120, 437760, 480960,525600/
-
- data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
- 306720, 351360, 394560, 439200, 482400,527040/
-
- data min_day, min_hr /1440, 60/
-
-! ok, let us invert the effects of the years: subtract off the
-! number of minutes per year until it goes negative
-! iyr then gives the year that the time (in minutes) occurs
- if (timestamp >= year(2021)) stop 'year too high in invtime'
-
- iyr=1979
- itime=timestamp
-
- 10 iyr=iyr+1
- ttime=itime-year(iyr)
- if (ttime <= 0) then
- if (iyr == 1980) iyr=iyr+1
- iyr=iyr-1
- itime=itime-year(iyr)
- else
- goto 10
- endif
-
-! assign the return variable
- yr=iyr
-
-! ok, the remaining time is less than one full year, so convert
-! by the same method as above into months
- imon=0
-
-! if not leap year
- if (.not. is_leap_year(iyr)) then
-
-! increment the month, and subtract off the minutes from the
-! remaining time for a non-leap year
- 20 imon=imon+1
- tmon=itime-month(imon)
- if (tmon > 0) then
- goto 20
- else if (tmon < 0) then
- imon=imon-1
- itime=itime-month(imon)
- else
- if (imon > 12) then
- imon=imon-12
- yr=yr+1
- endif
- mon=imon
- day=1
- hr=0
- min=0
- return
- endif
-
-! if leap year
- else
-
-! same thing, same code, but for a leap year
- 30 imon=imon+1
- tmon=itime-leap_mon(imon)
- if (tmon > 0) then
- goto 30
- elseif (tmon < 0) then
- imon=imon-1
- itime=itime-month(imon)
- else
- if (imon > 12) then
- imon=imon-12
- yr=yr+1
- endif
- mon=imon
- day=1
- hr=0
- min=0
- return
- endif
- endif
-
-! assign the return variable
- mon=imon
-
-! any remaining minutes will belong to day/hour/minutes
-! ok, let us get the days
- iday=0
- 40 iday=iday+1
- ttime=itime-min_day
- if (ttime >= 0) then
- itime=ttime
- goto 40
- endif
-
-! assign the return variable
- if (is_leap_year(iyr) .and. mon > 2) then
- day=iday-1
- else
- day=iday
- endif
-
-! pick off the hours of the days...remember, hours can be 0, so we start at -1
- ihour=-1
- 50 ihour=ihour+1
- thour=itime-min_hr
- if (thour >= 0) then
- itime=thour
- goto 50
- endif
-
-! assign the return variables
- hr=ihour
-
-! the remainder at this point is the minutes, so return them directly
- min=itime
-
- end subroutine invtime
-
Deleted: seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,152 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- program convolve_source_time_function
-
-!
-! convolve seismograms computed for a Heaviside with given source time function
-!
-
-! we mimic a triangle of half duration equal to half_duration_triangle
-! using a Gaussian having a very close shape, as explained in Figure 4.2
-! of the manual
-
- implicit none
-
- include "constants.h"
-
- integer :: i,j,N_j,number_remove,nlines
-
- double precision :: alpha,dt,tau_j,source,exponent,t1,t2,displ1,displ2,gamma,height,half_duration_triangle
-
- logical :: triangle
-
- double precision, dimension(:), allocatable :: time,sem,sem_fil
-
-! read file with number of lines in input
- open(unit=33,file='input_convolve_code.txt',status='old',action='read')
- read(33,*) nlines
- read(33,*) half_duration_triangle
- read(33,*) triangle
- close(33)
-
-! allocate arrays
- allocate(time(nlines),sem(nlines),sem_fil(nlines))
-
-! read the input seismogram
- do i = 1,nlines
- read(5,*) time(i),sem(i)
- enddo
-
-! define a Gaussian with the right exponent to mimic a triangle of equivalent half duration
- alpha = SOURCE_DECAY_MIMIC_TRIANGLE/half_duration_triangle
-
-! compute the time step
- dt = time(2) - time(1)
-
-! number of integers for which the source wavelet is different from zero
- if(triangle) then
- N_j = ceiling(half_duration_triangle/dt)
- else
- N_j = ceiling(1.5d0*half_duration_triangle/dt)
- endif
-
- do i = 1,nlines
-
- sem_fil(i) = 0.d0
-
- do j = -N_j,N_j
-
- if(i > j .and. i-j <= nlines) then
-
- tau_j = dble(j)*dt
-
-! convolve with a triangle
- if(triangle) then
- height = 1.d0 / half_duration_triangle
- if(abs(tau_j) > half_duration_triangle) then
- source = 0.d0
- else if (tau_j < 0.d0) then
- t1 = - N_j * dt
- displ1 = 0.d0
- t2 = 0.d0
- displ2 = height
- gamma = (tau_j - t1) / (t2 - t1)
- source= (1.d0 - gamma) * displ1 + gamma * displ2
- else
- t1 = 0.d0
- displ1 = height
- t2 = + N_j * dt
- displ2 = 0.d0
- gamma = (tau_j - t1) / (t2 - t1)
- source= (1.d0 - gamma) * displ1 + gamma * displ2
- endif
-
- else
-
-! convolve with a Gaussian
- exponent = alpha**2 * tau_j**2
- if(exponent < 50.d0) then
- source = alpha*exp(-exponent)/sqrt(PI)
- else
- source = 0.d0
- endif
-
- endif
-
- sem_fil(i) = sem_fil(i) + sem(i-j)*source*dt
-
- endif
-
- enddo
- enddo
-
-! compute number of samples to remove from end of seismograms
- number_remove = N_j + 1
- do i=1,nlines - number_remove
- write(*,*) sngl(time(i)),' ',sngl(sem_fil(i))
- enddo
-
- end program convolve_source_time_function
-
Deleted: seismo/2D/SPECFEM2D/trunk/create_color_image.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/create_color_image.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/create_color_image.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,267 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine create_color_image(color_image_2D_data,iglob_image_color_2D, &
- NX,NY,it,cutsnaps,image_color_vp_display)
-
-! display a given field as a red and blue color image
-
-! to display the snapshots : display image*.gif
-
-! when compiling with Intel ifort, use " -assume byterecl " option to create binary PNM images
-
- implicit none
-
- include "constants.h"
-
- integer :: NX,NY,it
-
- double precision :: cutsnaps
-
- integer, dimension(NX,NY) :: iglob_image_color_2D
-
- double precision, dimension(NX,NY) :: color_image_2D_data
- double precision, dimension(NX,NY) :: image_color_vp_display
-
- integer :: ix,iy,R,G,B,tenthousands,thousands,hundreds,tens,units,remainder,current_rec
-
- double precision :: amplitude_max,normalized_value,vpmin,vpmax,x1
-
- character(len=100) :: file_name,system_command
-
-! create temporary image files in binary PNM P6 format (smaller) or ASCII PNM P3 format (easier to edit)
- logical, parameter :: BINARY_FILE = .true.
-
-! ASCII code of character '0' and of carriage return character
- integer, parameter :: ascii_code_of_zero = 48, ascii_code_of_carriage_return = 10
-
-! open the image file
- write(file_name,"('OUTPUT_FILES/image',i7.7,'.pnm')") it
-
- if(BINARY_FILE) then
-
- open(unit=27,file=file_name,status='unknown',access='direct',recl=1)
- write(27,rec=1) 'P'
- write(27,rec=2) '6' ! write P6 = binary PNM image format
- write(27,rec=3) char(ascii_code_of_carriage_return)
-
-! compute and write horizontal size
- remainder = NX
-
- tenthousands = remainder / 10000
- remainder = remainder - 10000 * tenthousands
-
- thousands = remainder / 1000
- remainder = remainder - 1000 * thousands
-
- hundreds = remainder / 100
- remainder = remainder - 100 * hundreds
-
- tens = remainder / 10
- remainder = remainder - 10 * tens
-
- units = remainder
-
- write(27,rec=4) char(tenthousands + ascii_code_of_zero)
- write(27,rec=5) char(thousands + ascii_code_of_zero)
- write(27,rec=6) char(hundreds + ascii_code_of_zero)
- write(27,rec=7) char(tens + ascii_code_of_zero)
- write(27,rec=8) char(units + ascii_code_of_zero)
- write(27,rec=9) ' '
-
-! compute and write vertical size
- remainder = NY
-
- tenthousands = remainder / 10000
- remainder = remainder - 10000 * tenthousands
-
- thousands = remainder / 1000
- remainder = remainder - 1000 * thousands
-
- hundreds = remainder / 100
- remainder = remainder - 100 * hundreds
-
- tens = remainder / 10
- remainder = remainder - 10 * tens
-
- units = remainder
-
- write(27,rec=10) char(tenthousands + ascii_code_of_zero)
- write(27,rec=11) char(thousands + ascii_code_of_zero)
- write(27,rec=12) char(hundreds + ascii_code_of_zero)
- write(27,rec=13) char(tens + ascii_code_of_zero)
- write(27,rec=14) char(units + ascii_code_of_zero)
- write(27,rec=15) char(ascii_code_of_carriage_return)
-
-! number of shades
- write(27,rec=16) '2'
- write(27,rec=17) '5'
- write(27,rec=18) '5'
- write(27,rec=19) char(ascii_code_of_carriage_return)
-
-! block of image data starts at sixteenth character
- current_rec = 20
-
- else
-
- open(unit=27,file=file_name,status='unknown')
- write(27,"('P3')") ! write P3 = ASCII PNM image format
- write(27,*) NX,NY ! write image size
- write(27,*) '255' ! number of shades
-
- endif
-
-! compute maximum amplitude
- amplitude_max = maxval(abs(color_image_2D_data))
- vpmin = HUGEVAL
- vpmax = TINYVAL
- do iy=1,NY
- do ix=1,NX
- if ( iglob_image_color_2D(ix,iy) > -1 ) then
- vpmin = min(vpmin,image_color_vp_display(ix,iy))
- vpmax = max(vpmax,image_color_vp_display(ix,iy))
- endif
-
- enddo
- enddo
-
-! in the PNM format, the image starts in the upper-left corner
- do iy=NY,1,-1
- do ix=1,NX
-
-! check if pixel is defined or not (can be above topography for instance)
- if(iglob_image_color_2D(ix,iy) == -1) then
-
-! use light blue to display undefined region above topography
- R = 204
- G = 255
- B = 255
-
-! suppress small amplitudes considered as noise
- else if (abs(color_image_2D_data(ix,iy)) < amplitude_max * cutsnaps) then
-
-! use P velocity model as background where amplitude is negligible
- if((vpmax-vpmin)/vpmin > 0.02d0) then
- x1 = (image_color_vp_display(ix,iy)-vpmin)/(vpmax-vpmin)
- else
- x1 = 0.5d0
- endif
-
-! rescale to avoid very dark gray levels
- x1 = x1*0.7 + 0.2
- if(x1 > 1.d0) x1=1.d0
-
-! invert scale: white = vpmin, dark gray = vpmax
- x1 = 1.d0 - x1
-
-! map to [0,255]
- x1 = x1 * 255.d0
-
- R = nint(x1)
- if(R < 0) R = 0
- if(R > 255) R = 255
- G = R
- B = R
-
- else
-
-! define normalized image data in [-1:1] and convert to nearest integer
-! keeping in mind that data values can be negative
- normalized_value = color_image_2D_data(ix,iy) / amplitude_max
-
-! suppress values outside of [-1:+1]
- if(normalized_value < -1.d0) normalized_value = -1.d0
- if(normalized_value > 1.d0) normalized_value = 1.d0
-
-! use red if positive value, blue if negative, no green
- if(normalized_value >= 0.d0) then
- R = nint(255.d0*normalized_value**POWER_DISPLAY_COLOR)
- G = 0
- B = 0
- else
- R = 0
- G = 0
- B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY_COLOR)
- endif
-
- endif
-
-! write color image
- if(BINARY_FILE) then
-
-! first write red
- write(27,rec=current_rec) char(R)
- current_rec = current_rec + 1
-
-! then write green
- write(27,rec=current_rec) char(G)
- current_rec = current_rec + 1
-
-! then write blue
- write(27,rec=current_rec) char(B)
- current_rec = current_rec + 1
-
- else
-
- write(27,"(i3,' ',i3,' ',i3)") R,G,B
-
- endif
-
- enddo
- enddo
-
-! close the file
- close(27)
-
-! open image file and create system command to convert image to more convenient format
-! use the "convert" command from ImageMagick http://www.imagemagick.org
- write(system_command,"('cd OUTPUT_FILES ; convert image',i7.7,'.pnm image',i7.7,'.gif ; rm -f image',i7.7,'.pnm')") it,it,it
-
-! call the system to convert image to GIF
-! this line can be safely commented out if your compiler does not implement "system()" for system calls;
-! in such a case you will simply get images in PNM format in directory OUTPUT_FILES instead of GIF format
- call system(system_command)
-
- end subroutine create_color_image
-
Deleted: seismo/2D/SPECFEM2D/trunk/createnum_fast.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/createnum_fast.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/createnum_fast.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,343 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
-
-! same as subroutine "createnum_slow" but with a faster algorithm
-
- implicit none
-
- include "constants.h"
-
- integer npoin,npgeo,nspec,ngnod,myrank,ipass
- integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
- double precision shape(ngnod,NGLLX,NGLLX)
- double precision coorg(NDIM,npgeo)
-
- integer i,j
-
-! additional arrays needed for this fast version
- integer, dimension(:), allocatable :: loc,ind,ninseg,iglob,iwork
- logical, dimension(:), allocatable :: ifseg
- double precision, dimension(:), allocatable :: xp,yp,work
-
- integer ie,nseg,ioff,iseg,ig
- integer nxyz,ntot,ispec,ieoff,ilocnum,iy,ix,in,nnum
-
- double precision xmaxval,xminval,ymaxval,yminval,xtol,xtypdist
- double precision xcor,ycor
-
-
-!---- create global mesh numbering
- if(myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*)
- write(IOUT,*) 'Generating global mesh numbering (fast version)...'
- write(IOUT,*)
- endif
-
- nxyz = NGLLX*NGLLZ
- ntot = nxyz*nspec
-
- allocate(loc(ntot))
- allocate(ind(ntot))
- allocate(ninseg(ntot))
- allocate(iglob(ntot))
- allocate(ifseg(ntot))
- allocate(xp(ntot))
- allocate(yp(ntot))
- allocate(work(ntot))
- allocate(iwork(ntot))
-
-! compute coordinates of the grid points
- do ispec=1,nspec
- ieoff = nxyz*(ispec - 1)
- ilocnum = 0
-
- do iy = 1,NGLLX
- do ix = 1,NGLLX
-
- ilocnum = ilocnum + 1
-
- xcor = zero
- ycor = zero
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xcor = xcor + shape(in,ix,iy)*coorg(1,nnum)
- ycor = ycor + shape(in,ix,iy)*coorg(2,nnum)
- enddo
-
- xp(ilocnum + ieoff) = xcor
- yp(ilocnum + ieoff) = ycor
-
- enddo
- enddo
-
- enddo
-
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-! Establish initial pointers
- do ie=1,nspec
- ieoff = nxyz*(ie -1)
- do ix=1,nxyz
- loc (ix+ieoff) = ix+ieoff
- enddo
- enddo
-
-! set up local geometric tolerances
-
- xtypdist=+HUGEVAL
-
- do ie=1,nspec
-
- xminval=+HUGEVAL
- yminval=+HUGEVAL
- xmaxval=-HUGEVAL
- ymaxval=-HUGEVAL
- ieoff=nxyz*(ie-1)
- do ilocnum=1,nxyz
- xmaxval=max(xp(ieoff+ilocnum),xmaxval)
- xminval=min(xp(ieoff+ilocnum),xminval)
- ymaxval=max(yp(ieoff+ilocnum),ymaxval)
- yminval=min(yp(ieoff+ilocnum),yminval)
- enddo
-
-! compute the minimum typical "size" of an element in the mesh
- xtypdist = min(xtypdist,xmaxval-xminval)
- xtypdist = min(xtypdist,ymaxval-yminval)
-
- enddo
-
-! define a tolerance, small with respect to the minimum size
- xtol = SMALLVALTOL * xtypdist
-
- ifseg(:) = .false.
- nseg = 1
- ifseg(1) = .true.
- ninseg(1) = ntot
-
- do j=1,NDIM
-! Sort within each segment
- ioff=1
- do iseg=1,nseg
- if(j == 1) then
- call rank (xp(ioff),ind,ninseg(iseg))
- else
- call rank (yp(ioff),ind,ninseg(iseg))
- endif
- call swap(xp(ioff),work,ind,ninseg(iseg))
- call swap(yp(ioff),work,ind,ninseg(iseg))
- call iswap(loc(ioff),iwork,ind,ninseg(iseg))
- ioff=ioff+ninseg(iseg)
- enddo
-! Check for jumps in current coordinate
- if (j == 1) then
- do i=2,ntot
- if (abs(xp(i)-xp(i-1)) > xtol) ifseg(i)=.true.
- enddo
- else
- do i=2,ntot
- if (abs(yp(i)-yp(i-1)) > xtol) ifseg(i)=.true.
- enddo
- endif
-! Count up number of different segments
- nseg = 0
- do i=1,ntot
- if (ifseg(i)) then
- nseg = nseg+1
- ninseg(nseg) = 1
- else
- ninseg(nseg) = ninseg(nseg) + 1
- endif
- enddo
- enddo
-!
-! Assign global node numbers (now sorted lexicographically!)
-!
- ig = 0
- do i=1,ntot
- if (ifseg(i)) ig=ig+1
- iglob(loc(i)) = ig
- enddo
-
- npoin = ig
-
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-! get result in my format
- do ispec=1,nspec
- ieoff = nxyz*(ispec - 1)
- ilocnum = 0
- do iy = 1,NGLLX
- do ix = 1,NGLLX
- ilocnum = ilocnum + 1
- ibool(ix,iy,ispec) = iglob(ilocnum + ieoff)
- enddo
- enddo
- enddo
-
- deallocate(loc)
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iglob)
- deallocate(ifseg)
- deallocate(xp)
- deallocate(yp)
- deallocate(work)
- deallocate(iwork)
-
-! check the numbering obtained
- if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) call exit_MPI('Error while generating global numbering')
-
- if(myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Total number of points of the global mesh: ',npoin
- write(IOUT,*)
- endif
-
- end subroutine createnum_fast
-
-
-!-----------------------------------------------------------------------
-
- subroutine rank(A,IND,N)
-!
-! Use Heap Sort (p 233 Numerical Recipes)
-!
- implicit none
-
- integer N
- double precision A(N)
- integer IND(N)
-
- integer i,j,l,ir,indx
- double precision q
-
- do J=1,N
- IND(j)=j
- enddo
-
- if(n == 1) return
- L=n/2+1
- ir=n
- 100 continue
- IF(l > 1) THEN
- l=l-1
- indx=ind(l)
- q=a(indx)
- ELSE
- indx=ind(ir)
- q=a(indx)
- ind(ir)=ind(1)
- ir=ir-1
- if(ir == 1) then
- ind(1)=indx
- return
- endif
- ENDIF
- i=l
- j=l+l
- 200 continue
- IF(J <= IR) THEN
- IF(J < IR) THEN
- IF(A(IND(j)) < A(IND(j+1))) j=j+1
- ENDIF
- IF(q < A(IND(j))) THEN
- IND(I)=IND(J)
- I=J
- J=J+J
- ELSE
- J=IR+1
- ENDIF
- GOTO 200
- ENDIF
- IND(I)=INDX
- GOTO 100
-
- end subroutine rank
-
-!-----------------------------------------------------------------------
-
- subroutine swap(a,w,ind,n)
-!
-! Use IND to sort array A (p 233 Numerical Recipes)
-!
- implicit none
-
- integer n
- double precision A(N),W(N)
- integer IND(N)
-
- integer j
-
- W(:) = A(:)
-
- do J=1,N
- A(j) = W(ind(j))
- enddo
-
- end subroutine swap
-
-!-----------------------------------------------------------------------
-
- subroutine iswap(a,w,ind,n)
-!
-! Use IND to sort array A
-!
- implicit none
-
- integer n
- integer A(N),W(N),IND(N)
-
- integer j
-
- W(:) = A(:)
-
- do J=1,N
- A(j) = W(ind(j))
- enddo
-
- end subroutine iswap
-
Deleted: seismo/2D/SPECFEM2D/trunk/createnum_slow.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/createnum_slow.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/createnum_slow.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,324 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
-
-! generate the global numbering
-
- implicit none
-
- include "constants.h"
-
- integer npoin,nspec,ngnod,myrank,ipass
-
- integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
-
- integer i,j,num2,i2,j2,ipos,ipos2,iloc,jloc,kloc
- integer ngnodloc,ngnodother,nedgeloc,nedgeother,npedge,numelem,npcorn
-
- logical alreadyexist
-
- integer, dimension(NEDGES) :: ngnod_begin,ngnod_end
-
-
-!---- create global mesh numbering
- if(myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Generating global mesh numbering (slow version)...'
- write(IOUT,*)
- endif
-
- npoin = 0
- npedge = 0
- npcorn = 0
-
-! define edges from the four control points
-
-! --- edge 1 linking point 1 to point 2
- ngnod_begin(1)= 1
- ngnod_end(1)= 2
-
-! --- edge 2 linking point 2 to point 3
- ngnod_begin(2)= 2
- ngnod_end(2)= 3
-
-! --- edge 3 linking point 3 to point 4
- ngnod_begin(3)= 3
- ngnod_end(3)= 4
-
-! --- edge 4 linking point 4 to point 1
- ngnod_begin(4)= 4
- ngnod_end(4)= 1
-
-! initialisation du tableau de numerotation globale
- ibool(:,:,:) = 0
-
- do numelem = 1,nspec
- do i=1,NGLLX
- do j=1,NGLLZ
-
-! verifier que le point n'a pas deja ete genere
-
- if(ibool(i,j,numelem) == 0) then
-
-!
-!---- point interieur a un element, donc forcement unique
-!
- if(i /= 1 .and. i /= NGLLX .and. j /= 1 .and. j /= NGLLZ) then
-
- npoin = npoin + 1
- ibool(i,j,numelem) = npoin
-
-!
-!---- point au coin d'un element, rechercher les coins des autres elements
-!
- else if((i == 1 .and. j == 1) .or. (i == 1 .and. j == NGLLZ) .or. &
- (i == NGLLX .and. j == 1) .or. (i == NGLLX .and. j == NGLLZ)) then
-
-! trouver numero local du coin
- if(i == 1 .and. j == 1) then
- ngnodloc = 1
- else if(i == NGLLX .and. j == 1) then
- ngnodloc = 2
- else if(i == NGLLX .and. j == NGLLZ) then
- ngnodloc = 3
- else if(i == 1 .and. j == NGLLZ) then
- ngnodloc = 4
- endif
-
-! rechercher si existe deja, forcement dans un element precedent
-
- alreadyexist = .false.
-
- if(numelem > 1) then
-
- do num2=1,numelem-1
-
-! ne rechercher que sur les 4 premiers points de controle et non sur ngnod
- do ngnodother=1,4
-
-! voir si ce coin a deja ete genere
- if(knods(ngnodother,num2) == knods(ngnodloc,numelem)) then
- alreadyexist = .true.
-
-! obtenir la numerotation dans l'autre element
- if(ngnodother == 1) then
- i2 = 1
- j2 = 1
- else if(ngnodother == 2) then
- i2 = NGLLX
- j2 = 1
- else if(ngnodother == 3) then
- i2 = NGLLX
- j2 = NGLLZ
- else if(ngnodother == 4) then
- i2 = 1
- j2 = NGLLZ
- else
- call exit_MPI('bad corner')
- endif
-
-! affecter le meme numero
- ibool(i,j,numelem) = ibool(i2,j2,num2)
-
-! sortir de la recherche
- goto 134
-
- endif
- enddo
- enddo
-
- 134 continue
-
- endif
-
-! si un ancien point n'a pas ete trouve, en generer un nouveau
- if(.not. alreadyexist) then
- npcorn = npcorn + 1
- npoin = npoin + 1
- ibool(i,j,numelem) = npoin
- endif
-
-!
-!---- point a l'interieur d'une arete, rechercher si autre arete correspondante
-!
- else
-
-! trouver numero local de l'arete
- if(j == 1) then
- nedgeloc = 1
- else if(i == NGLLX) then
- nedgeloc = 2
- else if(j == NGLLZ) then
- nedgeloc = 3
- else if(i == 1) then
- nedgeloc = 4
- endif
-
-! rechercher si existe deja, forcement dans un element precedent
-
- alreadyexist = .false.
-
- if(numelem > 1) then
-
- do num2=1,numelem-1
-
-! rechercher sur les 4 aretes
- do nedgeother=1,4
-
-!--- detecter un eventuel defaut dans la structure topologique du maillage
-
- if((knods(ngnod_begin(nedgeother),num2) == knods(ngnod_begin(nedgeloc),numelem)) &
- .and. &
- (knods(ngnod_end(nedgeother),num2) == knods(ngnod_end(nedgeloc),numelem))) then
- call exit_MPI('Improper topology of the input mesh detected')
-
-!--- sinon voir si cette arete a deja ete generee
-
- else if((knods(ngnod_begin(nedgeother),num2) == knods(ngnod_end(nedgeloc),numelem)) &
- .and. &
- (knods(ngnod_end(nedgeother),num2) == knods(ngnod_begin(nedgeloc),numelem))) then
-
- alreadyexist = .true.
-
-! obtenir la numerotation dans l'autre element
-! maillage conforme donc on doit supposer que NGLLX == NGLLZ
-
-! generer toute l'arete pour eviter des recherches superflues
- do kloc = 2,NGLLX-1
-
-! calculer l'abscisse le long de l'arete de depart
- if(nedgeloc == 1) then
- iloc = kloc
- jloc = 1
- ipos = iloc
- else if(nedgeloc == 2) then
- iloc = NGLLX
- jloc = kloc
- ipos = jloc
- else if(nedgeloc == 3) then
- iloc = kloc
- jloc = NGLLZ
- ipos = NGLLX - iloc + 1
- else if(nedgeloc == 4) then
- iloc = 1
- jloc = kloc
- ipos = NGLLZ - jloc + 1
- else
- call exit_MPI('bad nedgeloc')
- endif
-
-! calculer l'abscisse le long de l'arete d'arrivee
-! topologie du maillage coherente, donc sens de parcours des aretes opposes
-
- ipos2 = NGLLX - ipos + 1
-
-! calculer les coordonnees reelles dans l'element d'arrivee
- if(nedgeother == 1) then
- i2 = ipos2
- j2 = 1
- else if(nedgeother == 2) then
- i2 = NGLLX
- j2 = ipos2
- else if(nedgeother == 3) then
- i2 = NGLLX - ipos2 + 1
- j2 = NGLLZ
- else if(nedgeother == 4) then
- i2 = 1
- j2 = NGLLZ - ipos2 + 1
- else
- call exit_MPI('bad nedgeother')
- endif
-
-! verifier que le point de depart n'existe pas deja
- if(ibool(iloc,jloc,numelem) /= 0) call exit_MPI('point generated twice')
-
-! verifier que le point d'arrivee existe bien deja
- if(ibool(i2,j2,num2) == 0) call exit_MPI('unknown point in the mesh')
-
-! affecter le meme numero
- ibool(iloc,jloc,numelem) = ibool(i2,j2,num2)
-
- enddo
-
-! sortir de la recherche
- goto 135
-
- endif
- enddo
- enddo
-
- 135 continue
-
- endif
-
-! si un ancien point n'a pas ete trouve, en generer un nouveau
- if(.not. alreadyexist) then
- npedge = npedge + 1
- npoin = npoin + 1
- ibool(i,j,numelem) = npoin
- endif
-
- endif
-
- endif
-
- enddo
- enddo
- enddo
-
-! verification de la coherence de la numerotation generee
- if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) call exit_MPI('Error while generating global numbering')
-
- if(myrank == 0 .and. ipass == 1) then
- write(IOUT,*) 'Total number of points of the global mesh: ',npoin,' distributed as follows:'
- write(IOUT,*)
- write(IOUT,*) 'Number of interior points: ',npoin-npedge-npcorn
- write(IOUT,*) 'Number of edge points (without corners): ',npedge
- write(IOUT,*) 'Number of corner points: ',npcorn
- write(IOUT,*)
- endif
-
- end subroutine createnum_slow
-
Deleted: seismo/2D/SPECFEM2D/trunk/datim.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/datim.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/datim.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,72 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine datim(string_input)
-
-! get date and time
-
- implicit none
-
- include "constants.h"
-
- character(len=50) string_input
- character(len=8) datein
- character(len=10) timein
- character(len=16) dateprint
- character(len=8) timeprint
-
- datein = ' '
- timein = ' '
-
- call date_and_time(datein,timein)
-
- dateprint = datein(7:8)//' - '//datein(5:6)//' - '//datein(1:4)
- timeprint = timein(1:2)//':'//timein(3:4)//':'//timein(5:6)
-
- write(iout,"(//1x,79('-')/1x,79('-')/1x,'Program SPECFEM2D: ')")
- write(iout,"(1x,79('-')/1x,79('-')/1x,a50)") string_input
- write(iout,"(1x,79('-')/,1x,79('-')/' D a t e : ',a16,30x,' T i m e : ',a8/1x,79('-'),/1x,79('-'))") dateprint,timeprint
-
- end subroutine datim
-
Deleted: seismo/2D/SPECFEM2D/trunk/define_derivation_matrices.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/define_derivation_matrices.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/define_derivation_matrices.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,94 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
-
- implicit none
-
- include "constants.h"
-
-! Gauss-Lobatto-Legendre points of integration
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLZ) :: zigll
-
-! weights
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
-
-! array with derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-
-! function for calculating derivatives of Lagrange polynomials
- double precision, external :: lagrange_deriv_GLL
-
- integer i1,i2,k1,k2
-
-! set up coordinates of the Gauss-Lobatto-Legendre points
- call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
- call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
-
-! if number of points is odd, the middle abscissa is exactly zero
- if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
- if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
-
-! calculate derivatives of the Lagrange polynomials
-! and precalculate some products in double precision
-! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
- do i1=1,NGLLX
- do i2=1,NGLLX
- hprime_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)
- hprimewgll_xx(i2,i1) = wxgll(i2) * hprime_xx(i2,i1)
- enddo
- enddo
-
- do k1=1,NGLLZ
- do k2=1,NGLLZ
- hprime_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)
- hprimewgll_zz(k2,k1) = wzgll(k2) * hprime_zz(k2,k1)
- enddo
- enddo
-
- end subroutine define_derivation_matrices
-
Deleted: seismo/2D/SPECFEM2D/trunk/define_external_model.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/define_external_model.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/define_external_model.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,91 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine define_external_model(x,y,iflag_element,myrank,rho,vp,vs,Qp_attenuation,&
- Qs_attenuation,c11,c13,c15,c33,c35,c55 )
-
- implicit none
-
- include "constants.h"
-
-! user can modify this routine to assign any different external Earth model (rho, vp, vs)
-! based on the x and y coordinates of that grid point and the flag of the region it belongs to
-
- integer, intent(in) :: iflag_element,myrank
-
- double precision, intent(in) :: x,y
-
- double precision, intent(out) :: rho,vp,vs
- double precision, intent(out) :: Qp_attenuation,Qs_attenuation
- double precision, intent(out) :: c11,c15,c13,c33,c35,c55
-
-! dummy routine here, just to demonstrate how the model can be assigned
- if(myrank == 0 .and. iflag_element == 1 .or. x < 1700.d0 .or. y >= 2300.d0) then
- rho = 2000.d0
- vp = 3000.d0
- vs = vp / sqrt(3.d0)
- Qp_attenuation = 0
- Qs_attenuation = 0
- c11 = 169.d9
- c13 = 122.d9
- c15 = 0.d0
- c33 = c11
- c35 = 0.d0
- c55 = 75.3d9
- else
- rho = 2500.d0
- vp = 3600.d0
- vs = vp / 2.d0
- Qp_attenuation = 60
- Qs_attenuation = 60
- c11 = 0.d0
- c13 = 0.d0
- c15 = 0.d0
- c33 = 0.d0
- c35 = 0.d0
- c55 = 0.d0
- endif
-
- end subroutine define_external_model
Deleted: seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,170 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)
-
-!=======================================================================
-!
-! Set up the shape functions for the subparametric transformation.
-! The routine can handle 4 or 9 control nodes defined as follows:
-!
-! 4 . . . . 7 . . . . 3
-! . .
-! . t .
-! . .
-! 8 9 s 6
-! . .
-! . .
-! . .
-! 1 . . . . 5 . . . . 2
-!
-! Local coordinate system : s,t
-!
-!=======================================================================
-
- implicit none
-
- include "constants.h"
-
- integer ngnod
-
- double precision shape2D(ngnod)
- double precision dershape2D(NDIM,ngnod)
- double precision xi,gamma
-
- double precision s,t,sp,sm,tp,tm,s2,t2,ss,tt,st
-
-!
-!---- set up the shape functions and their local derivatives
-!
- s = xi
- t = gamma
-
-!---- 4-node element
- if(ngnod == 4) then
- sp = s + ONE
- sm = s - ONE
- tp = t + ONE
- tm = t - ONE
-
-!---- corner nodes
- shape2D(1) = QUART * sm * tm
- shape2D(2) = - QUART * sp * tm
- shape2D(3) = QUART * sp * tp
- shape2D(4) = - QUART * sm * tp
-
- dershape2D(1,1) = QUART * tm
- dershape2D(1,2) = - QUART * tm
- dershape2D(1,3) = QUART * tp
- dershape2D(1,4) = - QUART * tp
-
- dershape2D(2,1) = QUART * sm
- dershape2D(2,2) = - QUART * sp
- dershape2D(2,3) = QUART * sp
- dershape2D(2,4) = - QUART * sm
-
-!---- 9-node element
- else if(ngnod == 9) then
-
- sp = s + ONE
- sm = s - ONE
- tp = t + ONE
- tm = t - ONE
- s2 = s * TWO
- t2 = t * TWO
- ss = s * s
- tt = t * t
- st = s * t
-
-!---- corner nodes
- shape2D(1) = QUART * sm * st * tm
- shape2D(2) = QUART * sp * st * tm
- shape2D(3) = QUART * sp * st * tp
- shape2D(4) = QUART * sm * st * tp
-
- dershape2D(1,1) = QUART * tm * t * (s2 - ONE)
- dershape2D(1,2) = QUART * tm * t * (s2 + ONE)
- dershape2D(1,3) = QUART * tp * t * (s2 + ONE)
- dershape2D(1,4) = QUART * tp * t * (s2 - ONE)
-
- dershape2D(2,1) = QUART * sm * s * (t2 - ONE)
- dershape2D(2,2) = QUART * sp * s * (t2 - ONE)
- dershape2D(2,3) = QUART * sp * s * (t2 + ONE)
- dershape2D(2,4) = QUART * sm * s * (t2 + ONE)
-
-!---- midside nodes
- shape2D(5) = HALF * tm * t * (ONE - ss)
- shape2D(6) = HALF * sp * s * (ONE - tt)
- shape2D(7) = HALF * tp * t * (ONE - ss)
- shape2D(8) = HALF * sm * s * (ONE - tt)
-
- dershape2D(1,5) = -ONE * st * tm
- dershape2D(1,6) = HALF * (ONE - tt) * (s2 + ONE)
- dershape2D(1,7) = -ONE * st * tp
- dershape2D(1,8) = HALF * (ONE - tt) * (s2 - ONE)
-
- dershape2D(2,5) = HALF * (ONE - ss) * (t2 - ONE)
- dershape2D(2,6) = -ONE * st * sp
- dershape2D(2,7) = HALF * (ONE - ss) * (t2 + ONE)
- dershape2D(2,8) = -ONE * st * sm
-
-!---- center node
- shape2D(9) = (ONE - ss) * (ONE - tt)
-
- dershape2D(1,9) = -ONE * s2 * (ONE - tt)
- dershape2D(2,9) = -ONE * t2 * (ONE - ss)
-
- else
- call exit_MPI('Error: wrong number of control nodes')
- endif
-
-!--- check the shape functions and their derivatives
-! sum of shape functions should be one
-! sum of derivaticves of shape functions should be zero
- if(abs(sum(shape2D)-ONE) > TINYVAL) call exit_MPI('error shape functions')
- if(abs(sum(dershape2D(1,:))) > TINYVAL) call exit_MPI('error deriv xi shape functions')
- if(abs(sum(dershape2D(2,:))) > TINYVAL) call exit_MPI('error deriv gamma shape functions')
-
- end subroutine define_shape_functions
-
Deleted: seismo/2D/SPECFEM2D/trunk/enforce_acoustic_free_surface.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/enforce_acoustic_free_surface.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/enforce_acoustic_free_surface.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,88 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
-
-! free surface for an acoustic medium
-! if acoustic, the free surface condition is a Dirichlet condition for the potential,
-! not Neumann, in order to impose zero pressure at the surface
-
- implicit none
-
- include "constants.h"
-
- integer :: nelem_acoustic_surface,npoin,nspec
-
- integer, dimension(5,nelem_acoustic_surface) :: acoustic_surface
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- real(kind=CUSTOM_REAL), dimension(npoin) :: &
- potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
-
-!---
-!--- local variables
-!---
-
- integer :: ispec_acoustic_surface,ispec,i,j,iglob
-
- do ispec_acoustic_surface = 1, nelem_acoustic_surface
-
- ispec = acoustic_surface(1,ispec_acoustic_surface)
-
- do j = acoustic_surface(4,ispec_acoustic_surface), acoustic_surface(5,ispec_acoustic_surface)
- do i = acoustic_surface(2,ispec_acoustic_surface), acoustic_surface(3,ispec_acoustic_surface)
- iglob = ibool(i,j,ispec)
- potential_acoustic(iglob) = ZERO
- potential_dot_acoustic(iglob) = ZERO
- potential_dot_dot_acoustic(iglob) = ZERO
- enddo
- enddo
-
- enddo
-
- end subroutine enforce_acoustic_free_surface
-
Deleted: seismo/2D/SPECFEM2D/trunk/exit_mpi.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/exit_mpi.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/exit_mpi.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,75 +0,0 @@
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!-----------------------------------------------
-! subroutine to stop the code whether sequential or parallel.
-!-----------------------------------------------
-subroutine exit_MPI(error_msg)
-
- implicit none
-#ifdef USE_MPI
- ! standard include of the MPI library
- include "mpif.h"
-#endif
-
- ! identifier for error message file
- integer, parameter :: IERROR = 30
-
- character(len=*) error_msg
-
- integer ier
-
- ier = 0
-
- ! write error message to screen
- write(*,*) error_msg(1:len(error_msg))
- write(*,*) 'Error detected, aborting MPI... proc '
-
- ! stop all the MPI processes, and exit
-#ifdef USE_MPI
- call MPI_ABORT(MPI_COMM_WORLD,30,ier)
-#endif
-
- stop 'error, program ended in exit_MPI'
-
-end subroutine exit_MPI
Deleted: seismo/2D/SPECFEM2D/trunk/get_MPI.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/get_MPI.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/get_MPI.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,319 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-#ifdef USE_MPI
-
- subroutine get_MPI(nspec,ibool,knods,ngnod,npoin,elastic,poroelastic, &
- ninterface, max_interface_size, &
- my_nelmnts_neighbours,my_interfaces,my_neighbours, &
- ibool_interfaces_acoustic, ibool_interfaces_elastic, &
- ibool_interfaces_poroelastic, &
- nibool_interfaces_acoustic, nibool_interfaces_elastic, &
- nibool_interfaces_poroelastic, &
- inum_interfaces_acoustic, inum_interfaces_elastic, &
- inum_interfaces_poroelastic, &
- ninterface_acoustic, ninterface_elastic, ninterface_poroelastic, &
- mask_ispec_inner_outer, &
- myrank,ipass,coord)
-
-! sets up the MPI interface for communication between partitions
-
- implicit none
-
- include "constants.h"
- include 'mpif.h'
-
- integer, intent(in) :: nspec, npoin, ngnod
- logical, dimension(nspec), intent(in) :: elastic, poroelastic
- integer, dimension(ngnod,nspec), intent(in) :: knods
- integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
-
- integer :: ninterface
- integer :: max_interface_size
- integer, dimension(ninterface) :: my_nelmnts_neighbours,my_neighbours
- integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
-
- integer, dimension(NGLLX*max_interface_size,ninterface) :: &
- ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
- integer, dimension(ninterface) :: &
- nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
- integer, dimension(ninterface), intent(out) :: &
- inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
- integer, intent(out) :: ninterface_acoustic, ninterface_elastic, ninterface_poroelastic
-
- logical, dimension(nspec), intent(inout) :: mask_ispec_inner_outer
-
- integer :: myrank,ipass
- double precision, dimension(NDIM,npoin) :: coord
-
- !local parameters
- double precision, dimension(:), allocatable :: xp,zp
- double precision, dimension(:), allocatable :: work
- integer, dimension(:), allocatable :: locval
- integer, dimension(:), allocatable :: nibool_interfaces_true
- ! for MPI buffers
- integer, dimension(:), allocatable :: reorder_interface,ind,ninseg,iwork
- integer, dimension(:), allocatable :: ibool_dummy
-! integer, dimension(:,:), allocatable :: ibool_interfaces_dummy
- logical, dimension(:), allocatable :: ifseg
- integer :: iinterface,ilocnum
- integer :: num_points1, num_points2
- ! assembly test
- integer :: i,j,ispec,iglob,count,inum,ier,idomain
- integer :: max_nibool_interfaces,num_nibool,num_interface
- real(kind=CUSTOM_REAL), dimension(:),allocatable :: test_flag_cr
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_ac
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_ac
- integer, dimension(:), allocatable :: tab_requests_send_recv_acoustic
-
- ! gets global indices for points on MPI interfaces
- ! (defined by my_interfaces) between different partitions
- ! and stores them in ibool_interfaces*** & nibool_interfaces*** (number of total points)
- call prepare_assemble_MPI(nspec,ibool,knods, ngnod,npoin, elastic, poroelastic, &
- ninterface, max_interface_size, &
- my_nelmnts_neighbours, my_interfaces, &
- ibool_interfaces_acoustic, ibool_interfaces_elastic, &
- ibool_interfaces_poroelastic, &
- nibool_interfaces_acoustic, nibool_interfaces_elastic, &
- nibool_interfaces_poroelastic, &
- inum_interfaces_acoustic, inum_interfaces_elastic, &
- inum_interfaces_poroelastic, &
- ninterface_acoustic, ninterface_elastic, ninterface_poroelastic, &
- mask_ispec_inner_outer )
-
-
- ! sorts ibool comm buffers lexicographically for all MPI interfaces
- num_points1 = 0
- num_points2 = 0
- allocate(nibool_interfaces_true(ninterface))
-
- do idomain = 1,3
-
- ! checks number of interface in this domain
- num_interface = 0
- if( idomain == 1 ) then
- num_interface = ninterface_acoustic
- elseif( idomain == 2 ) then
- num_interface = ninterface_elastic
- elseif( idomain == 3 ) then
- num_interface = ninterface_poroelastic
- endif
- if( num_interface == 0 ) cycle
-
- ! loops over interfaces
- do iinterface = 1, ninterface
-
- ! number of global points in this interface
- num_nibool = 0
- if( idomain == 1 ) then
- num_nibool = nibool_interfaces_acoustic(iinterface)
- elseif( idomain == 2 ) then
- num_nibool = nibool_interfaces_elastic(iinterface)
- elseif( idomain == 3 ) then
- num_nibool = nibool_interfaces_poroelastic(iinterface)
- endif
- ! checks if anything to sort
- if( num_nibool == 0 ) cycle
-
- allocate(xp(num_nibool))
- allocate(zp(num_nibool))
- allocate(locval(num_nibool))
- allocate(ifseg(num_nibool))
- allocate(reorder_interface(num_nibool))
- allocate(ibool_dummy(num_nibool))
- allocate(ind(num_nibool))
- allocate(ninseg(num_nibool))
- allocate(iwork(num_nibool))
- allocate(work(num_nibool))
-
- ! works with a copy of ibool array
- if( idomain == 1 ) then
- ibool_dummy(:) = ibool_interfaces_acoustic(1:num_nibool,iinterface)
- elseif( idomain == 2 ) then
- ibool_dummy(:) = ibool_interfaces_elastic(1:num_nibool,iinterface)
- elseif( idomain == 3 ) then
- ibool_dummy(:) = ibool_interfaces_poroelastic(1:num_nibool,iinterface)
- endif
-
- ! gets x,y,z coordinates of global points on MPI interface
- do ilocnum = 1, num_nibool
- iglob = ibool_dummy(ilocnum)
- xp(ilocnum) = coord(1,iglob)
- zp(ilocnum) = coord(2,iglob)
- enddo
-
- ! sorts (lexicographically?) ibool_interfaces and updates value
- ! of total number of points nibool_interfaces_true(iinterface)
- call sort_array_coordinates(num_nibool,xp,zp, &
- ibool_dummy, &
- reorder_interface,locval,ifseg, &
- nibool_interfaces_true(iinterface), &
- ind,ninseg,iwork,work)
-
- ! checks that number of MPI points are still the same
- num_points1 = num_points1 + num_nibool
- num_points2 = num_points2 + nibool_interfaces_true(iinterface)
- if( num_points1 /= num_points2 ) then
- write(IOUT,*) 'error sorting MPI interface points:',myrank
- write(IOUT,*) ' domain:',idomain
- write(IOUT,*) ' interface:',iinterface,num_points1,num_points2
- call exit_MPI('error sorting MPI interface')
- endif
-
- ! stores new order of ibool array
- if( idomain == 1 ) then
- ibool_interfaces_acoustic(1:num_nibool,iinterface) = ibool_dummy(:)
- elseif( idomain == 2 ) then
- ibool_interfaces_elastic(1:num_nibool,iinterface) = ibool_dummy(:)
- elseif( idomain == 3 ) then
- ibool_interfaces_poroelastic(1:num_nibool,iinterface) = ibool_dummy(:)
- endif
-
- ! cleanup temporary arrays
- deallocate(xp)
- deallocate(zp)
- deallocate(locval)
- deallocate(ifseg)
- deallocate(reorder_interface)
- deallocate(ibool_dummy)
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iwork)
- deallocate(work)
- enddo
- enddo
-
- ! cleanup
- deallocate(nibool_interfaces_true)
-
- ! outputs total number of MPI interface points
- call MPI_ALLREDUCE(num_points2, num_points1, 1, MPI_INTEGER, &
- MPI_SUM, MPI_COMM_WORLD, ier)
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) 'total MPI interface points: ',num_points1
- endif
-
- ! checks interfaces in acoustic domains
- if ( ninterface_acoustic > 0) then
-
- ! checks with assembly of test fields
- allocate(test_flag_cr(npoin))
- test_flag_cr(:) = 0._CUSTOM_REAL
- count = 0
- do ispec = 1, nspec
- ! sets flags on global points
- do j = 1, NGLLZ
- do i = 1, NGLLX
- ! global index
- iglob = ibool(i,j,ispec)
-
- ! counts number of unique global points to set
- if( nint(test_flag_cr(iglob)) == 0 ) count = count+1
-
- ! sets identifier
- test_flag_cr(iglob) = myrank + 1.0
- enddo
- enddo
- enddo
-
- max_nibool_interfaces = maxval(nibool_interfaces_acoustic(:))
-
- allocate(tab_requests_send_recv_acoustic(ninterface_acoustic*2))
- allocate(buffer_send_faces_vector_ac(max_nibool_interfaces,ninterface_acoustic))
- allocate(buffer_recv_faces_vector_ac(max_nibool_interfaces,ninterface_acoustic))
-
- inum = 0
- do iinterface = 1, ninterface
- inum = inum + nibool_interfaces_acoustic(iinterface)
- enddo
-
- call MPI_ALLREDUCE(inum, num_points2, 1, MPI_INTEGER, &
- MPI_SUM, MPI_COMM_WORLD, ier)
-
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) ' acoustic interface points: ',num_points2
- endif
-
- ! adds contributions from different partitions to flag arrays
- ! custom_real arrays
- call assemble_MPI_vector_ac(test_flag_cr,npoin, &
- ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
- max_interface_size, max_nibool_interfaces,&
- ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
- tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
- buffer_recv_faces_vector_ac, my_neighbours)
-
- ! checks number of interface points
- i = 0
- do iglob=1,npoin
- ! only counts flags with MPI contributions
- if( test_flag_cr(iglob) > myrank+1.0_CUSTOM_REAL ) i = i + 1
- enddo
- call MPI_ALLREDUCE(inum, iglob, 1, MPI_INTEGER, &
- MPI_SUM, MPI_COMM_WORLD, ier)
-
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) ' assembled acoustic MPI interface points:',iglob
- endif
- if( num_points2 /= iglob ) then
- print*,'error assembly:',myrank
- print*,' count = ',count
- print*,' inum = ',inum
- print*,' i = ',i
- print*,' total: ',num_points2,' not equal to assembled ',iglob
- call exit_MPI('error acoustic MPI assembly')
- endif
- deallocate(tab_requests_send_recv_acoustic)
- deallocate(buffer_send_faces_vector_ac)
- deallocate(buffer_recv_faces_vector_ac)
-
- deallocate(test_flag_cr)
-
- endif
-
-
-
- end subroutine get_MPI
-
-#endif
Deleted: seismo/2D/SPECFEM2D/trunk/get_node_number.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/get_node_number.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/get_node_number.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,94 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
-! *******************
-! meshing subroutines
-! *******************
-
-!--- global node number
-
-integer function num(i,j,nx)
-
- implicit none
-
- integer i,j,nx
-
- num = j*(nx+1) + i + 1
-
-end function num
-
-
-!--- global node number (when ngnod==4).
-integer function num_4(i,j,nx)
-
- implicit none
-
- integer i,j,nx
-
- num_4 = j*(nx+1) + i + 1
-
-end function num_4
-
-
-!--- global node number (when ngnod==9).
-integer function num_9(i,j,nx,nz)
-
- implicit none
-
- integer i,j,nx,nz
-
-
- if ( (mod(i,2) == 0) .and. (mod(j,2) == 0) ) then
- num_9 = j/2 * (nx+1) + i/2 + 1
- else
- if ( mod(j,2) == 0 ) then
- num_9 = (nx+1)*(nz+1) + j/2 * nx + ceiling(real(i)/real(2))
- else
- num_9 = (nx+1)*(nz+1) + nx*(nz+1) + floor(real(j)/real(2))*(nx*2+1) + i + 1
-
- endif
- endif
-
-end function num_9
Deleted: seismo/2D/SPECFEM2D/trunk/get_perm_cuthill_mckee.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/get_perm_cuthill_mckee.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/get_perm_cuthill_mckee.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,806 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! implement reverse Cuthill-McKee (1969) ordering, introduced in
-! E. Cuthill and J. McKee. Reducing the bandwidth of sparse symmetric matrices.
-! In Proceedings of the 1969 24th national conference, pages 157-172,
-! New-York, New-York, USA, 1969. ACM Press.
-! see for instance http://en.wikipedia.org/wiki/Cuthill%E2%80%93McKee_algorithm
-
- subroutine get_perm(ibool,perm,limit,nspec,nglob)
-
- implicit none
-
- include "constants.h"
-
-! local variables
- integer nspec,nglob_GLL_full
- integer nglob_four_corners_only,nglob
-
-! maximum number of neighbors of a spectral element (in principle, it could be any value)
- integer, parameter :: MAX_NUMBER_OF_NEIGHBORS = 50
-
-! input
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
-! output
- integer, dimension(nspec) :: perm
-
-! global corner numbers that need to be created
- integer, dimension(nglob) :: global_corner_number
-
- integer mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
- integer, dimension(:), allocatable :: ne,np,adj
- integer xadj(nspec+1)
-
-! arrays to store the permutation and inverse permutation of the Cuthill-McKee algorithm
- integer, dimension(nspec) :: invperm
-
- logical maskel(nspec)
-
- integer i,istart,istop,number_of_neighbors
-
-! only count the total size of the array that will be created, or actually create it
- logical count_only
- integer total_size_ne,total_size_adj,limit
-
-!
-!-----------------------------------------------------------------------
-!
- if(PERFORM_CUTHILL_MCKEE) then
-
- ! total number of points in the mesh
- nglob_GLL_full = nglob
-
- !---- call Charbel Farhat's routines
- call form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,nglob_GLL_full,ibool,nglob_four_corners_only)
- do i=1,nspec
- istart = mp(i)
- istop = mp(i+1) - 1
- enddo
-
- allocate(np(nglob_four_corners_only+1))
- count_only = .true.
- total_size_ne = 1
- allocate(ne(total_size_ne))
- call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only,nspec,count_only,total_size_ne)
- deallocate(ne)
- allocate(ne(total_size_ne))
- count_only = .false.
- call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only,nspec,count_only,total_size_ne)
- do i=1,nglob_four_corners_only
- istart = np(i)
- istop = np(i+1) - 1
- enddo
-
- count_only = .true.
- total_size_adj = 1
- allocate(adj(total_size_adj))
- call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_four_corners_only,&
- count_only,total_size_ne,total_size_adj)
- deallocate(adj)
- allocate(adj(total_size_adj))
- count_only = .false.
- call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_four_corners_only,&
- count_only,total_size_ne,total_size_adj)
- do i=1,nspec
- istart = xadj(i)
- istop = xadj(i+1) - 1
- number_of_neighbors = istop-istart+1
- if(number_of_neighbors < 1) stop 'error: your mesh seems to have at least one element not connected to any other'
- if(number_of_neighbors > MAX_NUMBER_OF_NEIGHBORS) stop 'error: your mesh seems to have an unlikely high valence'
- enddo
- deallocate(ne,np)
-
-! call the Cuthill-McKee sorting algorithm
- call cuthill_mckee(adj,xadj,perm,invperm,nspec,total_size_adj,limit)
- deallocate(adj)
- else
-! create identity permutation in order to do nothing
- do i=1,nspec
- perm(i) = i
- enddo
- endif
-
- end subroutine get_perm
-
-!=======================================================================
-!
-! Charbel Farhat's FEM topology routines
-!
-! Dimitri Komatitsch, February 1996 - Code based on Farhat's original version
-! described in his technical report from 1987
-!
-! modified and adapted by Dimitri Komatitsch, May 2006
-!
-!=======================================================================
-
- subroutine form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number, &
- nglob_GLL_full,ibool,nglob_four_corners_only)
-
-!-----------------------------------------------------------------------
-!
-! Forms the MN and MP arrays
-!
-! Input :
-! -------
-! ibool Array needed to build the element connectivity table
-! nspec Number of elements in the domain
-! NGNOD_QUADRANGLE number of nodes per hexahedron (brick with 8 corners)
-!
-! Output :
-! --------
-! MN, MP This is the element connectivity array pair.
-! Array MN contains the list of the element
-! connectivity, that is, the nodes contained in each
-! element. They are stored in a stacked fashion.
-!
-! Pointer array MP stores the location of each
-! element list. Its length is equal to the number
-! of elements plus one.
-!
-!-----------------------------------------------------------------------
-
- implicit none
-
- include "constants.h"
-
- integer nspec,nglob_GLL_full
-
-! arrays with mesh parameters per slice
- integer, intent(in), dimension(NGLLX,NGLLZ,nspec) :: ibool
-
-! global corner numbers that need to be created
- integer, intent(out), dimension(nglob_GLL_full) :: global_corner_number
- integer, intent(out) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
- integer, intent(out) :: nglob_four_corners_only
-
- integer ninter,nsum,ispec,node,k,inumcorner,ix,iy
-
- ninter = 1
- nsum = 1
- mp(1) = 1
-
-!---- define topology of the elements in the mesh
-!---- we need to define adjacent numbers from the sub-mesh consisting of the corners only
- nglob_four_corners_only = 0
- global_corner_number(:) = -1
-
- do ispec=1,nspec
-
- inumcorner = 0
- do iy = 1,NGLLZ,NGLLZ-1
- do ix = 1,NGLLX,NGLLX-1
-
- inumcorner = inumcorner + 1
- if(inumcorner > NGNOD_QUADRANGLE) stop 'corner number too large'
-
-! check if this point was already assigned a number previously, otherwise create one and store it
- if(global_corner_number(ibool(ix,iy,ispec)) == -1) then
- nglob_four_corners_only = nglob_four_corners_only + 1
- global_corner_number(ibool(ix,iy,ispec)) = nglob_four_corners_only
- endif
-
- node = global_corner_number(ibool(ix,iy,ispec))
- do k=nsum,ninter-1
- if(node == mn(k)) goto 200
- enddo
-
- mn(ninter) = node
- ninter = ninter + 1
- 200 continue
-
- enddo
- enddo
-
- nsum = ninter
- mp(ispec + 1) = nsum
-
- enddo
-
- end subroutine form_elt_connectivity_foelco
-
-!
-!----------------------------------------------------
-!
-
- subroutine form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only, &
- nspec,count_only,total_size_ne)
-
-!-----------------------------------------------------------------------
-!
-! Forms the NE and NP arrays
-!
-! Input :
-! -------
-! MN, MP, nspec
-! nglob_four_corners_only Number of nodes in the domain
-!
-! Output :
-! --------
-! NE, NP This is the node-connected element array pair.
-! Integer array NE contains a list of the
-! elements connected to each node, stored in stacked fashion.
-!
-! Array NP is the pointer array for the
-! location of a node's element list in the NE array.
-! Its length is equal to the number of points plus one.
-!
-!-----------------------------------------------------------------------
-
- implicit none
-
- include "constants.h"
-
-! only count the total size of the array that will be created, or actually create it
- logical count_only
- integer total_size_ne
-
- integer nglob_four_corners_only,nspec
-
- integer, intent(in) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
-
- integer, intent(out) :: ne(total_size_ne),np(nglob_four_corners_only+1)
-
- integer nsum,inode,ispec,j
-
- nsum = 1
- np(1) = 1
-
- do inode=1,nglob_four_corners_only
- do 200 ispec=1,nspec
-
- do j=mp(ispec),mp(ispec + 1) - 1
- if (mn(j) == inode) then
- if(count_only) then
- total_size_ne = nsum
- else
- ne(nsum) = ispec
- endif
- nsum = nsum + 1
- goto 200
- endif
- enddo
- 200 continue
-
- np(inode + 1) = nsum
-
- enddo
-
- end subroutine form_node_connectivity_fonoco
-
-!
-!----------------------------------------------------
-!
-
- subroutine create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec, &
- nglob_four_corners_only,count_only,total_size_ne,total_size_adj)
-
-!-----------------------------------------------------------------------
-!
-! Establishes the element adjacency information of the mesh
-! Two elements are considered adjacent if they share a face.
-!
-! Input :
-! -------
-! MN, MP, NE, NP, nspec
-! MASKEL logical mask (length = nspec)
-!
-! Output :
-! --------
-! ADJ, XADJ This is the element adjacency array pair. Array
-! ADJ contains the list of the elements adjacent to
-! element i. They are stored in a stacked fashion.
-! Pointer array XADJ stores the location of each element list.
-!
-!-----------------------------------------------------------------------
-
- implicit none
-
- include "constants.h"
-
-! only count the total size of the array that will be created, or actually create it
- logical count_only
- integer total_size_ne,total_size_adj
-
- integer nglob_four_corners_only
-
- integer nspec,iad,ispec,istart,istop,ino,node,jstart,jstop,nelem,jel
-
- integer, intent(in) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1),ne(total_size_ne),np(nglob_four_corners_only+1)
-
- integer, intent(out) :: adj(total_size_adj),xadj(nspec+1)
-
- logical maskel(nspec)
- integer countel(nspec)
-
- xadj(1) = 1
- iad = 1
-
- do ispec=1,nspec
-
-! reset mask
- maskel(:) = .false.
-
-! mask current element
- maskel(ispec) = .true.
- if (FACE) countel(:) = 0
-
- istart = mp(ispec)
- istop = mp(ispec+1) - 1
- do ino=istart,istop
- node = mn(ino)
- jstart = np(node)
- jstop = np(node + 1) - 1
- do 120 jel=jstart,jstop
- nelem = ne(jel)
- if(maskel(nelem)) goto 120
- if (FACE) then
-!! DK DK this below implemented by David Michea in 3D, but not true anymore in 2D: should be
-!! DK DK two corners instead of three. But does not matter because FACE is always .false.
-!! DK DK and therefore this part of the routine is currently never used.
-!! DK DK Let me add a stop statement just in case.
- stop 'FACE = .true. not implemented, check the above comment in the source code'
-!! DK DK End of the stop statement added.
- ! if 2 elements share at least 3 corners, therefore they share a face
- countel(nelem) = countel(nelem) + 1
- if (countel(nelem)>=3) then
- if(count_only) then
- total_size_adj = iad
- else
- adj(iad) = nelem
- endif
- maskel(nelem) = .true.
- iad = iad + 1
- endif
- else
- if(count_only) then
- total_size_adj = iad
- else
- adj(iad) = nelem
- endif
- maskel(nelem) = .true.
- iad = iad + 1
- endif
- 120 continue
- enddo
-
- xadj(ispec+1) = iad
-
- enddo
-
- end subroutine create_adjacency_table_adjncy
-
-!
-!----------------------------------------------------
-!
-
- subroutine cuthill_mckee(adj,xadj,mask,invperm_all,nspec,total_size_adj,limit)
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: nspec,total_size_adj, limit
- integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
-
- integer, intent(out), dimension(nspec) :: mask,invperm_all
- integer, dimension(nspec) :: invperm_sub
- integer ispec,gsize,counter,nspec_sub,root,total_ordered_elts, next_root
-
-! fill the mask with ones
- mask(:) = 1
- invperm_all(:) = 0
- counter = 0
- nspec_sub = limit
- root = 1
- total_ordered_elts = 0
-
- do while(total_ordered_elts < nspec)
- ! creation of a sublist of sorted elements which fit in the cache (the criterion of size is limit)
- ! limit = nb of elements that can fit in the L2 cache
- call Cut_McK( root, nspec, total_size_adj, xadj, adj, mask, gsize, invperm_sub, limit, nspec_sub, next_root)
- ! add the sublist in the main permutation list
- invperm_all(total_ordered_elts+1:total_ordered_elts+nspec_sub) = invperm_sub(1:nspec_sub)
- total_ordered_elts = total_ordered_elts + nspec_sub
- ! seek for a new root to build the new sublist
- if (next_root > 0) then
- root = next_root
- else
- if (total_ordered_elts /= nspec) &
- call find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
- root = next_root
- endif
- enddo
-
- if (INVERSE) then
- do ispec=1,nspec
- mask(invperm_all(ispec)) = ispec
- enddo
- else
- mask(:) = invperm_all(:)
- endif
-
- end subroutine cuthill_mckee
-
-
-!*******************************************************************************
-! Objective: Cuthill-McKee ordering
-! The algorithm is:
-!
-! X(1) = ROOT.
-! for ( I = 1 to N-1)
-! Find all unlabeled neighbors of X(I),
-! assign them the next available labels, in order of increasing degree.
-!
-! Parameters:
-! root the starting point for the cm ordering.
-! nbnodes the number of nodes.
-! nnz the number of adjacency entries.
-!
-! xadj/adj the graph
-! mask only those nodes with nonzero mask are considered
-!
-! gsize the number of the connected component
-! invp Inverse permutation (from new order to old order)
-!*******************************************************************************
-
-subroutine find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
-
- implicit none
-
- include "constants.h"
-
-! input
- integer, intent(in) :: total_size_adj,total_ordered_elts,nspec
- integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
- integer, intent(in), dimension(nspec) :: mask,invperm_all
-! output
- integer, intent(out) :: next_root
-! variables
- integer :: cur_node,neighbor_node,i,j
-
- do i=total_ordered_elts, 1, -1
- cur_node = invperm_all(i)
- do j= xadj(cur_node), xadj(cur_node+1)-1
- neighbor_node = adj(j)
- if (mask(neighbor_node)/=0) then
- next_root=neighbor_node
- return
- endif
- enddo
- enddo
-
-end subroutine find_next_root
-
-!*******************************************************************************
-! Objective: Cuthill-McKee ordering
-! The algorithm is:
-!
-! X(1) = ROOT.
-! for ( I = 1 to N-1)
-! Find all unlabeled neighbors of X(I),
-! assign them the next available labels, in order of increasing degree.
-!
-! Parameters:
-! root the starting point for the cm ordering.
-! nbnodes the number of nodes.
-! nnz the number of adjacency entries.
-!
-! xadj/adj the graph
-! mask only those nodes with nonzero mask are considered
-!
-! gsize the number of the connected component
-! invp Inverse permutation (from new order to old order)
-!*******************************************************************************
-
-subroutine Cut_McK( root, nbnodes, nnz, xadj, adj, mask, gsize, invp, limit, nspec_sub, next_root)
-
- implicit none
-
- include "constants.h"
-
-!--------------------------------------------------------------- Input Variables
- integer root, nnz, nbnodes, limit, nspec_sub, next_root
-
- integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
-
-!-------------------------------------------------------------- Output Variables
- integer gsize
- integer invp(nbnodes)
-
-!--------------------------------------------------------------- Local Variables
- integer i, j, k, l, lbegin, lnbr, linvp, lvlend, nbr, node, fnbr
- integer deg(nbnodes)
-
-! Find the degrees of the nodes in the subgraph specified by mask and root
-! Here invp is used to store a levelization of the subgraph
- invp(:)=0
- deg(:)=0
- call degree ( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, invp)
-
- mask(root) = 0
-
- IF (gsize > 1) THEN
- !If there is at least 2 nodes in the subgraph
- lvlend = 0
- lnbr = 1
-
- DO while (lvlend < lnbr)
- !lbegin/lvlend point to the begin/end of the present level
- lbegin = lvlend + 1
- lvlend = lnbr
-
- do i= lbegin, lvlend
- node = invp(i)
-
- !Find the unnumbered neighbours of node.
- !fnbr/lnbr point to the first/last neighbors of node
- fnbr = lnbr + 1
- do j= xadj(node), xadj(node+1)-1
- nbr = adj(j)
-
- if (mask(nbr) /= 0) then
- lnbr = lnbr + 1
- mask(nbr) = 0
- invp(lnbr) = nbr
- endif
- enddo
-
- !If no neighbors, go to next node in this level.
- IF (lnbr > fnbr) THEN
- !Sort the neighbors of NODE in increasing order by degree.
- !Linear insertion is used.
- k = fnbr
- do while (k < lnbr)
- l = k
- k = k + 1
- nbr = invp(k)
-
- DO WHILE (fnbr < l)
- linvp = invp(l)
-
- if (deg(linvp) <= deg(nbr)) then
- exit
- endif
-
- invp(l+1) = linvp
- l = l-1
- ENDDO
-
- invp(l+1) = nbr
- enddo
- ENDIF
- enddo
- ENDDO
-
- ENDIF
-
- if (gsize > limit) then
- do i = limit + 1 , nbnodes
- node=invp(i)
- if (node /=0) mask(node) = 1
- enddo
- next_root = invp(limit +1)
- nspec_sub = limit
- else
- next_root = -1
- nspec_sub = gsize
- endif
-
-END subroutine Cut_McK
-
-
-!*******************************************************************************
-! Objective: computes the degrees of the nodes in the connected graph
-!
-! Parameters:
-! root the root node
-! nbnodes the number of nodes in the graph
-! nnz the graph size
-! xadj/adj the whole graph
-! mask Only nodes with mask == 0 are considered
-!
-! gsize the number of nodes in the connected graph
-! deg degree for all the nodes in the connected graph
-! level levelization of the connected graph
-!
-!*******************************************************************************
-
-subroutine degree( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, level )
-
- implicit none
-
-!--------------------------------------------------------------- Input Variables
- integer root, nbnodes, nnz
- integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
-
-!-------------------------------------------------------------- Output Variables
- integer gsize
- integer deg(nbnodes), level(nbnodes)
-
-!--------------------------------------------------------------- Local Variables
- integer i, j, ideg, lbegin, lvlend, lvsize, nxt, nbr, node
-
-! added a test to detect disconnected subsets in the mesh
-! (in which case Cuthill-McKee fails and should be turned off)
- if(root > nbnodes+1) stop 'error: root > nbnodes+1 in Cuthill-McKee'
- if(root < 1) then
- print *,'error: root < 1 in Cuthill-McKee; you probably have a mesh composed of'
- print *,'two disconnected subsets of elements, in which case Cuthill-McKee fails and should be turned off.'
- print *,'please set PERFORM_CUTHILL_MCKEE = .false. in constants.h and recompile.'
- print *,'please also doublecheck that you indeed want to run two separate meshes simultaneously,'
- print *,'which is extremely unusual (but formally not incorrect).'
- stop 'fatal error in Cuthill-McKee'
- endif
-
-! The sign of xadj(I) is used to indicate if node i has been considered
- xadj(root) = -xadj(root)
- level(1) = root
- nxt = 1
- lvlend = 0
- lvsize = 1
-
- DO WHILE (lvsize > 0)
- ! lbegin/lvlend points the begin/end of the present level
- lbegin = lvlend + 1
- lvlend = nxt
-
- ! Find the degrees of nodes in the present level and generate the next level
- DO i= lbegin, lvlend
- node = level(i)
- ideg = 0
- do j= ABS( xadj(node) ), ABS( xadj(node+1) )-1
- nbr = adj(j)
-
- if (mask(nbr) /= 0) then
- ideg = ideg + 1
-
- if (xadj(nbr) >= 0) then
- xadj(nbr) = -xadj(nbr)
- nxt = nxt + 1
- level(nxt) = nbr
- endif
- endif
- enddo
-
- deg(node) = ideg
- ENDDO
-
- !Compute the level size of the next level
- lvsize = nxt - lvlend
- ENDDO
-
- !Reset xadj to its correct sign
- do i = 1, nxt
- node = level(i)
- xadj(node) = -xadj(node)
- enddo
-
- gsize = nxt
-
-END subroutine degree
-
-!
-!-----------------------------------------------------------------------
-!
-
- subroutine permute_elements_real(array_to_permute,temp_array,perm,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: nspec
- integer, intent(in), dimension(nspec) :: perm
-
- real(kind=CUSTOM_REAL), intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
-
- integer old_ispec,new_ispec
-
-! copy the original array
- temp_array(:,:,:) = array_to_permute(:,:,:)
-
- do old_ispec = 1,nspec
- new_ispec = perm(old_ispec)
- array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
- enddo
-
- end subroutine permute_elements_real
-
-!
-!-----------------------------------------------------------------------
-!
-
-! implement permutation of elements for arrays of integer type
- subroutine permute_elements_integer(array_to_permute,temp_array,perm,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: nspec
- integer, intent(in), dimension(nspec) :: perm
-
- integer, intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
-
- integer old_ispec,new_ispec
-
-! copy the original array
- temp_array(:,:,:) = array_to_permute(:,:,:)
-
- do old_ispec = 1,nspec
- new_ispec = perm(old_ispec)
- array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
- enddo
-
- end subroutine permute_elements_integer
-
-!
-!-----------------------------------------------------------------------
-!
-
-! implement permutation of elements for arrays of double precision type
- subroutine permute_elements_dble(array_to_permute,temp_array,perm,nspec)
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: nspec
- integer, intent(in), dimension(nspec) :: perm
-
- double precision, intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
-
- integer old_ispec,new_ispec
-
-! copy the original array
- temp_array(:,:,:) = array_to_permute(:,:,:)
-
- do old_ispec = 1,nspec
- new_ispec = perm(old_ispec)
- array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
- enddo
-
- end subroutine permute_elements_dble
-
Deleted: seismo/2D/SPECFEM2D/trunk/get_poroelastic_velocities.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/get_poroelastic_velocities.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/get_poroelastic_velocities.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,155 +0,0 @@
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!----
-!---- subroutine to compute poroelastic velocities cpI, cpII, & cs as a function of the dominant frequency
-!----
-
- subroutine get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
- tortl,rhol_s,rhol_f,etal_f,perm,fi,f0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- implicit none
-
- include "constants.h"
-
- double precision :: f0,w0il
- double precision :: H_biot,C_biot,M_biot
- double precision :: cpIsquare,cpIIsquare
- double precision :: cssquare,att_I,att_II
- double precision :: etal_f,rhol_f,rhol_s,rhol_bar,perm
- double precision :: mul_fr,phil,tortl
-
- double precision :: a_r,a_i,b_r,b_i,cc,alpha,aa1,aa2
- double precision :: xx,yy, gXI, gYI,gXII,gYII,w_c,f_c
- double precision :: wi,fi,taus,taue,Q0,bbr,bbi
-
- double precision :: gA,gB,sa,sb,xxs,yys
- logical :: TURN_VISCATTENUATION_ON
-
- rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
-
- w_c = etal_f*phil/(tortl*rhol_f*perm)
- f_c = w_c/(2*pi)
-
- wi=2.d0*pi*fi
-
- alpha=10.d0**dlog10(wi)
- w0il = 2.d0*pi*f0
- taue = (sqrt(Q0*Q0+1) +1)/(w0il*Q0)
- taus = (sqrt(Q0*Q0+1) -1)/(w0il*Q0)
-
- if(TURN_VISCATTENUATION_ON) then
-! high frequency, with memory variables
- bbr = etal_f/perm*(1.d0+alpha*alpha*taus*taue)/(1.d0 + alpha*alpha*taus*taus)
- bbi = etal_f/perm*alpha*(taue-taus)/(1.d0 + alpha*alpha*taus*taus)
- else
-! low frequency
- bbr = etal_f/perm
- bbi = 0.d0
- endif
-
-! cs
- gA = (rhol_f*tortl*rhol_bar-phil*rhol_f**2)**2/(phil*rhol_bar)**2 - (bbr**2-bbi**2)/alpha**2*&
- (phil*rhol_f/(rhol_bar*tortl) -1.d0) - bbi/alpha*phil*rhol_f/(rhol_bar*tortl)*&
- (rhol_f*tortl*rhol_bar-phil*rhol_f**2)/(phil*rhol_bar)
- gB = -2.d0*bbr*bbi/alpha**2*(phil*rhol_f/(rhol_bar*tortl) -1.d0) + bbr/alpha*phil*rhol_f/&
- (rhol_bar*tortl)*(rhol_f*tortl*rhol_bar-phil*rhol_f**2)/(phil*rhol_bar)
-!
- sa = (rhol_f*tortl*rhol_bar-phil*rhol_f**2)**2/(phil*rhol_bar)**2 + (bbr**2-bbi**2)/alpha**2
- sb = 2.d0*bbr*bbi/alpha**2
-!
- xxs = sa*gA + sb*gB
- yys = gA*sb - sa*gB
-
- cssquare = mul_fr/(rhol_bar-phil*rhol_f/tortl) * 2.d0*(gA**2+gB**2)/(sqrt(xxs**2+yys**2)+xxs)
-
-
-! cpI & cpII
- a_r = rhol_bar - phil*rhol_f/tortl - phil*rhol_bar/(tortl*rhol_f)*bbi/alpha
- a_i = phil*rhol_bar/(tortl*rhol_f)*bbr
- b_r = H_biot + M_biot*phil*rhol_bar/(tortl*rhol_f) - 2.d0*phil*C_biot/tortl - &
- phil*H_biot/(tortl*rhol_f)*bbi/alpha
- b_i = phil*H_biot/(tortl*rhol_f)*bbr
- cc = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
-!
- xx = b_r*b_r - b_i*b_i/(alpha*alpha) - 4.d0*a_r*cc
- yy = 2.d0*b_r*b_i/alpha - 4.d0*a_i/alpha*cc
-!
- gXI = a_r*(b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) + &
- a_i/alpha*(b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
-
- gYI = a_i/alpha*(b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) - &
- a_r*(b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
- gYI = -gYI
-
- gXII = a_r*(b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) + &
- a_i/alpha*(b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
-
- gYII = a_i/alpha*(b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) - &
- a_r*(b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
- gYII = -gYII
-!
-!
-!
- cpIsquare = ((b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2 + &
- (b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)/&
- (sqrt(gXI**2+gYI**2) + gXI)
-
- cpIIsquare = ((b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2 + &
- (b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)/&
- (sqrt(gXII**2+gYII**2) + gXII)
-
-! attenuation factors
- att_I = -alpha*sign(1.d0,yy)*sqrt(sqrt(gXI**2+gYI**2)-gXI) / &
- sqrt((b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2+&
- (b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)
- att_II = -alpha*sign(1.d0,yy)*sqrt(sqrt(gXII**2+gYII**2)-gXII) / &
- sqrt((b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2+&
- (b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)
-
-! inverse quality factors
- aa1 = -gYI/gXI
- aa2 = -gYII/gXII
-
- end subroutine get_poroelastic_velocities
-
Deleted: seismo/2D/SPECFEM2D/trunk/gll_library.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/gll_library.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/gll_library.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,534 +0,0 @@
-
-!=======================================================================
-!
-! Library to compute the Gauss-Lobatto-Legendre points and weights
-! Based on Gauss-Lobatto routines from M.I.T.
-! Department of Mechanical Engineering
-!
-!=======================================================================
-
- double precision function endw1(n,alpha,beta)
-
- implicit none
-
- integer n
- double precision alpha,beta
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
- double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
- double precision, external :: gammaf
- integer i
-
- f3 = zero
- apb = alpha+beta
- if(n == 0) then
- endw1 = zero
- return
- endif
- f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
- f1 = f1*(apb+two)*two**(apb+two)/two
- if(n == 1) then
- endw1 = f1
- return
- endif
- fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
- fint1 = fint1*two**(apb+two)
- fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
- fint2 = fint2*two**(apb+three)
- f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
- if(n == 2) then
- endw1 = f2
- return
- endif
- do i=3,n
- di = dble(i-1)
- abn = alpha+beta+di
- abnn = abn+di
- a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
- a2 = (two*(alpha-beta))/(abnn*(abnn+two))
- a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
- f3 = -(a2*f2+a1*f1)/a3
- f1 = f2
- f2 = f3
- enddo
- endw1 = f3
-
- end function endw1
-
-!
-!=======================================================================
-!
-
- double precision function endw2(n,alpha,beta)
-
- implicit none
-
- integer n
- double precision alpha,beta
-
- double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
- double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
- double precision, external :: gammaf
- integer i
-
- apb = alpha+beta
- f3 = zero
- if (n == 0) then
- endw2 = zero
- return
- endif
- f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
- f1 = f1*(apb+two)*two**(apb+two)/two
- if (n == 1) then
- endw2 = f1
- return
- endif
- fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
- fint1 = fint1*two**(apb+two)
- fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
- fint2 = fint2*two**(apb+three)
- f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
- if (n == 2) then
- endw2 = f2
- return
- endif
- do i=3,n
- di = dble(i-1)
- abn = alpha+beta+di
- abnn = abn+di
- a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
- a2 = (two*(alpha-beta))/(abnn*(abnn+two))
- a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
- f3 = -(a2*f2+a1*f1)/a3
- f1 = f2
- f2 = f3
- enddo
- endw2 = f3
-
- end function endw2
-
-!
-!=======================================================================
-!
-
- double precision function gammaf (x)
-
- implicit none
-
- double precision, parameter :: pi = 3.141592653589793d0
-
- double precision x
-
- double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
-
- gammaf = one
-
- if (x == -half) gammaf = -two*sqrt(pi)
- if (x == half) gammaf = sqrt(pi)
- if (x == one ) gammaf = one
- if (x == two ) gammaf = one
- if (x == 1.5d0) gammaf = sqrt(pi)/2.d0
- if (x == 2.5d0) gammaf = 1.5d0*sqrt(pi)/2.d0
- if (x == 3.5d0) gammaf = 2.5d0*1.5d0*sqrt(pi)/2.d0
- if (x == 3.d0 ) gammaf = 2.d0
- if (x == 4.d0 ) gammaf = 6.d0
- if (x == 5.d0 ) gammaf = 24.d0
- if (x == 6.d0 ) gammaf = 120.d0
-
- end function gammaf
-
-!
-!=====================================================================
-!
-
- subroutine jacg (xjac,np,alpha,beta)
-
-!=======================================================================
-!
-! computes np Gauss points, which are the zeros of the
-! Jacobi polynomial with parameters alpha and beta
-!
-! .alpha = beta = 0.0 -> Legendre points
-! .alpha = beta = -0.5 -> Chebyshev points
-!
-!=======================================================================
-
- implicit none
-
- integer np
- double precision alpha,beta
- double precision xjac(np)
-
- integer k,j,i,jmin,jm,n
- double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
- double precision p,pd,pm1,pdm1,pm2,pdm2
-
- integer, parameter :: K_MAX_ITER = 10
- double precision, parameter :: zero = 0.d0, eps = 1.0d-12
-
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- xlast = 0.d0
- n = np-1
- dth = 4.d0*atan(1.d0)/(2.d0*dble(n)+2.d0)
- p = 0.d0
- pd = 0.d0
- jmin = 0
- do j=1,np
- if(j == 1) then
- x = cos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
- else
- x1 = cos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
- x2 = xlast
- x = (x1+x2)/2.d0
- endif
- do k=1,K_MAX_ITER
- call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
- recsum = 0.d0
- jm = j-1
- do i=1,jm
- recsum = recsum+1.d0/(x-xjac(np-i+1))
- enddo
- delx = -p/(pd-recsum*p)
- x = x+delx
- if(abs(delx) < eps) goto 31
- enddo
- 31 continue
- xjac(np-j+1) = x
- xlast = x
- enddo
- do i=1,np
- xmin = 2.d0
- do j=i,np
- if(xjac(j) < xmin) then
- xmin = xjac(j)
- jmin = j
- endif
- enddo
- if(jmin /= i) then
- swap = xjac(i)
- xjac(i) = xjac(jmin)
- xjac(jmin) = swap
- endif
- enddo
-
- end subroutine jacg
-
-!
-!=====================================================================
-!
-
- subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
-
-!=======================================================================
-!
-! Computes the Jacobi polynomial of degree n and its derivative at x
-!
-!=======================================================================
-
- implicit none
-
- double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
- integer n
-
- double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
- integer k
-
- apb = alp+bet
- poly = 1.d0
- pder = 0.d0
- psave = 0.d0
- pdsave = 0.d0
-
- if (n == 0) return
-
- polyl = poly
- pderl = pder
- poly = (alp-bet+(apb+2.d0)*x)/2.d0
- pder = (apb+2.d0)/2.d0
- if (n == 1) return
-
- do k=2,n
- dk = dble(k)
- a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
- a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
- b3 = (2.d0*dk+apb-2.d0)
- a3 = b3*(b3+1.d0)*(b3+2.d0)
- a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
- polyn = ((a2+a3*x)*poly-a4*polyl)/a1
- pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
- psave = polyl
- pdsave = pderl
- polyl = poly
- poly = polyn
- pderl = pder
- pder = pdern
- enddo
-
- polym1 = polyl
- pderm1 = pderl
- polym2 = psave
- pderm2 = pdsave
-
- end subroutine jacobf
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision FUNCTION PNDLEG (Z,N)
-
-!------------------------------------------------------------------------
-!
-! Compute the derivative of the Nth order Legendre polynomial at Z.
-! Based on the recursion formula for the Legendre polynomials.
-!
-!------------------------------------------------------------------------
- implicit none
-
- double precision z
- integer n
-
- double precision P1,P2,P1D,P2D,P3D,FK,P3
- integer k
-
- P1 = 1.d0
- P2 = Z
- P1D = 0.d0
- P2D = 1.d0
- P3D = 1.d0
-
- do K = 1, N-1
- FK = dble(K)
- P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
- P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
- P1 = P2
- P2 = P3
- P1D = P2D
- P2D = P3D
- enddo
-
- PNDLEG = P3D
-
- end function pndleg
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision FUNCTION PNLEG (Z,N)
-
-!------------------------------------------------------------------------
-!
-! Compute the value of the Nth order Legendre polynomial at Z.
-! Based on the recursion formula for the Legendre polynomials.
-!
-!------------------------------------------------------------------------
- implicit none
-
- double precision z
- integer n
-
- double precision P1,P2,P3,FK
- integer k
-
- P1 = 1.d0
- P2 = Z
- P3 = P2
-
- do K = 1, N-1
- FK = dble(K)
- P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
- P1 = P2
- P2 = P3
- enddo
-
- PNLEG = P3
-
- end function pnleg
-
-!
-!------------------------------------------------------------------------
-!
-
- double precision function pnormj (n,alpha,beta)
-
- implicit none
-
- double precision alpha,beta
- integer n
-
- double precision one,two,dn,const,prod,dindx,frac
- double precision, external :: gammaf
- integer i
-
- one = 1.d0
- two = 2.d0
- dn = dble(n)
- const = alpha+beta+one
-
- if (n <= 1) then
- prod = gammaf(dn+alpha)*gammaf(dn+beta)
- prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
- pnormj = prod * two**const/(two*dn+const)
- return
- endif
-
- prod = gammaf(alpha+one)*gammaf(beta+one)
- prod = prod/(two*(one+const)*gammaf(const+one))
- prod = prod*(one+alpha)*(two+alpha)
- prod = prod*(one+beta)*(two+beta)
-
- do i=3,n
- dindx = dble(i)
- frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
- prod = prod*frac
- enddo
-
- pnormj = prod * two**const/(two*dn+const)
-
- end function pnormj
-
-!
-!------------------------------------------------------------------------
-!
-
- subroutine zwgjd(z,w,np,alpha,beta)
-
-!=======================================================================
-!
-! Z w g j d : Generate np Gauss-Jacobi points and weights
-! associated with Jacobi polynomial of degree n = np-1
-!
-! Note : Coefficients alpha and beta must be greater than -1.
-! ----
-!=======================================================================
-
- implicit none
- include 'constants.h'
-
- !double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
-
- integer np
- double precision z(np)
- real(kind=CUSTOM_REAL) :: w(np)
- double precision alpha,beta
-
- integer n,np1,np2,i
- double precision p,pd,pm1,pdm1,pm2,pdm2
- double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
- double precision, external :: gammaf,pnormj
-
- pd = zero
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- n = np-1
- apb = alpha+beta
- p = zero
- pdm1 = zero
-
- if (np <= 0) call exit_MPI('minimum number of Gauss points is 1')
-
- if ((alpha <= -one) .or. (beta <= -one)) call exit_MPI('alpha and beta must be greater than -1')
-
- if (np == 1) then
- z(1) = (beta-alpha)/(apb+two)
- w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
- return
- endif
-
- call jacg(z,np,alpha,beta)
-
- np1 = n+1
- np2 = n+2
- dnp1 = dble(np1)
- dnp2 = dble(np2)
- fac1 = dnp1+alpha+beta+one
- fac2 = fac1+dnp1
- fac3 = fac2+one
- fnorm = pnormj(np1,alpha,beta)
- rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
- do i=1,np
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
- w(i) = -rcoef/(p*pdm1)
- enddo
-
- end subroutine zwgjd
-
-!
-!------------------------------------------------------------------------
-!
-
- subroutine zwgljd(z,w,np,alpha,beta)
-
-!=======================================================================
-!
-! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
-! ----------- weights associated with Jacobi polynomials of degree
-! n = np-1.
-!
-! Note : alpha and beta coefficients must be greater than -1.
-! Legendre polynomials are special case of Jacobi polynomials
-! just by setting alpha and beta to 0.
-!
-!=======================================================================
-
- implicit none
- include 'constants.h'
-
-
- !double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
-
- integer np
- double precision alpha,beta
- double precision z(np)
- real(kind=CUSTOM_REAL) :: w(np)
-
- integer n,nm1,i
- double precision p,pd,pm1,pdm1,pm2,pdm2
- double precision alpg,betg
- double precision, external :: endw1,endw2
-
- p = zero
- pm1 = zero
- pm2 = zero
- pdm1 = zero
- pdm2 = zero
-
- n = np-1
- nm1 = n-1
- pd = zero
-
- if (np <= 1) call exit_MPI('minimum number of Gauss-Lobatto points is 2')
-
-! with spectral elements, use at least 3 points
- if (np <= 2) call exit_MPI('minimum number of Gauss-Lobatto points for the SEM is 3')
-
- if ((alpha <= -one) .or. (beta <= -one)) call exit_MPI('alpha and beta must be greater than -1')
-
- if (nm1 > 0) then
- alpg = alpha+one
- betg = beta+one
- call zwgjd(z(2),w(2),nm1,alpg,betg)
- endif
-
- z(1) = - one
- z(np) = one
-
- do i=2,np-1
- w(i) = w(i)/(one-z(i)**2)
- enddo
-
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
- w(1) = endw1(n,alpha,beta)/(two*pd)
- call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
- w(np) = endw2(n,alpha,beta)/(two*pd)
-
- end subroutine zwgljd
-
Deleted: seismo/2D/SPECFEM2D/trunk/gmat01.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/gmat01.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/gmat01.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,396 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine gmat01(density_array,porosity_array,tortuosity_array, &
- aniso_array,permeability,poroelastcoef, &
- numat,myrank,ipass,Qp_array,Qs_array, &
- freq0,Q0,f0,TURN_VISCATTENUATION_ON)
-
-! reads properties of a 2D isotropic or anisotropic linear elastic element
-
- implicit none
- include "constants.h"
-
- integer :: numat,myrank,ipass
- double precision :: density_array(2,numat),poroelastcoef(4,3,numat),porosity_array(numat)
- double precision :: aniso_array(6,numat),tortuosity_array(numat),permeability(3,numat)
- double precision :: Qp_array(numat),Qs_array(numat)
- double precision :: f0,Q0,freq0
- logical :: TURN_VISCATTENUATION_ON
-
- ! local parameters
- double precision :: lambdaplus2mu,kappa
- double precision :: young,poisson,cp,cs,mu,two_mu,lambda,Qp,Qs
- double precision :: lambdaplus2mu_s,lambdaplus2mu_fr,kappa_s,kappa_f,kappa_fr
- double precision :: young_s,poisson_s,density(2),phi,tortuosity
- double precision :: cpIsquare,cpIIsquare,cssquare,mu_s,mu_fr,eta_f,lambda_s,lambda_fr
- double precision :: val1,val2,val3,val4,val5,val6
- double precision :: val7,val8,val9,val10,val11,val12,val0
- double precision :: c11,c13,c15,c33,c35,c55
- double precision :: D_biot,H_biot,C_biot,M_biot
- double precision :: w_c
- integer in,n,indic
- character(len=80) datlin
-
-
- !
- !---- loop over the different material sets
- !
- density_array(:,:) = zero
- porosity_array(:) = zero
- tortuosity_array(:) = zero
- aniso_array(:,:) = zero
- permeability(:,:) = zero
- poroelastcoef(:,:,:) = zero
- Qp_array(:) = zero
- Qs_array(:) = zero
-
- if(myrank == 0 .and. ipass == 1) write(IOUT,100) numat
-
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- do in = 1,numat
-
- read(IIN,*) n,indic,val0,val1,val2,val3,val4,val5,val6,val7,val8,val9,val10,val11,val12
-
- if(n<1 .or. n>numat) call exit_MPI('Wrong material set number')
-
- !---- isotropic material, P and S velocities given, allows for declaration of elastic/acoustic material
- !---- elastic (cs/=0) and acoustic (cs=0)
- if(indic == 1) then
- density(1) = val0
-
- ! P and S velocity
- cp = val1
- cs = val2
-
- ! Qp and Qs values
- Qp = val5
- Qs = val6
-
- ! Lam'e parameters
- lambdaplus2mu = density(1)*cp*cp
- mu = density(1)*cs*cs
- two_mu = 2.d0*mu
- lambda = lambdaplus2mu - two_mu
-
- ! bulk modulus Kappa
- kappa = lambda + two_mu/3.d0
-
- ! Young modulus
- young = 9.d0*kappa*mu/(3.d0*kappa + mu)
-
- ! Poisson's ratio
- poisson = half*(3.d0*kappa-two_mu)/(3.d0*kappa+mu)
-
- ! Poisson's ratio must be between -1 and +1/2
- if (poisson < -1.d0 .or. poisson > 0.5d0) call exit_MPI('Poisson''s ratio out of range')
-
- !---- anisotropic material, c11, c13, c33 and c44 given in Pascal
- else if (indic == 2) then
-
- density(1) =val0
-
- ! P and S velocity
- cp = 20
- cs = 10
-
- ! Anisotropy parameters
- c11 = val1
- c13 = val2
- c15 = val3
- c33 = val4
- c35 = val5
- c55 = val6
-
- ! Qp and Qs values
- !Qp = val9
- !Qs = val10
-
- ! Lam'e parameters
- lambdaplus2mu = density(1)*cp*cp
- mu = density(1)*cs*cs
- two_mu = 2.d0*mu
- lambda = lambdaplus2mu - two_mu
-
- ! bulk modulus Kappa
- kappa = lambda + two_mu/3.d0
-
- ! Young modulus
- young = 9.d0*kappa*mu/(3.d0*kappa + mu)
-
- ! Poisson's ratio
- poisson = half*(3.d0*kappa-two_mu)/(3.d0*kappa+mu)
-
- !---- isotropic material, moduli are given, allows for declaration of poroelastic material
- !---- poroelastic (0<phi<1)
- else if (indic == 3) then
- ! Qs values
- Qs = val12
-
- density(1) =val0
- density(2) =val1
-
- ! Solid properties
- kappa_s = val7
- mu_s = val11
- ! Fluid properties
- kappa_f = val8
- eta_f = val10
- ! Frame properties
- kappa_fr = val9
- mu_fr = val11
- ! Lam'e parameters for the solid phase and the frame
- lambdaplus2mu_s = kappa_s + FOUR_THIRDS*mu_s
- lambda_s = lambdaplus2mu_s - 2.d0*mu_s
- lambdaplus2mu_fr = kappa_fr + FOUR_THIRDS*mu_fr
- lambda_fr = lambdaplus2mu_fr - 2.d0*mu_fr
- phi = val2
- tortuosity = val3
-
- ! Biot coefficients for the input phi
- D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
- H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
- C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
- M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
-
- call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare, &
- H_biot,C_biot,M_biot,mu_fr,phi, &
- tortuosity,density(1),density(2),eta_f, &
- val4,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
-
- porosity_array(n) = val2
- tortuosity_array(n) = val3
- permeability(1,n) = val4
- permeability(2,n) = val5
- permeability(3,n) = val6
-
- ! Young modulus for the solid phase
- young_s = 9.d0*kappa_s*mu_s/(3.d0*kappa_s + mu_s)
-
- ! Poisson's ratio for the solid phase
- poisson_s = HALF*(3.d0*kappa_s- 2.d0*mu_s)/(3.d0*kappa_s+mu_s)
-
- ! Poisson's ratio must be between -1 and +1/2
- if (poisson_s < -1.d0 .or. poisson_s > 0.5d0) stop 'Poisson''s ratio for the solid phase out of range'
-
- else
- call exit_MPI('wrong model flag read')
-
- endif
-
- !
- !---- set elastic coefficients and density
- !
- ! Isotropic : lambda, mu, K (= lambda + 2*mu), zero
- ! Transverse anisotropic : c11, c13, c33, c44
- !
- if(indic == 1) then
- density_array(1,n) = density(1)
- poroelastcoef(1,1,n) = lambda
- poroelastcoef(2,1,n) = mu
- poroelastcoef(3,1,n) = lambdaplus2mu
- poroelastcoef(4,1,n) = zero
- Qp_array(n) = Qp
- Qs_array(n) = Qs
- if(mu > TINYVAL) then
- porosity_array(n) = 0.d0
- else
- porosity_array(n) = 1.d0
- endif
- elseif (indic == 2) then
- density_array(1,n) = density(1)
-! dummy poroelastcoef values, trick to avoid floating invalid
- poroelastcoef(1,1,n) = lambda
- poroelastcoef(2,1,n) = mu
- poroelastcoef(3,1,n) = lambdaplus2mu
- poroelastcoef(4,1,n) = zero
- aniso_array(1,n) = c11
- aniso_array(2,n) = c13
- aniso_array(3,n) = c15
- aniso_array(4,n) = c33
- aniso_array(5,n) = c35
- aniso_array(6,n) = c55
-! dummy Q values, trick to avoid a bug in attenuation_model
- Qp_array(n) = 15
- Qs_array(n) = 15
- porosity_array(n) = 0.d0
- elseif (indic == 3) then
- density_array(1,n) = density(1)
- density_array(2,n) = density(2)
- poroelastcoef(1,1,n) = lambda_s
- poroelastcoef(2,1,n) = mu_s ! = mu_fr
- poroelastcoef(3,1,n) = lambdaplus2mu_s
- poroelastcoef(4,1,n) = zero
-
- poroelastcoef(1,2,n) = kappa_f
- poroelastcoef(2,2,n) = eta_f
- poroelastcoef(3,2,n) = zero
- poroelastcoef(4,2,n) = zero
-
- poroelastcoef(1,3,n) = lambda_fr
- poroelastcoef(2,3,n) = mu_fr
- poroelastcoef(3,3,n) = lambdaplus2mu_fr
- poroelastcoef(4,3,n) = zero
- Qp_array(n) = 10.d0 ! dummy for attenuation_model
- Qs_array(n) = Qs
- endif
-
- !
- !---- check what has been read
- !
- if(myrank == 0 .and. ipass == 1) then
- if(indic == 1) then
- ! material can be acoustic (fluid) or elastic (solid)
- if(poroelastcoef(2,1,n) > TINYVAL) then ! elastic
- write(IOUT,200) n,cp,cs,density(1),poisson,lambda,mu,kappa,young,Qp,Qs
- else ! acoustic
- write(IOUT,300) n,cp,density(1),kappa,Qp,Qs
- endif
- elseif(indic == 2) then ! elastic (anisotropic)
- write(IOUT,400) n,density(1),c11,c13,c15,c33,c35,c55
- elseif(indic == 3) then
- ! material is poroelastic (solid/fluid)
- write(iout,500) n,sqrt(cpIsquare),sqrt(cpIIsquare),sqrt(cssquare)
- write(iout,600) density(1),poisson_s,lambda_s,mu_s,kappa_s,young_s
- write(iout,700) density(2),kappa_f,eta_f
- write(iout,800) lambda_fr,mu_fr,kappa_fr,porosity_array(n),tortuosity_array(n),&
- permeability(1,n),permeability(2,n),permeability(3,n),Qs
- write(iout,900) D_biot,H_biot,C_biot,M_biot,w_c
- endif
- endif
-
- enddo
-
- !
- !---- formats
- !
-100 format(//,' M a t e r i a l s e t s : ', &
- ' 2 D (p o r o) e l a s t i c i t y', &
- /1x,54('='),//5x,'Number of material sets . . . . . . (numat) =',i6)
-
-200 format(//5x,'----------------------------------------',/5x, &
- '-- Elastic (solid) isotropic material --',/5x, &
- '----------------------------------------',/5x, &
- 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
- 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
- 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8,/5x, &
- 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
- 'Poisson''s ratio. . . . . . . . .(poisson) =',1pe15.8,/5x, &
- 'First Lame parameter Lambda. . . (lambda) =',1pe15.8,/5x, &
- 'Second Lame parameter Mu. . . . . . .(mu) =',1pe15.8,/5x, &
- 'Bulk modulus Kappa . . . . . . . .(kappa) =',1pe15.8,/5x, &
- 'Young''s modulus E. . . . . . . . .(young) =',1pe15.8,/5x, &
- 'Qp_attenuation. . . . . . . . . . . .(Qp) =',1pe15.8,/5x, &
- 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
-
-300 format(//5x,'-------------------------------',/5x, &
- '-- Acoustic (fluid) material --',/5x, &
- '-------------------------------',/5x, &
- 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
- 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
- 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
- 'Bulk modulus Kappa . . . . . . . .(kappa) =',1pe15.8,/5x, &
- 'Qp_attenuation. . . . . . . . . . . .(Qp) =',1pe15.8,/5x, &
- 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
-
-400 format(//5x,'-------------------------------------',/5x, &
- '-- Transverse anisotropic material --',/5x, &
- '-------------------------------------',/5x, &
- 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
- 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
- 'c11 coefficient (Pascal). . . . . . (c11) =',1pe15.8,/5x, &
- 'c13 coefficient (Pascal). . . . . . (c13) =',1pe15.8,/5x, &
- 'c15 coefficient (Pascal). . . . . . (c15) =',1pe15.8,/5x, &
- 'c33 coefficient (Pascal). . . . . . (c33) =',1pe15.8,/5x, &
- 'c35 coefficient (Pascal). . . . . . (c35) =',1pe15.8,/5x, &
- 'c55 coefficient (Pascal). . . . . . (c55) =',1pe15.8,/5x)
-
-500 format(//5x,'----------------------------------------',/5x, &
- '-- Poroelastic isotropic material --',/5x, &
- '----------------------------------------',/5x, &
- 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
- 'First P-wave velocity. . . . . . . . . . . (cpI) =',1pe15.8,/5x, &
- 'Second P-wave velocity. . . . . . . . . . . (cpII) =',1pe15.8,/5x, &
- 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8)
-
-600 format(//5x,'-------------------------------',/5x, &
- '-- Solid phase properties --',/5x, &
- 'Mass density. . . . . . . . . . (density_s) =',1pe15.8,/5x, &
- 'Poisson''s ratio. . . . . . . . .(poisson_s) =',1pe15.8,/5x, &
- 'First Lame parameter Lambda. . . (lambda_s) =',1pe15.8,/5x, &
- 'Second Lame parameter Mu. . . . . . .(mu_s) =',1pe15.8,/5x, &
- 'Solid bulk modulus Kappa . . . . . . . .(kappa_s) =',1pe15.8,/5x, &
- 'Young''s modulus E. . . . . . . . .(young_s) =',1pe15.8)
-
-700 format(//5x,'-------------------------------',/5x, &
- '-- Fluid phase properties --',/5x, &
- 'Mass density. . . . . . . . . . (density_f) =',1pe15.8,/5x, &
- 'Fluid bulk modulus Kappa . . . . . . . .(kappa_f) =',1pe15.8,/5x, &
- 'Fluid viscosity Eta . . . . . . . .(eta_f) =',1pe15.8)
-
-800 format(//5x,'-------------------------------',/5x, &
- '-- Frame properties --',/5x, &
- 'First Lame parameter Lambda. . . (lambda_fr) =',1pe15.8,/5x, &
- 'Second Lame parameter Mu. . . . . . .(mu_fr) =',1pe15.8,/5x, &
- 'Frame bulk modulus Kappa . . . . . . . .(kappa_fr) =',1pe15.8,/5x, &
- 'Porosity. . . . . . . . . . . . . . . . .(phi) =',1pe15.8,/5x,&
- 'Tortuosity. . . . . . . . . . . . . . . . .(c) =',1pe15.8,/5x,&
- 'Permeability xx component. . . . . . . . . . =',1pe15.8,/5x,&
- 'Permeability zx component. . . . . . . . . . =',1pe15.8,/5x,&
- 'Permeability zz component. . . . . . . . . . =',1pe15.8,/5x,&
- 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
-
-900 format(//5x,'-------------------------------',/5x, &
- '-- Biot coefficients --',/5x, &
- '-------------------------------',/5x, &
- 'D. . . . . . . . =',1pe15.8,/5x, &
- 'H. . . . . . . . =',1pe15.8,/5x, &
- 'C. . . . . . . . =',1pe15.8,/5x, &
- 'M. . . . . . . . =',1pe15.8,/5x, &
- 'characteristic freq =',1pe15.8)
-
- end subroutine gmat01
-
Deleted: seismo/2D/SPECFEM2D/trunk/include_for_periodic_conditions.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/include_for_periodic_conditions.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/include_for_periodic_conditions.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,105 +0,0 @@
-
-!----------------------------------------------------------------------
- do ispecperio2 = 1,NSPEC_PERIO
-
- ispec2 = numperio_right(ispecperio2)
-
- if(codeabs_perio_right(ILEFT,ispecperio2)) then
- i2 = 1
- do j2 = 1,NGLLZ
- iglob2 = ibool(i2,j2,ispec2)
- if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
- (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
- print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
-! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
-! print *,ispec,i,j,ispec2,i2,j2
-! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
-!--------------------------------------------------------------------------------
- iglob_target_to_replace = ibool(i2,j2,ispec2)
- do ispec3 = 1,nspec
- do j3 = 1,NGLLZ
- do i3 = 1,NGLLX
- if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
- enddo
- enddo
- enddo
-!--------------------------------------------------------------------------------
- endif
- enddo
- endif
-
- if(codeabs_perio_right(IRIGHT,ispecperio2)) then
- i2 = NGLLX
- do j2 = 1,NGLLZ
- iglob2 = ibool(i2,j2,ispec2)
- if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
- (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
- print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
-! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
-! print *,ispec,i,j,ispec2,i2,j2
-! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
-!--------------------------------------------------------------------------------
- iglob_target_to_replace = ibool(i2,j2,ispec2)
- do ispec3 = 1,nspec
- do j3 = 1,NGLLZ
- do i3 = 1,NGLLX
- if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
- enddo
- enddo
- enddo
-!--------------------------------------------------------------------------------
- endif
- enddo
- endif
-
- if(codeabs_perio_right(IBOTTOM,ispecperio2)) then
- j2 = 1
- do i2 = 1,NGLLX
- iglob2 = ibool(i2,j2,ispec2)
- if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
- (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
- print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
-! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
-! print *,ispec,i,j,ispec2,i2,j2
-! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
-!--------------------------------------------------------------------------------
- iglob_target_to_replace = ibool(i2,j2,ispec2)
- do ispec3 = 1,nspec
- do j3 = 1,NGLLZ
- do i3 = 1,NGLLX
- if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
- enddo
- enddo
- enddo
-!--------------------------------------------------------------------------------
- endif
- enddo
- endif
-
- if(codeabs_perio_right(ITOP,ispecperio2)) then
- j2 = NGLLZ
- do i2 = 1,NGLLX
- iglob2 = ibool(i2,j2,ispec2)
- if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
- (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
- print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
-! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
-! print *,ispec,i,j,ispec2,i2,j2
-! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
-!--------------------------------------------------------------------------------
- iglob_target_to_replace = ibool(i2,j2,ispec2)
- do ispec3 = 1,nspec
- do j3 = 1,NGLLZ
- do i3 = 1,NGLLX
- if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
- enddo
- enddo
- enddo
-!--------------------------------------------------------------------------------
- endif
- enddo
- endif
-
- enddo
-!----------------------------------------------------------------------
-
Deleted: seismo/2D/SPECFEM2D/trunk/initialize_simulation.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/initialize_simulation.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/initialize_simulation.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,120 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine initialize_simulation(nproc,myrank,NUMBER_OF_PASSES, &
- ninterface_acoustic,ninterface_elastic,ninterface_poroelastic)
-
- implicit none
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: nproc,myrank,NUMBER_OF_PASSES
- integer :: ninterface_acoustic, ninterface_elastic,ninterface_poroelastic
-
- ! local parameters
- integer :: ier
- character(len=256) :: prname
-
-!***********************************************************************
-!
-! i n i t i a l i z a t i o n p h a s e
-!
-!***********************************************************************
-
-#ifdef USE_MPI
- call MPI_INIT(ier)
- call MPI_COMM_SIZE(MPI_COMM_WORLD,nproc,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
- if( ier /= 0 ) call exit_MPI('error MPI initialization')
-
- ! this is only used in the case of MPI because it distinguishes between inner and outer element
- ! in the MPI partitions, which is meaningless in the serial case
- if(FURTHER_REDUCE_CACHE_MISSES) then
- NUMBER_OF_PASSES = 2
- else
- NUMBER_OF_PASSES = 1
- endif
-
-#else
- nproc = 1
- myrank = 0
- !ier = 0
- !ninterface_acoustic = 0
- !ninterface_elastic = 0
- !ninterface_poroelastic = 0
- !iproc = 0
- !ispec_inner = 0
- !ispec_outer = 0
-
- if(PERFORM_CUTHILL_MCKEE) then
- NUMBER_OF_PASSES = 2
- else
- NUMBER_OF_PASSES = 1
- endif
-#endif
-
- ninterface_acoustic = 0
- ninterface_elastic = 0
- ninterface_poroelastic = 0
-
- ! determine if we write to file instead of standard output
- if(IOUT /= ISTANDARD_OUTPUT) then
-
-#ifdef USE_MPI
- write(prname,240) myrank
- 240 format('simulation_results',i5.5,'.txt')
-#else
- prname = 'simulation_results.txt'
-#endif
-
- open(IOUT,file=prname,status='unknown',action='write',iostat=ier)
- if( ier /= 0 ) call exit_MPI('error opening file simulation_results***.txt')
-
- endif
-
- end subroutine initialize_simulation
Deleted: seismo/2D/SPECFEM2D/trunk/invert_mass_matrix.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/invert_mass_matrix.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/invert_mass_matrix.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,206 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine invert_mass_matrix_init(any_elastic,any_acoustic,any_poroelastic, &
- rmass_inverse_elastic,npoin_elastic, &
- rmass_inverse_acoustic,npoin_acoustic, &
- rmass_s_inverse_poroelastic, &
- rmass_w_inverse_poroelastic,npoin_poroelastic, &
- nspec,ibool,kmato,wxgll,wzgll,jacobian, &
- elastic,poroelastic, &
- assign_external_model,numat, &
- density,poroelastcoef,porosity,tortuosity, &
- vpext,rhoext)
-
-! builds the global mass matrix
-
- implicit none
- include 'constants.h'
-
- logical any_elastic,any_acoustic,any_poroelastic
-
- ! inverse mass matrices
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(npoin_elastic) :: rmass_inverse_elastic
-
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: rmass_inverse_acoustic
-
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(npoin_poroelastic) :: &
- rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
-
- integer :: nspec
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: kmato
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wzgll
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: jacobian
-
- logical,dimension(nspec) :: elastic,poroelastic
-
- logical :: assign_external_model
- integer :: numat
- double precision, dimension(2,numat) :: density
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,rhoext
-
- ! local parameters
- integer :: ispec,i,j,iglob
- double precision :: rhol,kappal,mul_relaxed,lambdal_relaxed
- double precision :: rhol_s,rhol_f,rhol_bar,phil,tortl
-
- ! initializes mass matrix
- if(any_elastic) rmass_inverse_elastic(:) = 0._CUSTOM_REAL
- if(any_poroelastic) rmass_s_inverse_poroelastic(:) = 0._CUSTOM_REAL
- if(any_poroelastic) rmass_w_inverse_poroelastic(:) = 0._CUSTOM_REAL
- if(any_acoustic) rmass_inverse_acoustic(:) = 0._CUSTOM_REAL
-
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
-
- ! if external density model (elastic or acoustic)
- if(assign_external_model) then
- rhol = rhoext(i,j,ispec)
- kappal = rhol * vpext(i,j,ispec)**2
- else
- rhol = density(1,kmato(ispec))
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- kappal = lambdal_relaxed + 2.d0/3.d0*mul_relaxed
- endif
-
- if( poroelastic(ispec) ) then
-
- ! material is poroelastic
-
- rhol_s = density(1,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- rhol_bar = (1.d0-phil)*rhol_s + phil*rhol_f
-
- ! for the solid mass matrix
- rmass_s_inverse_poroelastic(iglob) = rmass_s_inverse_poroelastic(iglob) &
- + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar - phil*rhol_f/tortl)
- ! for the fluid mass matrix
- rmass_w_inverse_poroelastic(iglob) = rmass_w_inverse_poroelastic(iglob) &
- + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar*rhol_f*tortl &
- - phil*rhol_f*rhol_f)/(rhol_bar*phil)
-
- elseif( elastic(ispec) ) then
-
- ! for elastic medium
-
- rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) &
- + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
-
- else
-
- ! for acoustic medium
-
- rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) &
- + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / kappal
-
- endif
-
- enddo
- enddo
- enddo ! do ispec = 1,nspec
-
- end subroutine invert_mass_matrix_init
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine invert_mass_matrix(any_elastic,any_acoustic,any_poroelastic, &
- rmass_inverse_elastic,npoin_elastic, &
- rmass_inverse_acoustic,npoin_acoustic, &
- rmass_s_inverse_poroelastic, &
- rmass_w_inverse_poroelastic,npoin_poroelastic)
-
-! inverts the global mass matrix
-
- implicit none
- include 'constants.h'
-
- logical any_elastic,any_acoustic,any_poroelastic
-
-! inverse mass matrices
- integer :: npoin_elastic
- real(kind=CUSTOM_REAL), dimension(npoin_elastic) :: rmass_inverse_elastic
-
- integer :: npoin_acoustic
- real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: rmass_inverse_acoustic
-
- integer :: npoin_poroelastic
- real(kind=CUSTOM_REAL), dimension(npoin_poroelastic) :: &
- rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
-
-
-! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
- if(any_elastic) &
- where(rmass_inverse_elastic <= 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
- if(any_poroelastic) &
- where(rmass_s_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_s_inverse_poroelastic = 1._CUSTOM_REAL
- if(any_poroelastic) &
- where(rmass_w_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_w_inverse_poroelastic = 1._CUSTOM_REAL
- if(any_acoustic) &
- where(rmass_inverse_acoustic <= 0._CUSTOM_REAL) rmass_inverse_acoustic = 1._CUSTOM_REAL
-
-! compute the inverse of the mass matrix
- if(any_elastic) &
- rmass_inverse_elastic(:) = 1._CUSTOM_REAL / rmass_inverse_elastic(:)
- if(any_poroelastic) &
- rmass_s_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_s_inverse_poroelastic(:)
- if(any_poroelastic) &
- rmass_w_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_w_inverse_poroelastic(:)
- if(any_acoustic) &
- rmass_inverse_acoustic(:) = 1._CUSTOM_REAL / rmass_inverse_acoustic(:)
-
- end subroutine invert_mass_matrix
Deleted: seismo/2D/SPECFEM2D/trunk/is_in_convex_quadrilateral.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/is_in_convex_quadrilateral.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/is_in_convex_quadrilateral.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,77 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine is_in_convex_quadrilateral(elmnt_coords, x_coord, z_coord, is_in)
-
- implicit none
-
- double precision, dimension(2,4) :: elmnt_coords
- double precision, intent(in) :: x_coord, z_coord
- logical, intent(out) :: is_in
-
- real :: x1, x2, x3, x4, z1, z2, z3, z4
- real :: normal1, normal2, normal3, normal4
-
- x1 = elmnt_coords(1,1)
- x2 = elmnt_coords(1,2)
- x3 = elmnt_coords(1,3)
- x4 = elmnt_coords(1,4)
- z1 = elmnt_coords(2,1)
- z2 = elmnt_coords(2,2)
- z3 = elmnt_coords(2,3)
- z4 = elmnt_coords(2,4)
-
- normal1 = (z_coord-z1) * (x2-x1) - (x_coord-x1) * (z2-z1)
- normal2 = (z_coord-z2) * (x3-x2) - (x_coord-x2) * (z3-z2)
- normal3 = (z_coord-z3) * (x4-x3) - (x_coord-x3) * (z4-z3)
- normal4 = (z_coord-z4) * (x1-x4) - (x_coord-x4) * (z1-z4)
-
- if ((normal1 < 0) .or. (normal2 < 0) .or. (normal3 < 0) .or. (normal4 < 0)) then
- is_in = .false.
- else
- is_in = .true.
- endif
-
- end subroutine is_in_convex_quadrilateral
-
Deleted: seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,162 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- double precision function hgll(I,Z,ZGLL,NZ)
-
-!-------------------------------------------------------------
-!
-! Compute the value of the Lagrangian interpolant L through
-! the NZ Gauss-Lobatto Legendre points ZGLL at point Z
-!
-!-------------------------------------------------------------
-
- implicit none
-
- integer i,nz
- double precision z
- double precision ZGLL(0:nz-1)
-
- integer n
- double precision EPS,DZ,ALFAN
- double precision, external :: PNLEG,PNDLEG
-
- EPS = 1.d-5
- DZ = Z - ZGLL(I)
- if(abs(DZ) < EPS) then
- HGLL = 1.d0
- return
- endif
- N = NZ - 1
- ALFAN = dble(N)*(dble(N)+1.d0)
- HGLL = - (1.d0-Z*Z)*PNDLEG(Z,N)/ (ALFAN*PNLEG(ZGLL(I),N)*(Z-ZGLL(I)))
-
- end function hgll
-
-!
-!=====================================================================
-!
-
- subroutine lagrange_any(xi,NGLL,xigll,h,hprime)
-
-! subroutine to compute the Lagrange interpolants based upon the GLL points
-! and their first derivatives at any point xi in [-1,1]
-
- implicit none
-
- integer NGLL
- double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)
-
- integer dgr,i,j
- double precision prod1,prod2
-
- do dgr=1,NGLL
-
- prod1 = 1.0d0
- prod2 = 1.0d0
- do i=1,NGLL
- if(i /= dgr) then
- prod1 = prod1*(xi-xigll(i))
- prod2 = prod2*(xigll(dgr)-xigll(i))
- endif
- enddo
- h(dgr)=prod1/prod2
-
- hprime(dgr)=0.0d0
- do i=1,NGLL
- if(i /= dgr) then
- prod1=1.0d0
- do j=1,NGLL
- if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
- enddo
- hprime(dgr) = hprime(dgr)+prod1
- endif
- enddo
- hprime(dgr) = hprime(dgr)/prod2
-
- enddo
-
- end subroutine lagrange_any
-
-!
-!=====================================================================
-!
-
-! subroutine to compute the derivative of the Lagrange interpolants
-! at the GLL points at any given GLL point
-
- double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)
-
-!------------------------------------------------------------------------
-!
-! Compute the value of the derivative of the I-th
-! Lagrange interpolant through the
-! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
-!
-!------------------------------------------------------------------------
-
- implicit none
-
- integer i,j,nz
- double precision zgll(0:nz-1)
-
- integer degpoly
-
- double precision, external :: pnleg,pndleg
-
- degpoly = nz - 1
- if (i == 0 .and. j == 0) then
- lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
- else if (i == degpoly .and. j == degpoly) then
- lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
- else if (i == j) then
- lagrange_deriv_GLL = 0.d0
- else
- lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
- (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
- + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
- (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
- endif
-
- end function lagrange_deriv_GLL
-
Deleted: seismo/2D/SPECFEM2D/trunk/locate_receivers.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_receivers.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/locate_receivers.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,317 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!----
-!---- locate_receivers finds the correct position of the receivers
-!----
-
- subroutine locate_receivers(ibool,coord,nspec,npoin,xigll,zigll, &
- nrec,nrecloc,recloc,which_proc_receiver,nproc,myrank, &
- st_xval,st_zval,ispec_selected_rec, &
- xi_receiver,gamma_receiver,station_name,network_name, &
- x_source,z_source, &
- coorg,knods,ngnod,npgeo,ipass, &
- x_final_receiver, z_final_receiver)
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer nrec,nspec,npoin,ngnod,npgeo,ipass
- integer, intent(in) :: nproc, myrank
-
- integer knods(ngnod,nspec)
- double precision coorg(NDIM,npgeo)
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
-! array containing coordinates of the points
- double precision coord(NDIM,npoin)
-
- integer irec,i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
-
- double precision x_source,z_source,dist,stele,stbur
- double precision, dimension(nrec) :: distance_receiver
- double precision xi,gamma,dx,dz,dxi,dgamma
-
-! Gauss-Lobatto-Legendre points of integration
- double precision xigll(NGLLX)
- double precision zigll(NGLLZ)
-
- double precision x,z,xix,xiz,gammax,gammaz,jacobian
-
-! use dynamic allocation
- double precision distmin
- double precision, dimension(:), allocatable :: final_distance
-
-! receiver information
- integer :: nrecloc
- integer, dimension(nrec) :: ispec_selected_rec, recloc
- double precision, dimension(nrec) :: xi_receiver,gamma_receiver
-
-! station information for writing the seismograms
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- double precision, dimension(nrec) :: st_xval,st_zval
-
-! tangential detection
- double precision, dimension(nrec) :: x_final_receiver, z_final_receiver
-
- double precision, dimension(nrec,nproc) :: gather_final_distance
- double precision, dimension(nrec,nproc) :: gather_xi_receiver, gather_gamma_receiver
- integer, dimension(nrec,nproc) :: gather_ispec_selected_rec
- integer, dimension(nrec), intent(inout) :: which_proc_receiver
- integer :: ierror
-
-
- ierror = 0
-#ifdef USE_MPI
- call MPI_BARRIER(MPI_COMM_WORLD,ierror)
-#endif
-
-! **************
-
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) '********************'
- write(IOUT,*) ' locating receivers'
- write(IOUT,*) '********************'
- write(IOUT,*)
- write(IOUT,*) 'reading receiver information from the DATA/STATIONS file'
- write(IOUT,*)
- endif
-
- open(unit=1,file='DATA/STATIONS_target',status='old',action='read')
-
-! allocate memory for arrays using number of stations
- allocate(final_distance(nrec))
-
-! loop on all the stations
- do irec=1,nrec
-
- ! set distance to huge initial value
- distmin=HUGEVAL
-
- read(1,*) station_name(irec),network_name(irec),st_xval(irec),st_zval(irec),stele,stbur
-
- ! check that station is not buried, burial is not implemented in current code
- if(abs(stbur) > TINYVAL) call exit_MPI('stations with non-zero burial not implemented yet')
-
- ! compute distance between source and receiver
- distance_receiver(irec) = sqrt((st_zval(irec)-z_source)**2 + (st_xval(irec)-x_source)**2)
-
- do ispec=1,nspec
-
- ! loop only on points inside the element
- ! exclude edges to ensure this point is not shared with other elements
- do j=2,NGLLZ-1
- do i=2,NGLLX-1
-
- iglob = ibool(i,j,ispec)
- dist = sqrt((st_xval(irec)-dble(coord(1,iglob)))**2 + (st_zval(irec)-dble(coord(2,iglob)))**2)
-
- ! keep this point if it is closer to the receiver
- if(dist < distmin) then
- distmin = dist
- ispec_selected_rec(irec) = ispec
- ix_initial_guess = i
- iz_initial_guess = j
- endif
-
- enddo
- enddo
-
- ! end of loop on all the spectral elements
- enddo
-
-
-! ****************************************
-! find the best (xi,gamma) for each receiver
-! ****************************************
-
- ! use initial guess in xi and gamma
- xi = xigll(ix_initial_guess)
- gamma = zigll(iz_initial_guess)
-
- ! iterate to solve the non linear system
- do iter_loop = 1,NUM_ITER
-
- ! recompute jacobian for the new point
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_rec(irec),ngnod,nspec,npgeo, &
- .true.)
-
- ! compute distance to target location
- dx = - (x - st_xval(irec))
- dz = - (z - st_zval(irec))
-
- ! compute increments
- dxi = xix*dx + xiz*dz
- dgamma = gammax*dx + gammaz*dz
-
- ! update values
- xi = xi + dxi
- gamma = gamma + dgamma
-
- ! impose that we stay in that element
- ! (useful if user gives a receiver outside the mesh for instance)
- ! we can go slightly outside the [1,1] segment since with finite elements
- ! the polynomial solution is defined everywhere
- ! this can be useful for convergence of itertive scheme with distorted elements
- if (xi > 1.10d0) xi = 1.10d0
- if (xi < -1.10d0) xi = -1.10d0
- if (gamma > 1.10d0) gamma = 1.10d0
- if (gamma < -1.10d0) gamma = -1.10d0
-
- ! end of non linear iterations
- enddo
-
- ! compute final coordinates of point found
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_rec(irec),ngnod,nspec,npgeo, &
- .true.)
-
- ! store xi,gamma of point found
- xi_receiver(irec) = xi
- gamma_receiver(irec) = gamma
-
- ! compute final distance between asked and found
- final_distance(irec) = sqrt((st_xval(irec)-x)**2 + (st_zval(irec)-z)**2)
-
- x_final_receiver(irec) = x
- z_final_receiver(irec) = z
-
- enddo
-
- ! close receiver file
- close(1)
-
-! elect one process for each receiver.
-#ifdef USE_MPI
- call MPI_GATHER(final_distance(1),nrec,MPI_DOUBLE_PRECISION,&
- gather_final_distance(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
- call MPI_GATHER(xi_receiver(1),nrec,MPI_DOUBLE_PRECISION,&
- gather_xi_receiver(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
- call MPI_GATHER(gamma_receiver(1),nrec,MPI_DOUBLE_PRECISION,&
- gather_gamma_receiver(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
- call MPI_GATHER(ispec_selected_rec(1),nrec,MPI_INTEGER,&
- gather_ispec_selected_rec(1,1),nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
-
- if ( myrank == 0 ) then
- do irec = 1, nrec
- which_proc_receiver(irec:irec) = minloc(gather_final_distance(irec,:)) - 1
- enddo
- endif
-
- call MPI_BCAST(which_proc_receiver(1),nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
-
-#else
-
- gather_final_distance(:,1) = final_distance(:)
-
- gather_xi_receiver(:,1) = xi_receiver(:)
- gather_gamma_receiver(:,1) = gamma_receiver(:)
- gather_ispec_selected_rec(:,1) = ispec_selected_rec(:)
-
- which_proc_receiver(:) = 0
-
-#endif
-
- nrecloc = 0
- do irec = 1, nrec
- if ( which_proc_receiver(irec) == myrank ) then
- nrecloc = nrecloc + 1
- recloc(nrecloc) = irec
- endif
- enddo
-
- if (myrank == 0 .and. ipass == 1) then
-
- do irec = 1, nrec
- write(IOUT,*)
- write(IOUT,*) 'Station # ',irec,' ',station_name(irec),network_name(irec)
-
- if(gather_final_distance(irec,which_proc_receiver(irec)+1) == HUGEVAL) &
- call exit_MPI('error locating receiver')
-
- write(IOUT,*) ' original x: ',sngl(st_xval(irec))
- write(IOUT,*) ' original z: ',sngl(st_zval(irec))
- write(IOUT,*) ' distance from source: ',sngl(distance_receiver(irec))
- write(IOUT,*) 'closest estimate found: ',sngl(gather_final_distance(irec,which_proc_receiver(irec)+1)), &
- ' m away'
- write(IOUT,*) ' in element ',gather_ispec_selected_rec(irec,which_proc_receiver(irec)+1)
- write(IOUT,*) ' at process ', which_proc_receiver(irec)
- write(IOUT,*) ' at xi,gamma coordinates = ',gather_xi_receiver(irec,which_proc_receiver(irec)+1),&
- gather_gamma_receiver(irec,which_proc_receiver(irec)+1)
- write(IOUT,*)
- enddo
-
- write(IOUT,*)
- write(IOUT,*) 'end of receiver detection'
- write(IOUT,*)
-
- ! write out actual station locations (compare with STATIONS_target from meshfem2D)
- ! NOTE: this will be written out even if generate_STATIONS = .false.
- open(unit=15,file='DATA/STATIONS',status='unknown')
- do irec = 1,nrec
- write(15,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") &
- irec,x_final_receiver(irec),z_final_receiver(irec)
- enddo
- close(15)
-
- endif
-
- ! deallocate arrays
- deallocate(final_distance)
-
-#ifdef USE_MPI
- call MPI_BARRIER(MPI_COMM_WORLD,ierror)
-#endif
-
- end subroutine locate_receivers
-
Deleted: seismo/2D/SPECFEM2D/trunk/locate_source_force.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_source_force.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/locate_source_force.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,257 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!----
-!---- locate_source_force finds the correct position of the point force source
-!----
-
- subroutine locate_source_force(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
- ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank, &
- xi_source,gamma_source,coorg,knods,ngnod,npgeo,ipass,iglob_source)
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer nspec,npoin,ngnod,npgeo,ipass
-
- integer knods(ngnod,nspec)
- double precision coorg(NDIM,npgeo)
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
-! array containing coordinates of the points
- double precision coord(NDIM,npoin)
-
- integer i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
-
- double precision x_source,z_source,dist
- double precision xi,gamma,dx,dz,dxi,dgamma
-
-! Gauss-Lobatto-Legendre points of integration
- double precision xigll(NGLLX)
- double precision zigll(NGLLZ)
-
- double precision x,z,xix,xiz,gammax,gammaz,jacobian
- double precision distmin,final_distance,dist_glob
-
-! source information
- integer ispec_selected_source,is_proc_source,nb_proc_source,iglob_source
- integer, intent(in) :: nproc, myrank
- double precision xi_source,gamma_source
-
-#ifdef USE_MPI
- integer, dimension(1:nproc) :: allgather_is_proc_source
- integer, dimension(1) :: locate_is_proc_source
- integer :: ierror
-#endif
-
-
-
-! **************
- if ((myrank == 0 .or. nproc == 1) .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) '*******************************'
- write(IOUT,*) ' locating force source'
- write(IOUT,*) '*******************************'
- write(IOUT,*)
- endif
-
-! set distance to huge initial value
- distmin = HUGEVAL
-
- is_proc_source = 0
-
- do ispec = 1,nspec
-
-! loop only on points inside the element
-! exclude edges to ensure this point is not shared with other elements
- do j = 2,NGLLZ-1
- do i = 2,NGLLX-1
-
- iglob = ibool(i,j,ispec)
- dist = sqrt((x_source-dble(coord(1,iglob)))**2 &
- + (z_source-dble(coord(2,iglob)))**2)
-
-! keep this point if it is closer to the source
- if(dist < distmin) then
- iglob_source = iglob
- distmin = dist
- ispec_selected_source = ispec
- ix_initial_guess = i
- iz_initial_guess = j
- endif
-
- enddo
- enddo
-
-! end of loop on all the spectral elements
- enddo
-
-#ifdef USE_MPI
- ! global minimum distance computed over all processes
- call MPI_ALLREDUCE (distmin, dist_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ierror)
-
-#else
- dist_glob = distmin
-
-#endif
-
-! check if this process contains the source
- if ( abs(dist_glob - distmin) < TINYVAL ) is_proc_source = 1
-
-#ifdef USE_MPI
- ! determining the number of processes that contain the source
- ! (useful when the source is located on an interface)
- call MPI_ALLREDUCE (is_proc_source, nb_proc_source, 1, MPI_INTEGER, &
- MPI_SUM, MPI_COMM_WORLD, ierror)
-
-#else
-
- nb_proc_source = is_proc_source
-
-#endif
-
-
-#ifdef USE_MPI
- ! when several processes contain the source, we elect one of them (minimum rank).
- if ( nb_proc_source > 1 ) then
-
- call MPI_ALLGATHER(is_proc_source, 1, MPI_INTEGER, allgather_is_proc_source(1), &
- 1, MPI_INTEGER, MPI_COMM_WORLD, ierror)
- locate_is_proc_source = maxloc(allgather_is_proc_source) - 1
-
- if ( myrank /= locate_is_proc_source(1) ) then
- is_proc_source = 0
- endif
- nb_proc_source = 1
-
- endif
-
-#endif
-
-! ****************************************
-! find the best (xi,gamma) for each source
-! ****************************************
-
-! use initial guess in xi and gamma
- xi = xigll(ix_initial_guess)
- gamma = zigll(iz_initial_guess)
-
-! iterate to solve the non linear system
- do iter_loop = 1,NUM_ITER
-
-! recompute jacobian for the new point
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
- .true.)
-
-! compute distance to target location
- dx = - (x - x_source)
- dz = - (z - z_source)
-
-! compute increments
- dxi = xix*dx + xiz*dz
- dgamma = gammax*dx + gammaz*dz
-
-! update values
- xi = xi + dxi
- gamma = gamma + dgamma
-
-! impose that we stay in that element
-! (useful if user gives a source outside the mesh for instance)
-! we can go slightly outside the [1,1] segment since with finite elements
-! the polynomial solution is defined everywhere
-! this can be useful for convergence of itertive scheme with distorted elements
- if (xi > 1.10d0) xi = 1.10d0
- if (xi < -1.10d0) xi = -1.10d0
- if (gamma > 1.10d0) gamma = 1.10d0
- if (gamma < -1.10d0) gamma = -1.10d0
-
-! end of non linear iterations
- enddo
-
-! compute final coordinates of point found
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
- .true.)
-
-! store xi,gamma of point found
- xi_source = xi
- gamma_source = gamma
-
-! compute final distance between asked and found
- final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
-
- if (is_proc_source == 1 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Force source:'
-
- if(final_distance == HUGEVAL) call exit_MPI('error locating force source')
-
- write(IOUT,*) ' original x: ',sngl(x_source)
- write(IOUT,*) ' original z: ',sngl(z_source)
- write(IOUT,*) 'closest estimate found: ',sngl(final_distance),' m away'
-#ifdef USE_MPI
- write(IOUT,*) ' in rank ',myrank
-#endif
- write(IOUT,*) ' in element ',ispec_selected_source
- write(IOUT,*) ' at xi,gamma coordinates = ',xi_source,gamma_source
- write(IOUT,*)
-
- write(IOUT,*)
- write(IOUT,*) 'end of force source detection'
- write(IOUT,*)
- endif
-
-#ifdef USE_MPI
- call MPI_BARRIER(MPI_COMM_WORLD,ierror)
-#endif
-
- end subroutine locate_source_force
-
Deleted: seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,256 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!----
-!---- locate_source_moment_tensor finds the correct position of the moment-tensor source
-!----
-
- subroutine locate_source_moment_tensor(ibool,coord,nspec,npoin, &
- xigll,zigll,x_source,z_source, &
- ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank, &
- xi_source,gamma_source,coorg,knods,ngnod,npgeo,ipass)
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer nspec,npoin,ngnod,npgeo,ipass
-
- integer knods(ngnod,nspec)
- double precision coorg(NDIM,npgeo)
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
-! array containing coordinates of the points
- double precision coord(NDIM,npoin)
-
- integer i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
-
- double precision x_source,z_source,dist
- double precision xi,gamma,dx,dz,dxi,dgamma
-
-! Gauss-Lobatto-Legendre points of integration
- double precision xigll(NGLLX)
- double precision zigll(NGLLZ)
-
- double precision x,z,xix,xiz,gammax,gammaz,jacobian
- double precision distmin,final_distance,dist_glob
-
-! source information
- integer ispec_selected_source,is_proc_source,nb_proc_source
- integer, intent(in) :: nproc, myrank
- double precision xi_source,gamma_source
-
-#ifdef USE_MPI
- integer, dimension(1:nproc) :: allgather_is_proc_source
- integer, dimension(1) :: locate_is_proc_source
- integer :: ierror
-#endif
-
-
-
-! **************
- if ((myrank == 0 .or. nproc == 1) .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) '*******************************'
- write(IOUT,*) ' locating moment-tensor source'
- write(IOUT,*) '*******************************'
- write(IOUT,*)
- endif
-
-! set distance to huge initial value
- distmin = HUGEVAL
-
- is_proc_source = 0
-
- do ispec = 1,nspec
-
-! loop only on points inside the element
-! exclude edges to ensure this point is not shared with other elements
- do j = 2,NGLLZ-1
- do i = 2,NGLLX-1
-
- iglob = ibool(i,j,ispec)
- dist = sqrt((x_source-dble(coord(1,iglob)))**2 &
- + (z_source-dble(coord(2,iglob)))**2)
-
-! keep this point if it is closer to the source
- if(dist < distmin) then
- distmin = dist
- ispec_selected_source = ispec
- ix_initial_guess = i
- iz_initial_guess = j
- endif
-
- enddo
- enddo
-
-! end of loop on all the spectral elements
- enddo
-
-#ifdef USE_MPI
- ! global minimum distance computed over all processes
- call MPI_ALLREDUCE (distmin, dist_glob, 1, MPI_DOUBLE_PRECISION, &
- MPI_MIN, MPI_COMM_WORLD, ierror)
-
-#else
- dist_glob = distmin
-
-#endif
-
-! check if this process contains the source
- if ( dist_glob == distmin ) is_proc_source = 1
-
-#ifdef USE_MPI
- ! determining the number of processes that contain the source
- ! (useful when the source is located on an interface)
- call MPI_ALLREDUCE (is_proc_source, nb_proc_source, 1, MPI_INTEGER, &
- MPI_SUM, MPI_COMM_WORLD, ierror)
-
-#else
- nb_proc_source = is_proc_source
-
-#endif
-
-
-#ifdef USE_MPI
- ! when several processes contain the source, we elect one of them (minimum rank).
- if ( nb_proc_source > 1 ) then
-
- call MPI_ALLGATHER(is_proc_source, 1, MPI_INTEGER, allgather_is_proc_source(1), &
- 1, MPI_INTEGER, MPI_COMM_WORLD, ierror)
- locate_is_proc_source = maxloc(allgather_is_proc_source) - 1
-
- if ( myrank /= locate_is_proc_source(1) ) then
- is_proc_source = 0
- endif
- nb_proc_source = 1
-
- endif
-
-#endif
-
-! ****************************************
-! find the best (xi,gamma) for each source
-! ****************************************
-
-! use initial guess in xi and gamma
- xi = xigll(ix_initial_guess)
- gamma = zigll(iz_initial_guess)
-
-! iterate to solve the non linear system
- do iter_loop = 1,NUM_ITER
-
-! recompute jacobian for the new point
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
- .true.)
-
-! compute distance to target location
- dx = - (x - x_source)
- dz = - (z - z_source)
-
-! compute increments
- dxi = xix*dx + xiz*dz
- dgamma = gammax*dx + gammaz*dz
-
-! update values
- xi = xi + dxi
- gamma = gamma + dgamma
-
-! impose that we stay in that element
-! (useful if user gives a source outside the mesh for instance)
-! we can go slightly outside the [1,1] segment since with finite elements
-! the polynomial solution is defined everywhere
-! this can be useful for convergence of itertive scheme with distorted elements
- if (xi > 1.10d0) xi = 1.10d0
- if (xi < -1.10d0) xi = -1.10d0
- if (gamma > 1.10d0) gamma = 1.10d0
- if (gamma < -1.10d0) gamma = -1.10d0
-
-! end of non linear iterations
- enddo
-
-! compute final coordinates of point found
- call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
- coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
- .true.)
-
-! store xi,gamma of point found
- xi_source = xi
- gamma_source = gamma
-
-! compute final distance between asked and found
- final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
-
- if (is_proc_source == 1 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Moment-tensor source:'
-
- if(final_distance == HUGEVAL) call exit_MPI('error locating moment-tensor source')
-
- write(IOUT,*) ' original x: ',sngl(x_source)
- write(IOUT,*) ' original z: ',sngl(z_source)
- write(IOUT,*) 'closest estimate found: ',sngl(final_distance),' m away'
-#ifdef USE_MPI
- write(IOUT,*) ' in rank ',myrank
-#endif
- write(IOUT,*) ' in element ',ispec_selected_source
- write(IOUT,*) ' at xi,gamma coordinates = ',xi_source,gamma_source
- write(IOUT,*)
-
- write(IOUT,*)
- write(IOUT,*) 'end of moment-tensor source detection'
- write(IOUT,*)
- endif
-
-#ifdef USE_MPI
- call MPI_BARRIER(MPI_COMM_WORLD,ierror)
-#endif
-
- end subroutine locate_source_moment_tensor
-
Deleted: seismo/2D/SPECFEM2D/trunk/meshfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/meshfem2D.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/meshfem2D.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,942 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!========================================================================
-!
-! Basic mesh generator for SPECFEM2D
-!
-!========================================================================
-
-! If you use this code for your own research, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{VaCaSaKoVi99,
-! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
-! D. Komatitsch and J. P. Vilotte},
-! title = {Elastic wave propagation in an irregularly layered medium},
-! journal = {Soil Dynamics and Earthquake Engineering},
-! year = {1999},
-! volume = {18},
-! pages = {11-18},
-! number = {1},
-! doi = {10.1016/S0267-7261(98)00027-X}}
-!
-! @ARTICLE{LeChKoHuTr09,
-! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
-! Shouh Huang and Jeroen Tromp},
-! title = {Effects of realistic surface topography on seismic ground motion
-! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
-! method and {LiDAR DTM}},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {681-693},
-! number = {2A},
-! doi = {10.1785/0120080264}}
-!
-! @ARTICLE{LeChLiKoHuTr08,
-! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
-! and Bor Shouh Huang and Jeroen Tromp},
-! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
-! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2008},
-! volume = {98},
-! pages = {253-264},
-! number = {1},
-! doi = {10.1785/0120070033}}
-!
-! @ARTICLE{LeKoHuTr09,
-! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
-! title = {Effects of topography on seismic wave propagation: An example from
-! northern {T}aiwan},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {314-325},
-! number = {1},
-! doi = {10.1785/0120080020}}
-!
-! @ARTICLE{KoErGoMi10,
-! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
-! David Mich\'ea},
-! title = {High-order finite-element seismic wave propagation modeling with
-! {MPI} on a large {GPU} cluster},
-! journal = {J. Comput. Phys.},
-! year = {2010},
-! volume = {229},
-! pages = {7692-7714},
-! number = {20},
-! doi = {10.1016/j.jcp.2010.06.024}}
-!
-! @ARTICLE{KoGoErMi10,
-! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
-! David Mich\'ea},
-! title = {Modeling the propagation of elastic waves using spectral elements
-! on a cluster of 192 {GPU}s},
-! journal = {Computer Science Research and Development},
-! year = {2010},
-! volume = {25},
-! pages = {75-82},
-! number = {1-2},
-! doi = {10.1007/s00450-010-0109-1}}
-!
-! @ARTICLE{KoMiEr09,
-! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
-! title = {Porting a high-order finite-element earthquake modeling application
-! to {NVIDIA} graphics cards using {CUDA}},
-! journal = {Journal of Parallel and Distributed Computing},
-! year = {2009},
-! volume = {69},
-! pages = {451-460},
-! number = {5},
-! doi = {10.1016/j.jpdc.2009.01.006}}
-!
-! @ARTICLE{LiPoKoTr04,
-! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
-! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
-! journal={Bull. Seismol. Soc. Am.},
-! year = {2004},
-! volume = {94},
-! pages = {1748-1761},
-! number = {5},
-! doi = {10.1785/012004038}}
-!
-! @INCOLLECTION{ChKoViCaVaFe07,
-! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
-! Yann Capdeville and Bernard Valette and Gaetano Festa},
-! title = {Spectral Element Analysis in Seismology},
-! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
-! publisher = {Elsevier - Academic Press},
-! year = {2007},
-! editor = {Ru-Shan Wu and Val\'erie Maupin},
-! volume = {48},
-! series = {Advances in Geophysics},
-! pages = {365-419}}
-!
-! @ARTICLE{KoVi98,
-! author={D. Komatitsch and J. P. Vilotte},
-! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
-! journal={Bull. Seismol. Soc. Am.},
-! year=1998,
-! volume=88,
-! number=2,
-! pages={368-392}}
-!
-! @ARTICLE{KoTr99,
-! author={D. Komatitsch and J. Tromp},
-! year=1999,
-! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
-! journal={Geophys. J. Int.},
-! volume=139,
-! number=3,
-! pages={806-822},
-! doi={10.1046/j.1365-246x.1999.00967.x}}
-!
-! @ARTICLE{KoLiTrSuStSh04,
-! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
-! and Christiane Stidham and John H. Shaw},
-! year=2004,
-! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
-! based upon the Spectral-Element Method},
-! journal={Bull. Seism. Soc. Am.},
-! volume=94,
-! number=1,
-! pages={187-206}}
-!
-! @ARTICLE{MoTr08,
-! author={C. Morency and J. Tromp},
-! title={Spectral-element simulations of wave propagation in poroelastic media},
-! journal={Geophys. J. Int.},
-! year=2008,
-! volume=175,
-! pages={301-345}}
-!
-! and/or other articles from http://web.univ-pau.fr/~dkomati1/publications.html
-!
-! If you use the kernel capabilities of the code, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{LiTr06,
-! author={Qinya Liu and Jeroen Tromp},
-! title={Finite-frequency kernels based on adjoint methods},
-! journal={Bull. Seismol. Soc. Am.},
-! year=2006,
-! volume=96,
-! number=6,
-! pages={2383-2397},
-! doi={10.1785/0120060041}}
-!
-! @ARTICLE{MoLuTr09,
-! author={C. Morency and Y. Luo and J. Tromp},
-! title={Finite-frequency kernels for wave propagation in porous media based upon adjoint methods},
-! year=2009,
-! journal={Geophys. J. Int.},
-! doi={10.1111/j.1365-246X.2009.04332}}
-!
-! If you use the METIS / SCOTCH / CUBIT non-structured capabilities, please also cite:
-!
-! @ARTICLE{MaKoBlLe08,
-! author = {R. Martin and D. Komatitsch and C. Blitz and N. {Le Goff}},
-! title = {Simulation of seismic wave propagation in an asteroid based upon
-! an unstructured {MPI} spectral-element method: blocking and non-blocking
-! communication strategies},
-! journal = {Lecture Notes in Computer Science},
-! year = {2008},
-! volume = {5336},
-! pages = {350-363}}
-!
-! version 6.1, Christina Morency and Pieyre Le Loher, March 2010:
-! - added SH (membrane) waves calculation for elastic media
-! - added support for external fully anisotropic media
-! - fixed some bugs in acoustic kernels
-!
-! version 6.0, Christina Morency and Yang Luo, August 2009:
-! - support for poroelastic media
-! - adjoint method for acoustic/elastic/poroelastic
-!
-! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, February 2008:
-! - support for CUBIT and GiD meshes
-! - MPI implementation of the code based on domain decomposition
-! with METIS or SCOTCH
-! - general fluid/solid implementation with any number, shape and orientation of
-! matching edges
-! - fluid potential of density * displacement instead of displacement
-! - absorbing edges with any normal vector
-! - general numbering of absorbing and acoustic free surface edges
-! - cleaned implementation of attenuation as in Carcione (1993)
-! - merged loops in the solver for efficiency
-! - simplified input of external model
-! - added CPU time information
-! - translated many comments from French to English
-!
-! version 5.1, Dimitri Komatitsch, January 2005:
-! - more general mesher with any number of curved layers
-! - Dirac and Gaussian time sources and corresponding convolution routine
-! - option for acoustic medium instead of elastic
-! - receivers at any location, not only grid points
-! - moment-tensor source at any location, not only a grid point
-! - color snapshots
-! - more flexible DATA/Par_file with any number of comment lines
-! - Xsu scripts for seismograms
-! - subtract t0 from seismograms
-! - seismograms and snapshots in pressure in addition to vector field
-!
-! version 5.0, Dimitri Komatitsch, May 2004:
-! - got rid of useless routines, suppressed commons etc.
-! - weak formulation based explicitly on stress tensor
-! - implementation of full anisotropy
-! - implementation of attenuation based on memory variables
-!
-! based on SPECFEM2D version 4.2, June 1998
-! (c) by Dimitri Komatitsch, Harvard University, USA
-! and Jean-Pierre Vilotte, Institut de Physique du Globe de Paris, France
-!
-! itself based on SPECFEM2D version 1.0, 1995
-! (c) by Dimitri Komatitsch and Jean-Pierre Vilotte,
-! Institut de Physique du Globe de Paris, France
-!
-
-! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
-! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
-! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
-! This permits acoustic-elastic coupling based on a non-iterative time scheme.
-! Displacement is then: u = grad(Chi) / rho
-! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
-! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
-! The source in an acoustic element is a pressure source.
-! First-order acoustic-acoustic discontinuities are also handled automatically
-! because pressure is continuous at such an interface, therefore Chi_dot_dot
-! is continuous, therefore Chi is also continuous, which is consistent with
-! the spectral-element basis functions and with the assembling process.
-! This is the reason why a simple displacement potential u = grad(Chi) would
-! not work because it would be discontinuous at such an interface and would
-! therefore not be consistent with the basis functions.
-
-program meshfem2D
-
- use part_unstruct
- use parameter_file
- use source_file
- use interfaces_file
- implicit none
-
- include "constants.h"
-
- ! coordinates of the grid points of the mesh
- double precision, dimension(:,:), allocatable :: x,z
-
- ! to compute the coordinate transformation
- integer :: ioffset
- double precision :: gamma,absx,a00,a01,bot0,top0
-
- ! to store density and velocity model
- integer, dimension(:), allocatable :: num_material
-
- ! interface data
- integer :: max_npoints_interface,number_of_interfaces,npoints_interface_bottom, &
- npoints_interface_top
- integer :: number_of_layers
- integer :: nz,nxread,nzread
-
- integer :: ilayer,ipoint_current
- integer, dimension(:), pointer :: nz_layer
- double precision, dimension(:), allocatable :: &
- xinterface_bottom,zinterface_bottom,coefs_interface_bottom, &
- xinterface_top,zinterface_top,coefs_interface_top
-
- integer :: nspec
- integer :: nbregion
-
- ! external functions
- integer, external :: num_4, num_9
- double precision, external :: value_spline
-
- ! variables used for storing info about the mesh and partitions
- integer, dimension(:), allocatable :: my_interfaces
- integer, dimension(:), allocatable :: my_nb_interfaces
-
- integer :: num_start
- integer :: num_node
-
- ! variables used for tangential detection
- integer :: nnodes_tangential_curve
- double precision, dimension(:,:), allocatable :: nodes_tangential_curve
-
-#ifdef USE_SCOTCH
- integer :: edgecut
-#endif
-
- integer :: iproc
- integer :: ix,iz,i,j
- integer :: imaterial_number,inumelem
- integer :: i_source,ios
- double precision :: tang1,tangN
-
- ! ***
- ! *** read the parameter file
- ! ***
-
- print *,'Reading the parameter file ... '
- print *
-
- open(unit=IIN,file='DATA/Par_file',status='old',iostat=ios)
- if( ios /= 0 ) stop 'error opening DATA/Par_file file'
-
- ! reads in parameters in DATA/Par_file
- call read_parameter_file()
-
- ! reads in mesh elements
- if ( read_external_mesh ) then
- call read_external_mesh_file(mesh_file, num_start, ngnod)
-
- else
- call read_interfaces_file(interfacesfile,max_npoints_interface, &
- number_of_interfaces,npoints_interface_bottom, &
- number_of_layers,nz_layer,nx,nz,nxread,nzread,ngnod, &
- nelmnts,elmnts)
- endif
-
- allocate(num_material(nelmnts))
- num_material(:) = 0
-
- ! assigns materials to mesh elements
- if ( read_external_mesh ) then
- call read_mat(materials_file, num_material)
- else
- call read_regions(nbregion,nb_materials,icodemat,cp,cs, &
- rho_s,Qp,Qs,aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
- nelmnts,num_material,nxread,nzread)
- endif
-
- close(IIN)
-
- print *
- print *,'Parameter file successfully read... '
-
- ! reads in source descriptions
- call read_source_file(NSOURCES)
-
- ! reads in tangential detection
- if (force_normal_to_surface .or. rec_normal_to_surface) then
- open(unit=IIN,file=tangential_detection_curve_file,status='old',action='read')
- read(IIN,*) nnodes_tangential_curve
- allocate(nodes_tangential_curve(2,nnodes_tangential_curve))
- do i = 1, nnodes_tangential_curve
- read(IIN,*) nodes_tangential_curve(1,i), nodes_tangential_curve(2,i)
- enddo
- close(IIN)
- else
- nnodes_tangential_curve = 1 ! dummy values instead of 0
- allocate(nodes_tangential_curve(2,1))
- endif
-
-
- !---
-
- if(ngnod /= 4 .and. ngnod /= 9) stop 'ngnod different from 4 or 9!'
-
- print *
- print *,'The mesh contains ',nelmnts,' elements'
- print *
- print *,'Control elements have ',ngnod,' nodes'
- print *
-
- !---
-
- if ( .not. read_external_mesh ) then
- ! allocate arrays for the grid
- allocate(x(0:nx,0:nz))
- allocate(z(0:nx,0:nz))
-
- x(:,:) = 0.d0
- z(:,:) = 0.d0
-
- ! get interface data from external file
- print *,'Reading interface data from file DATA/',interfacesfile(1:len_trim(interfacesfile))
- open(unit=IIN_INTERFACES,file='DATA/'//interfacesfile,status='old')
-
- allocate(xinterface_bottom(max_npoints_interface))
- allocate(zinterface_bottom(max_npoints_interface))
- allocate(coefs_interface_bottom(max_npoints_interface))
-
- allocate(xinterface_top(max_npoints_interface))
- allocate(zinterface_top(max_npoints_interface))
- allocate(coefs_interface_top(max_npoints_interface))
-
- ! read number of interfaces
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,number_of_interfaces)
-
- ! read bottom interface
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_bottom)
-
- ! loop on all the points describing this interface
- do ipoint_current = 1,npoints_interface_bottom
- call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
- xinterface_bottom(ipoint_current),zinterface_bottom(ipoint_current))
- enddo
-
- ! loop on all the layers
- do ilayer = 1,number_of_layers
-
- ! read top interface
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_top)
-
- ! loop on all the points describing this interface
- do ipoint_current = 1,npoints_interface_top
- call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
- xinterface_top(ipoint_current),zinterface_top(ipoint_current))
- enddo
-
- ! compute the spline for the bottom interface, impose the tangent on both edges
- tang1 = (zinterface_bottom(2)-zinterface_bottom(1)) / (xinterface_bottom(2)-xinterface_bottom(1))
- tangN = (zinterface_bottom(npoints_interface_bottom)-zinterface_bottom(npoints_interface_bottom-1)) / &
- (xinterface_bottom(npoints_interface_bottom)-xinterface_bottom(npoints_interface_bottom-1))
- call spline_construction(xinterface_bottom,zinterface_bottom,npoints_interface_bottom,tang1,tangN,coefs_interface_bottom)
-
- ! compute the spline for the top interface, impose the tangent on both edges
- tang1 = (zinterface_top(2)-zinterface_top(1)) / (xinterface_top(2)-xinterface_top(1))
- tangN = (zinterface_top(npoints_interface_top)-zinterface_top(npoints_interface_top-1)) / &
- (xinterface_top(npoints_interface_top)-xinterface_top(npoints_interface_top-1))
- call spline_construction(xinterface_top,zinterface_top,npoints_interface_top,tang1,tangN,coefs_interface_top)
-
- ! check if we are in the last layer, which contains topography,
- ! and modify the position of the source accordingly if it is located exactly at the surface
- do i_source=1,NSOURCES
- if(source_surf(i_source) .and. ilayer == number_of_layers) &
- zs(i_source) = value_spline(xs(i_source),xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
- enddo
-
- ! compute the offset of this layer in terms of number of spectral elements below along Z
- if(ilayer > 1) then
- ioffset = sum(nz_layer(1:ilayer-1))
- else
- ioffset = 0
- endif
-
- !--- definition of the mesh
-
- do ix = 0,nx
-
- ! evenly spaced points along X
- absx = xmin + (xmax - xmin) * dble(ix) / dble(nx)
-
- ! value of the bottom and top splines
- bot0 = value_spline(absx,xinterface_bottom,zinterface_bottom,coefs_interface_bottom,npoints_interface_bottom)
- top0 = value_spline(absx,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
-
- do iz = 0,nz_layer(ilayer)
-
- ! linear interpolation between bottom and top
- gamma = dble(iz) / dble(nz_layer(ilayer))
- a00 = 1.d0 - gamma
- a01 = gamma
-
- ! coordinates of the grid points
- x(ix,iz + ioffset) = absx
- z(ix,iz + ioffset) = a00*bot0 + a01*top0
-
- enddo
-
- enddo
-
- ! the top interface becomes the bottom interface before switching to the next layer
- npoints_interface_bottom = npoints_interface_top
- xinterface_bottom(:) = xinterface_top(:)
- zinterface_bottom(:) = zinterface_top(:)
-
- enddo
-
- close(IIN_INTERFACES)
-
- nnodes = (nz+1)*(nx+1)
- allocate(nodes_coords(2,nnodes))
- if ( ngnod == 4 ) then
- do j = 0, nz
- do i = 0, nx
- num_node = num_4(i,j,nxread)
- nodes_coords(1, num_node) = x(i,j)
- nodes_coords(2, num_node) = z(i,j)
-
- enddo
- enddo
-
- else
- do j = 0, nz
- do i = 0, nx
- num_node = num_9(i,j,nxread,nzread)
- nodes_coords(1, num_node) = x(i,j)
- nodes_coords(2, num_node) = z(i,j)
- enddo
- enddo
-
- endif
- else
- call read_nodes_coords(nodes_coords_file)
- endif
-
-
- if ( read_external_mesh ) then
- call read_acoustic_surface(free_surface_file, num_material, &
- ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
-
- if ( any_abs ) then
- call read_abs_surface(absorbing_surface_file, num_start)
- endif
-
- else
-
- ! count the number of acoustic free-surface elements
- nelem_acoustic_surface = 0
-
- ! if the surface is absorbing, it cannot be free at the same time
- if(.not. abstop) then
- j = nzread
- do i = 1,nxread
- imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- endif
- enddo
- endif
- if(.not. absbottom) then
- j = 1
- do i = 1,nxread
- imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- endif
- enddo
- endif
- if(.not. absleft) then
- i = 1
- do j = 1,nzread
- imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- endif
- enddo
- endif
- if(.not. absright) then
- i = nxread
- do j = 1,nzread
- imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- endif
- enddo
- endif
-
-
- allocate(acoustic_surface(4,nelem_acoustic_surface))
-
- nelem_acoustic_surface = 0
-
- if(.not. abstop) then
- j = nzread
- do i = 1,nxread
- imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >=1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- acoustic_surface(1,nelem_acoustic_surface) = (j-1)*nxread + (i-1)
- acoustic_surface(2,nelem_acoustic_surface) = 2
- acoustic_surface(3,nelem_acoustic_surface) = elmnts(3+ngnod*((j-1)*nxread+i-1))
- acoustic_surface(4,nelem_acoustic_surface) = elmnts(2+ngnod*((j-1)*nxread+i-1))
- endif
- enddo
- endif
- if(.not. absbottom) then
- j = 1
- do i = 1,nxread
- imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >=1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- acoustic_surface(1,nelem_acoustic_surface) = (j-1)*nxread + (i-1)
- acoustic_surface(2,nelem_acoustic_surface) = 2
- acoustic_surface(3,nelem_acoustic_surface) = elmnts(0+ngnod*((j-1)*nxread+i-1))
- acoustic_surface(4,nelem_acoustic_surface) = elmnts(1+ngnod*((j-1)*nxread+i-1))
- endif
- enddo
- endif
- if(.not. absleft) then
- i = 1
- do j = 1,nzread
- imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >=1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- acoustic_surface(1,nelem_acoustic_surface) = (j-1)*nxread + (i-1)
- acoustic_surface(2,nelem_acoustic_surface) = 2
- acoustic_surface(3,nelem_acoustic_surface) = elmnts(0+ngnod*((j-1)*nxread+i-1))
- acoustic_surface(4,nelem_acoustic_surface) = elmnts(3+ngnod*((j-1)*nxread+i-1))
- endif
- enddo
- endif
- if(.not. absright) then
- i = nxread
- do j = 1,nzread
- imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >=1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- acoustic_surface(1,nelem_acoustic_surface) = (j-1)*nxread + (i-1)
- acoustic_surface(2,nelem_acoustic_surface) = 2
- acoustic_surface(3,nelem_acoustic_surface) = elmnts(1+ngnod*((j-1)*nxread+i-1))
- acoustic_surface(4,nelem_acoustic_surface) = elmnts(2+ngnod*((j-1)*nxread+i-1))
- endif
- enddo
- endif
-
- !
- !--- definition of absorbing boundaries
- !
- nelemabs = 0
- if(absbottom) nelemabs = nelemabs + nxread
- if(abstop) nelemabs = nelemabs + nxread
- if(absleft) nelemabs = nelemabs + nzread
- if(absright) nelemabs = nelemabs + nzread
-
- allocate(abs_surface(4,nelemabs))
-
- ! generate the list of absorbing elements
- if(nelemabs > 0) then
- nelemabs = 0
- do iz = 1,nzread
- do ix = 1,nxread
- inumelem = (iz-1)*nxread + ix
- if(absbottom .and. iz == 1) then
- nelemabs = nelemabs + 1
- abs_surface(1,nelemabs) = inumelem-1
- abs_surface(2,nelemabs) = 2
- abs_surface(3,nelemabs) = elmnts(0+ngnod*(inumelem-1))
- abs_surface(4,nelemabs) = elmnts(1+ngnod*(inumelem-1))
- endif
- if(absright .and. ix == nxread) then
- nelemabs = nelemabs + 1
- abs_surface(1,nelemabs) = inumelem-1
- abs_surface(2,nelemabs) = 2
- abs_surface(3,nelemabs) = elmnts(1+ngnod*(inumelem-1))
- abs_surface(4,nelemabs) = elmnts(2+ngnod*(inumelem-1))
- endif
- if(abstop .and. iz == nzread) then
- nelemabs = nelemabs + 1
- abs_surface(1,nelemabs) = inumelem-1
- abs_surface(2,nelemabs) = 2
- abs_surface(3,nelemabs) = elmnts(3+ngnod*(inumelem-1))
- abs_surface(4,nelemabs) = elmnts(2+ngnod*(inumelem-1))
- endif
- if(absleft .and. ix == 1) then
- nelemabs = nelemabs + 1
- abs_surface(1,nelemabs) = inumelem-1
- abs_surface(2,nelemabs) = 2
- abs_surface(3,nelemabs) = elmnts(0+ngnod*(inumelem-1))
- abs_surface(4,nelemabs) = elmnts(3+ngnod*(inumelem-1))
- endif
- enddo
- enddo
- endif
-
- endif
-
-
- ! compute min and max of X and Z in the grid
- print *
- print *,'Min and max value of X in the grid = ',minval(nodes_coords(1,:)),maxval(nodes_coords(1,:))
- print *,'Min and max value of Z in the grid = ',minval(nodes_coords(2,:)),maxval(nodes_coords(2,:))
- print *
-
-
- ! ***
- ! *** create a Gnuplot file that displays the grid
- ! ***
- if ( .not. read_external_mesh ) then
- call save_gnuplot_file(ngnod,nx,nz,x,z)
- endif
-
-
- !*****************************
- ! partitioning
- !*****************************
-
- ! allocates & initializes partioning of elements
- allocate(part(0:nelmnts-1))
- part(:) = -1
-
- if( nproc > 1 ) then
- allocate(xadj_g(0:nelmnts))
- allocate(adjncy_g(0:MAX_NEIGHBORS*nelmnts-1))
- xadj_g(:) = 0
- adjncy_g(:) = -1
- endif
-
- ! construction of the graph
-
- ! if ngnod == 9, we work on a subarray of elements that represents the elements with four nodes (four corners) only
- ! because the adjacency of the mesh elements can be entirely determined from the knowledge of the four corners only
- if ( ngnod == 9 ) then
- allocate(elmnts_bis(0:NCORNERS*nelmnts-1))
- do i = 0, nelmnts-1
- elmnts_bis(i*NCORNERS:i*NCORNERS+NCORNERS-1) = elmnts(i*ngnod:i*ngnod+NCORNERS-1)
- enddo
-
- if ( nproc > 1 ) then
-
-!! DK DK fixed problem in the previous implementation by Nicolas Le Goff:
-!! DK DK (nxread+1)*(nzread+1) is OK for a regular internal mesh only, not for non structured external meshes
-!! DK DK call mesh2dual_ncommonnodes(nelmnts, (nxread+1)*(nzread+1), elmnts_bis, xadj, adjncy, nnodes_elmnts, nodes_elmnts,1)
-!! DK DK the subset of element corners is not renumbered therefore we must still use the nnodes computed for 9 nodes here
- ! determines maximum neighbors based on 1 common node
- call mesh2dual_ncommonnodes(elmnts_bis,1,xadj_g,adjncy_g)
- endif
-
- else
- if ( nproc > 1 ) then
- ! determines maximum neighbors based on 1 common node
- call mesh2dual_ncommonnodes(elmnts,1,xadj_g,adjncy_g)
- endif
-
- endif
-
-
- if ( nproc == 1 ) then
- part(:) = 0 ! single process has rank 0
- else
-
- ! number of common edges
- nb_edges = xadj_g(nelmnts)
-
- ! giving weight to edges and vertices. Currently not used.
- call read_weights()
-
- ! partitioning
- select case (partitioning_method)
-
- case(1)
-
- do iproc = 0, nproc-2
- part(iproc*floor(real(nelmnts)/real(nproc)):(iproc+1)*floor(real(nelmnts)/real(nproc))-1) = iproc
- enddo
- part(floor(real(nelmnts)/real(nproc))*(nproc-1):nelmnts-1) = nproc - 1
-
- case(2)
-
-!#ifdef USE_METIS
-! call Part_metis(nelmnts, xadj, adjncy, vwgt, adjwgt, nproc, nb_edges, edgecut, part, metis_options)
-!#else
-! print *, 'This version of SPECFEM was not compiled with support of METIS.'
-! print *, 'Please recompile with -DUSE_METIS in order to enable use of METIS.'
-! stop
-!#endif
- stop 'support for the METIS graph partitioner has been discontinued, please use SCOTCH (option 3) instead'
-
- case(3)
-
-#ifdef USE_SCOTCH
- call Part_scotch(nproc, edgecut)
-#else
- print *, 'This version of SPECFEM was not compiled with support of SCOTCH.'
- print *, 'Please recompile with -DUSE_SCOTCH in order to enable use of SCOTCH.'
- stop
-#endif
-
- end select
-
- endif
-
- ! beware of fluid solid edges : coupled elements are transfered to the same partition
- if ( ngnod == 9 ) then
- call acoustic_elastic_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
- else
- call acoustic_elastic_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
- endif
- ! beware of fluid porous edges : coupled elements are transfered to the same partition
- if ( ngnod == 9 ) then
- call acoustic_poro_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
- else
- call acoustic_poro_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
- endif
- ! beware of porous solid edges : coupled elements are transfered to the same partition
- if ( ngnod == 9 ) then
- call poro_elastic_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
- else
- call poro_elastic_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
- endif
-
- ! local number of each element for each partition
- call Construct_glob2loc_elmnts(nproc)
-
- if ( ngnod == 9 ) then
- if( allocated(nnodes_elmnts) ) deallocate(nnodes_elmnts)
- if( allocated(nodes_elmnts) ) deallocate(nodes_elmnts)
- allocate(nnodes_elmnts(0:nnodes-1))
- allocate(nodes_elmnts(0:nsize*nnodes-1))
- nnodes_elmnts(:) = 0
- nodes_elmnts(:) = 0
- do i = 0, ngnod*nelmnts-1
- nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
- nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
- enddo
- else
- if ( nproc < 2 ) then
- if( .not. allocated(nnodes_elmnts) ) allocate(nnodes_elmnts(0:nnodes-1))
- if( .not. allocated(nodes_elmnts) ) allocate(nodes_elmnts(0:nsize*nnodes-1))
- nnodes_elmnts(:) = 0
- nodes_elmnts(:) = 0
- do i = 0, ngnod*nelmnts-1
- nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
- nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
- enddo
- endif
- endif
-
- ! local number of each node for each partition
- call Construct_glob2loc_nodes(nproc)
-
- ! construct the interfaces between partitions (used for MPI assembly)
- if ( nproc /= 1 ) then
- if ( ngnod == 9 ) then
- call Construct_interfaces(nproc, elmnts_bis, &
- nb_materials, phi, num_material)
- else
- call Construct_interfaces(nproc, elmnts, &
- nb_materials, phi, num_material)
- endif
- allocate(my_interfaces(0:ninterfaces-1))
- allocate(my_nb_interfaces(0:ninterfaces-1))
- endif
-
- ! setting absorbing boundaries by elements instead of edges
- if ( any_abs ) then
- call merge_abs_boundaries(nb_materials, phi, num_material, ngnod)
- endif
-
- ! *** generate the databases for the solver
- call save_databases(nspec,num_material, &
- my_interfaces,my_nb_interfaces, &
- nnodes_tangential_curve,nodes_tangential_curve)
-
- ! print position of the source
- do i_source=1,NSOURCES
- print *
- print *,'Position (x,z) of the source = ',xs(i_source),zs(i_source)
- print *
- enddo
-
- !--- compute position of the receivers and write the STATIONS file
-
- if (generate_STATIONS) then
- call save_stations_file(nreceiverlines,nrec,xdeb,zdeb,xfin,zfin,enreg_surf_same_vertical, &
- xinterface_top,zinterface_top,coefs_interface_top, &
- npoints_interface_top,max_npoints_interface)
- endif
-
- print *
- if (nproc == 1) then
- print *,'This will be a serial simulation'
- else
- print *,'This will be a parallel simulation on ',nproc,' processors'
- endif
- print *
-
-end program meshfem2D
Deleted: seismo/2D/SPECFEM2D/trunk/netlib_specfun_erf.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/netlib_specfun_erf.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/netlib_specfun_erf.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,318 +0,0 @@
-
- subroutine calerf(ARG,RESULT,JINT)
-
-!------------------------------------------------------------------
-!
-! This routine can be freely obtained from Netlib
-! at http://www.netlib.org/specfun/erf
-!
-! Most Netlib software packages have no restrictions on their use
-! but Netlib recommends that you check with the authors to be sure.
-! See http://www.netlib.org/misc/faq.html#2.3 for details.
-!
-!------------------------------------------------------------------
-!
-! This packet evaluates erf(x) for a real argument x.
-! It contains one FUNCTION type subprogram: ERF,
-! and one SUBROUTINE type subprogram, CALERF. The calling
-! statements for the primary entries are:
-!
-! Y = ERF(X)
-!
-! The routine CALERF is intended for internal packet use only,
-! all computations within the packet being concentrated in this
-! routine. The function subprograms invoke CALERF with the
-! statement
-!
-! call CALERF(ARG,RESULT,JINT)
-!
-! where the parameter usage is as follows
-!
-! Function Parameters for CALERF
-! call ARG Result JINT
-!
-! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0
-!
-! The main computation evaluates near-minimax approximations
-! from "Rational Chebyshev approximations for the error function"
-! by William J. Cody, Math. Comp., 1969, PP. 631-638. This
-! transportable program uses rational functions that theoretically
-! approximate erf(x) and erfc(x) to at least 18 significant
-! decimal digits. The accuracy achieved depends on the arithmetic
-! system, the compiler, the intrinsic functions, and proper
-! selection of the machine-dependent constants.
-!
-!*******************************************************************
-!*******************************************************************
-!
-! Explanation of machine-dependent constants
-!
-! XMIN = the smallest positive floating-point number.
-! XINF = the largest positive finite floating-point number.
-! XNEG = the largest negative argument acceptable to ERFCX;
-! the negative of the solution to the equation
-! 2*exp(x*x) = XINF.
-! XSMALL = argument below which erf(x) may be represented by
-! 2*x/sqrt(pi) and above which x*x will not underflow.
-! A conservative value is the largest machine number X
-! such that 1.0 + X = 1.0 to machine precision.
-! XBIG = largest argument acceptable to ERFC; solution to
-! the equation: W(x) * (1-0.5/x**2) = XMIN, where
-! W(x) = exp(-x*x)/[x*sqrt(pi)].
-! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to
-! machine precision. A conservative value is
-! 1/[2*sqrt(XSMALL)]
-! XMAX = largest acceptable argument to ERFCX; the minimum
-! of XINF and 1/[sqrt(pi)*XMIN].
-!
-! Approximate IEEE double precision values are defined below.
-!
-!*******************************************************************
-!*******************************************************************
-!
-! Error returns
-!
-! The program returns ERFC = 0 for ARG >= XBIG;
-!
-! Author: William J. Cody
-! Mathematics and Computer Science Division
-! Argonne National Laboratory
-! Argonne, IL 60439, USA
-!
-! Latest modification: March 19, 1990
-!
-! Converted to Fortran90 and slightly modified by
-! Dimitri Komatitsch, University of Pau, France, November 2007.
-!
-!------------------------------------------------------------------
-
- implicit none
-
- integer I,JINT
- double precision A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEEN,SQRPI, &
- TWO,THRESHOLD,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL, &
- Y,YSQ,ZERO
- dimension A(5),B(4),C(9),D(8),P(6),Q(5)
-
-!------------------------------------------------------------------
-! Mathematical constants
-!------------------------------------------------------------------
- data FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/, &
- SQRPI/5.6418958354775628695D-1/,THRESHOLD/0.46875D0/, &
- SIXTEEN/16.0D0/
-
-!------------------------------------------------------------------
-! Machine-dependent constants
-!------------------------------------------------------------------
- data XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/, &
- XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/
-
-!------------------------------------------------------------------
-! Coefficients for approximation to erf in first interval
-!------------------------------------------------------------------
- data A/3.16112374387056560D00,1.13864154151050156D02, &
- 3.77485237685302021D02,3.20937758913846947D03, &
- 1.85777706184603153D-1/
- data B/2.36012909523441209D01,2.44024637934444173D02, &
- 1.28261652607737228D03,2.84423683343917062D03/
-
-!------------------------------------------------------------------
-! Coefficients for approximation to erfc in second interval
-!------------------------------------------------------------------
- data C/5.64188496988670089D-1,8.88314979438837594D0, &
- 6.61191906371416295D01,2.98635138197400131D02, &
- 8.81952221241769090D02,1.71204761263407058D03, &
- 2.05107837782607147D03,1.23033935479799725D03, &
- 2.15311535474403846D-8/
- data D/1.57449261107098347D01,1.17693950891312499D02, &
- 5.37181101862009858D02,1.62138957456669019D03, &
- 3.29079923573345963D03,4.36261909014324716D03, &
- 3.43936767414372164D03,1.23033935480374942D03/
-
-!------------------------------------------------------------------
-! Coefficients for approximation to erfc in third interval
-!------------------------------------------------------------------
- data P/3.05326634961232344D-1,3.60344899949804439D-1, &
- 1.25781726111229246D-1,1.60837851487422766D-2, &
- 6.58749161529837803D-4,1.63153871373020978D-2/
- data Q/2.56852019228982242D00,1.87295284992346047D00, &
- 5.27905102951428412D-1,6.05183413124413191D-2, &
- 2.33520497626869185D-3/
-
- X = ARG
- Y = ABS(X)
- if (Y <= THRESHOLD) then
-
-!------------------------------------------------------------------
-! Evaluate erf for |X| <= 0.46875
-!------------------------------------------------------------------
- YSQ = ZERO
- if (Y > XSMALL) YSQ = Y * Y
- XNUM = A(5)*YSQ
- XDEN = YSQ
-
- do I = 1, 3
- XNUM = (XNUM + A(I)) * YSQ
- XDEN = (XDEN + B(I)) * YSQ
- enddo
-
- RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
- if (JINT /= 0) RESULT = ONE - RESULT
- if (JINT == 2) RESULT = EXP(YSQ) * RESULT
- goto 800
-
-!------------------------------------------------------------------
-! Evaluate erfc for 0.46875 <= |X| <= 4.0
-!------------------------------------------------------------------
- else if (Y <= FOUR) then
- XNUM = C(9)*Y
- XDEN = Y
-
- do I = 1, 7
- XNUM = (XNUM + C(I)) * Y
- XDEN = (XDEN + D(I)) * Y
- enddo
-
- RESULT = (XNUM + C(8)) / (XDEN + D(8))
- if (JINT /= 2) then
- YSQ = AINT(Y*SIXTEEN)/SIXTEEN
- DEL = (Y-YSQ)*(Y+YSQ)
- RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
- endif
-
-!------------------------------------------------------------------
-! Evaluate erfc for |X| > 4.0
-!------------------------------------------------------------------
- else
- RESULT = ZERO
- if (Y >= XBIG) then
- if (JINT /= 2 .OR. Y >= XMAX) goto 300
- if (Y >= XHUGE) then
- RESULT = SQRPI / Y
- goto 300
- endif
- endif
- YSQ = ONE / (Y * Y)
- XNUM = P(6)*YSQ
- XDEN = YSQ
-
- do I = 1, 4
- XNUM = (XNUM + P(I)) * YSQ
- XDEN = (XDEN + Q(I)) * YSQ
- enddo
-
- RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
- RESULT = (SQRPI - RESULT) / Y
- if (JINT /= 2) then
- YSQ = AINT(Y*SIXTEEN)/SIXTEEN
- DEL = (Y-YSQ)*(Y+YSQ)
- RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
- endif
- endif
-
-!------------------------------------------------------------------
-! Fix up for negative argument, erf, etc.
-!------------------------------------------------------------------
- 300 if (JINT == 0) then
- RESULT = (HALF - RESULT) + HALF
- if (X < ZERO) RESULT = -RESULT
- else if (JINT == 1) then
- if (X < ZERO) RESULT = TWO - RESULT
- else
- if (X < ZERO) then
- if (X < XNEG) then
- RESULT = XINF
- else
- YSQ = AINT(X*SIXTEEN)/SIXTEEN
- DEL = (X-YSQ)*(X+YSQ)
- Y = EXP(YSQ*YSQ) * EXP(DEL)
- RESULT = (Y+Y) - RESULT
- endif
- endif
- endif
-
- 800 return
-
- end subroutine calerf
-
-!--------------------------------------------------------------------
-
- double precision function netlib_specfun_erf(X)
-
-! This subprogram computes approximate values for erf(x).
-! (see comments heading CALERF).
-!
-! Author/date: William J. Cody, January 8, 1985
-
- implicit none
-
- integer JINT
- double precision X, RESULT
-
- JINT = 0
- call calerf(X,RESULT,JINT)
- netlib_specfun_erf = RESULT
-
- end function netlib_specfun_erf
-
-!
-! Subject: RE: Can one freely use and redistribute Fortran routines "specfun" from Netlib?
-! From: Jack Dongarra
-! Date: Wed, 21 Nov 2007 10:33:45 -0500
-! To: Rusty Lusk, Dimitri Komatitsch
-!
-! Yes the code can freely be used and incorporated into other software. You
-! should of course acknowledge the use of the software.
-!
-! Hope this helps,
-!
-! Jack Dongarra
-!
-! **********************************************************************
-! Prof. Jack Dongarra; Innovative Computing Laboratory; EECS Department;
-! 1122 Volunteer Blvd; University of Tennessee; Knoxville TN 37996-3450;
-! +1-865-974-8295; http://www.cs.utk.edu/~dongarra/
-!
-! -----Original Message-----
-! From: Rusty Lusk
-! Sent: Wednesday, November 21, 2007 10:29 AM
-! To: Dimitri Komatitsch
-! Cc: Jack Dongarra
-! Subject: Re: Can one freely use and redistribute Fortran routines "specfun"
-! from Netlib?
-!
-! Netlib is managed at the University of Tennesee, not Argonne at this
-! point. I have copied Jack Dongarra on this reply; he should be able
-! to answer questions about licensing issues for code from Netlib.
-!
-! Regards,
-! Rusty
-!
-! On Nov 21, 2007, at 8:36 AM, Dimitri Komatitsch wrote:
-!
-! >
-! > Dear Sir,
-! >
-! > Can one freely use and redistribute Fortran routines "specfun" from
-! > Netlib http://netlib2.cs.utk.edu/specfun/
-! > which were written back in 1985-1990 by William J. Cody
-! > from the Mathematics and Computer Science Division at Argonne?
-! >
-! > We use one of these routines (the error function, erf())
-! > in one of our source codes, which we would like to
-! > release as open source under GPL v2+, and we therefore
-! > wonder if we could include that erf() routine in the
-! > package in a separate file (of course saying in a comment in the
-! > header that it comes from Netlib and was written by William J. Cody from
-! > Argonne).
-! >
-! > Thank you,
-! > Best regards,
-! >
-! > Dimitri Komatitsch.
-! >
-! > --
-! > Dimitri Komatitsch - dimitri.komatitsch aT univ-pau.fr
-! > Professor, University of Pau, Institut universitaire de France
-! > and INRIA Magique3D, France http://www.univ-pau.fr/~dkomati1
-! >
Deleted: seismo/2D/SPECFEM2D/trunk/paco_beyond_critical.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/paco_beyond_critical.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/paco_beyond_critical.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,605 +0,0 @@
-!
-! This subroutine was written by Paco Sanchez-Sesma and his colleagues
-! from the Autonomous University of Mexico (UNAM), Mexico City, Mexico
-!
-! original name : DISTRAFF.f
-!
-! CALCULO DE DESPLAZAMIENTOS (UX, UZ) y TRACCIONES (TX, TZ) DE CAMPO LIBRE
-! EN UN SEMIESPACIO ELASTICO Y EN LA VECINDAD DE LA SUPERFICIE
-!
-! INCIDENCIA DE ONDAS P, SV Y DE RAYLEIGH
-!
-! 7 de febrero de 2007
-!
-! modified by Dimitri Komatitsch and Ronan Madec in March 2008
-! in particular, converted to Fortran90 and to double precision
-
-subroutine paco_beyond_critical(coord,npoin,deltat,NSTEP_global,angleforce,&
- f0,cp_local,cs_local,INCLUDE_ATTENUATION,QD,source_type,v0x_left,v0z_left,v0x_right,v0z_right,&
- v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot,left_bound,right_bound,&
- bot_bound,nleft,nright,nbot,displ_elastic,veloc_elastic,accel_elastic)
-
- implicit none
-
- include "constants.h"
-
- double precision :: f0,cp_local,cs_local,deltat,dt,TP,angleforce,QD,delta_in_period
- logical :: INCLUDE_ATTENUATION
- integer :: npt,NSTEP_global,source_type,nleft,nright,nbot,npoin
-
- integer, dimension(nleft) :: left_bound
- integer, dimension(nright) :: right_bound
- integer, dimension(nbot) :: bot_bound
-
- double precision, dimension(nleft,NSTEP_global) :: v0x_left,v0z_left, t0x_left,t0z_left
- double precision, dimension(nright,NSTEP_global) :: v0x_right,v0z_right, t0x_right,t0z_right
- double precision, dimension(nbot,NSTEP_global) :: v0x_bot,v0z_bot, t0x_bot,t0z_bot
-
- double precision, dimension(2,npoin) :: coord
- double precision, dimension(2,npoin) :: displ_elastic
- double precision, dimension(2,npoin) :: veloc_elastic
- double precision, dimension(2,npoin) :: accel_elastic
-
- integer, dimension(:),allocatable :: local_pt
-
- double precision, dimension(:), allocatable :: temp_field
-
- integer :: J, indice, NSTEP_local, FLAG, N, NFREC, NFREC1
-
- double precision :: ANU,BEALF,ALFBE,RLM,VNX,VNZ,A1,B1,TOTO,FJ,AKA,AQA,GAMR
-
-! location of the point
- double precision :: X, Z, xmin, xmax, zmin, zmax
- integer :: inode
-
- complex(selected_real_kind(15,300)) :: CAKA,CAQA,UI,UR
- complex(selected_real_kind(15,300)) :: UX,UZ,SX,SZ,SXZ,A2,B2,AL,AK,AM
-
- complex(selected_real_kind(15,300)) :: TX,TZ
-
- complex(selected_real_kind(15,300)), dimension(:),allocatable::Field_Ux,Field_Uz,Field_Tx,Field_Tz
-
- double precision :: TS
-
-! to move the place where the wave reflects on free surface (offset too)
- double precision :: offset
-
-! size of the model
- xmin=minval(coord(1,:))
- xmax=maxval(coord(1,:))
- zmin=minval(coord(2,:))
- zmax=maxval(coord(2,:))
-
-! offset of the origin of time of the Ricker (equivalent to t0 in SPECFEM2D)
- offset=4.d0*(xmax-xmin)/5.d0
- TS=2.d0/f0
-
-! dominant period of the Ricker (equivalent to 1/f0 in SPECFEM2D)
- TP=1.d0/f0
-
-! find optimal period
-! if period is too small, you should see several initial plane wave on your initial field
- delta_in_period=2.d0
- do while(delta_in_period<1.5*abs(xmax-xmin)/cs_local)
- delta_in_period=2.d0*delta_in_period
- end do
-
-! test Deltat compatibility
- DT=256.d0
- do while(DT>deltat)
- DT=DT/2.d0
- end do
- if (abs(DT-deltat)>1.0d-13) then
- print *, "you must take a deltat as a power of two (power can be negative)"
- print *, "for example you can take", DT
- stop "can't go further, restart with new deltat"
- end if
-
- DT=deltat/2.d0
-
- N=2
- do while(N<2*NSTEP_global+1)
- N=2.d0*N
- end do
-
- do while(DT<(delta_in_period/N))
- N=2.d0*N
- end do
-
- print *, 'N found to do frequency calcul :', N
- print *,'number of discrete frequencies = ',N/2
- print *,'delta in period (seconds) = ',delta_in_period
- print *,'delta in frequency (Hz) = ',1.d0/delta_in_period
- print *,'dt (here we need deltat/2) = ', DT
-
- NFREC=N/2
- NFREC1=NFREC+1
-
-
-!
-! FDT: FUNCION DE TRASFERENCIA
-!
-
-! calculation of Poisson's ratio
- ANU = (cp_local*cp_local-2.d0*cs_local*cs_local)/(2.d0*(cp_local*cp_local-cs_local*cs_local))
- print *,"Poisson's ratio = ",ANU
-
- UI=(0.0d0, 1.0d0)
- UR=(1.0d0, 0.0d0)
-
-! convert angle to radians
- GAMR = angleforce
-
- BEALF=SQRT((1.0d0-2.0d0*ANU)/(2.0d0*(1.0d0-ANU)))
- ALFBE=1.0d0/BEALF
- RLM=ALFBE**2-2.0d0
-
-! flags: interior=0, left=1, right=2, bottom=3
- do FLAG=0,3
-
- if (FLAG==0) then
- print *, "calcul of the initial field for every point of the mesh"
- npt=npoin
- allocate(local_pt(npt))
- do inode=1,npt
- local_pt(inode)=inode
- end do
- NSTEP_local=1
- else if(FLAG==1) then
- print *, "calcul of every time step on the left absorbing boundary"
- npt=nleft
- allocate(local_pt(npt))
- local_pt=left_bound
- NSTEP_local=NSTEP_global
- else if(FLAG==2) then
- print *, "calcul of every time step on the right absorbing boundary"
- npt=nright
- allocate(local_pt(npt))
- local_pt=right_bound
- NSTEP_local=NSTEP_global
- else if(FLAG==3) then
- print *, "calcul of every time step on the bottom absorbing boundary"
- npt=nbot
- allocate(local_pt(npt))
- local_pt=bot_bound
- NSTEP_local=NSTEP_global
- end if
-
-! to distinguish all model case and boundary case
- allocate(temp_field(NSTEP_local))
-
- allocate(Field_Ux(NFREC1))
- allocate(Field_Uz(NFREC1))
- allocate(Field_Tx(NFREC1))
- allocate(Field_Tz(NFREC1))
-
-
- if(mod(N,2) /= 0) stop 'N must be a multiple of 2'
-
-! normal vector to the edge at this grid point
-! therefore corners between two grid edges must be computed twice
-! because the normal will change
- if (FLAG==1) then
- VNZ = 0.d0
- VNX = 1.d0
- else if (FLAG==2) then
- VNZ = 0.d0
- VNX = 1.d0
- else if (FLAG==3) then
- VNZ = 1.d0
- VNX = 0.d0
- else
- VNZ = 0.d0
- VNX = 0.d0
- end if
-
-
- do indice=1,npt
-
- if (FLAG==0) then
- inode=indice
- X=coord(1,indice)-offset
-! specfem coordinate axes are implemented from bottom to top whereas for this code
-! we need from top to bottom
- Z=zmax-coord(2,indice)
- else
- inode=local_pt(indice)
- X=coord(1,inode)-offset
-! specfem coordinate axes are implemented from bottom to top whereas for this code
-! we need from top to bottom
- Z=zmax-coord(2,inode)
- end if
-
- if (mod(indice,500)==0) then
- print *, indice, "points have been treated on ",npt," total points"
- end if
-
-!
-! first handle the particular case of zero frequency
-!
- TOTO=0.01d0
- IF (source_type==1) CALL ONDASP(GAMR,0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
- IF (source_type==2) CALL ONDASS(GAMR,TOTO,0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
- IF (source_type==3) CALL ONDASR(0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
-
-
- TOTO=0.0d0
- CALL DESFXY(TOTO,TOTO,source_type,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
-
-! write the frequency seismograms
- TX = SX *VNX+SXZ*VNZ
- TZ = SXZ*VNX+SZ *VNZ
-
- Field_Ux(1)=UX
- Field_Uz(1)=UZ
- if (FLAG/=0) then
- Field_Tx(1)=TX
- Field_Tz(1)=TZ
- end if
-
-!
-! then loop on all the other discrete frequencies
-!
- do J=1,N/2
-
-! compute the value of the frequency (= index * delta in frequency = index * 1/delta in period)
- FJ = dble(J) * 1.d0 / delta_in_period
-
-! pulsation (= 2 * PI * frequency)
- AKA=2.0d0*PI*FJ
-
- AQA=AKA*BEALF
-
-! exclude attenuation completely if needed
- if(INCLUDE_ATTENUATION) then
- CAKA=CMPLX(AKA,-AKA/(2.0d0*QD))
- CAQA=CMPLX(AQA,-AQA/(2.0d0*QD))
- else
- CAKA=CMPLX(AKA,0)
- CAQA=CMPLX(AQA,0)
- endif
-
- IF (source_type==1) CALL ONDASP(GAMR,AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
- IF (source_type==2) CALL ONDASS(GAMR,AKA,AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
- IF (source_type==3) CALL ONDASR(AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
-
- CALL DESFXY(X,Z,source_type,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
-
-! write the frequency seismograms
- TX = SX *VNX+SXZ*VNZ
- TZ = SXZ*VNX+SZ *VNZ
-
- Field_Ux(J+1)=UX
- Field_Uz(J+1)=UZ
- if (FLAG/=0) then
- Field_Tx(J+1)=TX
- Field_Tz(J+1)=TZ
- end if
-
- enddo
-
-! to convert frequency field in time field
-! (number at the end are unit numbers for writing in the good file,
-! in the case of the traction we fill only one file per call)
-
-! global model case for initial field
- if (FLAG==0) then
- call paco_convolve_fft(Field_Ux,1,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- displ_elastic(1,indice)=temp_field(1)
- call paco_convolve_fft(Field_Uz,1,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- displ_elastic(2,indice)=temp_field(1)
- call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- veloc_elastic(1,indice)=temp_field(1)
- call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- veloc_elastic(2,indice)=temp_field(1)
- call paco_convolve_fft(Field_Ux,3,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- accel_elastic(1,indice)=temp_field(1)
- call paco_convolve_fft(Field_Uz,3,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- accel_elastic(2,indice)=temp_field(1)
-
-! absorbing boundaries
-
-! left case
- else if (FLAG==1) then
- call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0x_left(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0z_left(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0x_left(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0z_left(indice,:)=temp_field(:)
-
-! right case
- else if (FLAG==2) then
- call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0x_right(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0z_right(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0x_right(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0z_right(indice,:)=temp_field(:)
-
-! bottom case
- else if (FLAG==3) then
- call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0x_bot(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- v0z_bot(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0x_bot(indice,:)=temp_field(:)
- call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
- t0z_bot(indice,:)=temp_field(:)
- end if
- enddo
-
- deallocate(temp_field)
- deallocate(local_pt)
-
- deallocate(Field_Ux)
- deallocate(Field_Uz)
- deallocate(Field_Tx)
- deallocate(Field_Tz)
-
- end do
-
-end subroutine paco_beyond_critical
-
-!---
-
-SUBROUTINE DESFXY(X,Z,ICAS,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
-
- implicit none
-
- double precision A1,B1,RLM,X,Z
- integer ICAS
- complex(selected_real_kind(15,300)) :: UX,UZ,SX,SZ,SXZ,A2,B2,AL,AK,AM
- complex(selected_real_kind(15,300)) :: UI,FAC
- complex(selected_real_kind(15,300)) :: AUX1,AUX2,FI1,FI2,PS1,PS2
-
- UI=(0.0d0,1.0d0)
- if (A1/=0.0d0) then
- AUX1=A1*EXP(UI*(AM*Z-AL*X)) ! campo P incidente
- else
- AUX1=CMPLX(0.0d0)
- end if
- if (A2/=0.0d0) then
- AUX2=A2*EXP(-UI*(AM*Z+AL*X)) *1.0d0 ! campo P reflejado
- else
- AUX2=CMPLX(0.0d0)
- end if
- FI1=AUX1+AUX2
- FI2=AUX1-AUX2
- if (B1/=0.0d0) then
- AUX1=B1*EXP(UI*(AK*Z-AL*X)) ! campo S incidente
- else
- AUX1=CMPLX(0.0d0)
- end if
- if (B2/=0.0d0) then
- AUX2=B2*EXP(-UI*(AK*Z+AL*X)) *1.0d0 ! campo S reflejado
- else
- AUX2=CMPLX(0.0d0)
- end if
- PS1=AUX1+AUX2
- PS2=AUX1-AUX2
-
-!
-! FAC ES PARA TENER CONSISTENCIA CON AKI & RICHARDS (1980)
-!
- FAC=UI
- IF (ICAS==2)FAC=-UI
-
- UX=(-UI*AL*FI1+UI*AK*PS2)*FAC
-
- UZ=(UI*AM*FI2+UI*AL*PS1)*FAC
-! Paco's convention for vertical coordinate axis is inverted
- UZ = - UZ
-
- AUX1=AL*AL+AM*AM
- SX=(-RLM*AUX1*FI1-2.0d0*AL*(AL*FI1-AK*PS2))*FAC
- SZ=(-RLM*AUX1*FI1-2.0d0*(AM*AM*FI1+AK*AL*PS2))*FAC
-
- SXZ=(2.0d0*AM*AL*FI2+(AL*AL-AK*AK)*PS1)*FAC
-! Paco's convention for vertical coordinate axis is inverted
- SXZ = - SXZ
-
-END SUBROUTINE DESFXY
-
-SUBROUTINE FAFB(CA,CB,FA,FB)
-
- implicit none
-
- double precision CA,CB,A,B
- complex(selected_real_kind(15,300)) :: FA,FB,ZER,UI
-
- ZER=(0.0d0,0.0d0)
- UI=(0.0d0,1.0d0)
- A=CA*CA-1.0d0
- B=CB*CB-1.0d0
-
- IF (CA<1.0d0) then
- FA=-UI*SQRT(-A)
- else
- FA=SQRT(A)+ZER
- end IF
-
- IF (CB<1.0d0) then
- FB=-UI*SQRT(-B)
- else
- FB=CMPLX(SQRT(B),0.0d0)
- end IF
-
-END SUBROUTINE FAFB
-
-SUBROUTINE A2B2(FA,FB,A2,B2)
-
- implicit none
-
- complex(selected_real_kind(15,300)) :: FA,FB,A2,B2,DEN,AUX
-
- AUX=FB*FB-1.0d0
- DEN=4.0d0*FA*FB+AUX*AUX
- A2=(4.0d0*FA*FB-AUX*AUX)/DEN
- B2=4.0d0*FA*AUX/DEN
-
-END SUBROUTINE A2B2
-
-! calculation of P waves
-SUBROUTINE ONDASP(GP,AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
-
- implicit none
-
- double precision A1,B1,ANU,CA,CB,GP,AQB,BEALF
- complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
-
- ZER=(0.0d0,0.0d0)
- BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
- A1=1.0d0/AQB
- B1=0.0d0
-
- IF (GP==0.0d0) then
- AL=ZER
- AK=ZER
- AM=AQB+ZER
- A2=(-1.0d0+ZER)/AQB
- B2=ZER
- RETURN
- end IF
-
- CA=1.0d0/SIN(GP)
- CB=CA/BEALF
- AL=AQB/CA+ZER
- CALL FAFB(CA,CB,FA,FB)
- AK=AL*FB
- AM=AL*FA
- CALL A2B2(FA,FB,A2,B2)
- A2=A2/AQB
- B2=B2/AQB
-
-END SUBROUTINE ONDASP
-
-! calculation of S waves
-SUBROUTINE ONDASS(GS,AKB,AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
-
- implicit none
-
- double precision A1,B1,ANU,CA,CB,GS,AQB,BEALF,AKB
- complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
-
- ZER=(0.0d0,0.0d0)
- BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
- A1=0.0d0
- B1=1.0d0/AKB
-
- IF (GS==0.0d0) then
- AL=ZER
- AK=AKB+ZER
- AM=ZER
- A2=ZER
- B2=(-1.0d0+ZER)/AKB
- return
- end IF
-
- CB=1.0d0/SIN(GS)
- CA=CB*BEALF
-
-!
-! case of the critical angle
-!
- IF (CA==1.d0) then
- AL=AQB+ZER
- AM=ZER
- CALL FAFB(CA,CB,FA,FB)
- AK=AL*FB
- B2=-B1
- A2=-4.0d0*COS(GS)*B1/(1./BEALF-2.*BEALF)
-
-! case of an angle that is not critical
- ELSE
- AL=AQB/CA+ZER
- CALL FAFB(CA,CB,FA,FB)
- AK=AL*FB
- AM=AL*FA
- CALL A2B2(FA,FB,B2,A2)
- A2=-A2*FB/FA
- A2=A2/AKB
- B2=B2/AKB
- endif
-
-END SUBROUTINE ONDASS
-
-! calculation of Rayleigh waves
-SUBROUTINE ONDASR(AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
-
- implicit none
-
- double precision A1,B1,ANU,CA,CB,AQB,BEALF,ba2
- complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
-
- double precision, external :: crb
-
- ZER=(0.0d0,0.0d0)
- A1=0.0d0
- B1=0.0d0
- B2=1.0d0+ZER
- BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
- BA2=BEALF*BEALF
- CB=CRB(BEALF)
- CA=CB*BEALF
- AL=AQB/CA+ZER
-
- CALL FAFB(CA,CB,FA,FB)
-
- AK=AL*FB
- AM=AL*FA
- A2=2.0d0*FB/(FB*FB-1.0d0)*B2
- B2=B2/(AL*A2+AK)
- A2=A2*B2
-
-END SUBROUTINE ONDASR
-
-FUNCTION CRB(BEALF)
-
- implicit none
-
- include "constants.h"
-
- double precision U3,BA2,P,Q,FIND,F1,F2,F12,FACT,CRB,BEALF
-
- U3=1.0d0/3.0d0
- BA2=BEALF*BEALF
- P=8.0d0/3.0d0-16.0d0*BA2
- Q=272.0d0/27.0d0-80.0d0/3.0d0*BA2
- FIND=Q*Q/4.0d0+P*P*P/27.0d0
- IF (FIND>=0.0d0) then
- F1=SQRT(FIND)-Q/2.0d0
- IF (F1>0.0d0) then
- F1=F1**U3
- else
- F1=-(-F1)**U3
- end IF
- F2=-SQRT(FIND)-Q/2.0d0
- IF (F2>0.0d0) then
- F2=F2**U3
- else
- F2=-(-F2)**U3
- end IF
- FACT=F1+F2+8.0d0/3.0d0
- CRB=SQRT(FACT)
- else
- F1=-27.0d0*Q*Q/(4.0d0*P*P*P)
- F1=SQRT(F1)
- IF (Q<0.0d0) then
- F1=COS((PI-ACOS(F1))/3.0d0)
- else
- F1=COS(ACOS(F1)/3.0d0)
- end IF
- F2=-P/3.0d0
- F2=SQRT(F2)
- F12=-2.0d0*F1*F2+8.0d0/3.0d0
- CRB=SQRT(F12)
- end IF
-
-END FUNCTION CRB
-
Deleted: seismo/2D/SPECFEM2D/trunk/paco_convolve_fft.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/paco_convolve_fft.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/paco_convolve_fft.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,230 +0,0 @@
-!
-! This subroutine was written by Paco Sanchez-Sesma and his colleagues
-! from the Autonomous University of Mexico (UNAM), Mexico City, Mexico
-!
-! PROGRAMA PARA CALCULAR SISMOGRAMAS SINTETICOS DADA LA
-! FUNCION DE TRANSFERENCIA PARA COMPONENTES Ux, Uz, R2
-! Tx y Tz SOLUCION DE CAMPO LIBRE Caso P-SV, RAYLEIGH
-!
-! modified by Dimitri Komatitsch and Ronan Madec in March 2008
-! in particular, converted to Fortran90 and to double precision
-
-subroutine paco_convolve_fft(Field,label,NSTEP,dt,NFREC,output_field,tp,ts)
-
- implicit none
-
- integer :: NFREC,N,NSTEP
-
- complex(selected_real_kind(15,300)), dimension(NFREC+1) :: Field
-
- complex(selected_real_kind(15,300)) :: CR(2*NFREC)
-
- double precision, dimension(NSTEP) :: output_field
-
- integer :: J,label
-
- double precision :: AN,FUN,RAIZ,dt,tp,ts
-
- double precision, external :: RIC, deRIC, de2RIC
-
- N=2*NFREC
-
- AN = N
-
-!
-! label=1 <=> champ U en entree =>convolution par un ricker pour U
-! label=2 <=> champ U en entree =>convolution par la derivee de ricker pour V
-! label=3 <=> champ U en entree =>convolution par la derivee seconde de ricker pour A
-! label=4 <=> champ T en entree =>convolution par un ricker
-!
-! flag=0 on a besoin de U, V et A (pas T)
-! flag/=0 on a besoin de T et V (pas U ni A)
-!
-! NSTEP==1 <=> FLAG==0 (flags: interior=0, left=1, right=2, bottom=3)
-!
-
- do j=1,N
- if (label==1 .or. label==4) FUN=ric(j,tp,ts,dt)
- if (label==2) FUN=deric(j,tp,ts,dt)
- if (label==3) FUN=de2ric(j,tp,ts,dt)
- CR(j)=CMPLX(FUN,0.0d0)
- enddo
-
- CALL fourier_transform(N,CR,-1.0d0)
-
- RAIZ = SQRT(AN)
-
- CALL SINTER(Field,output_field,NSTEP,CR,RAIZ,NFREC,label,dt)
-
-END subroutine paco_convolve_fft
-
-SUBROUTINE SINTER(V,output_field,NSTEP,CR,RAIZ,NFREC,label,dt)
-
- implicit none
-
- integer NSTEP, j,jn,N,label,nfrec,mult,delay
-
- double precision :: RAIZ
-
- complex(selected_real_kind(15,300)) :: VC
-
- double precision VT(2*NFREC)
-
- double precision :: filt,dt
-
- double precision, dimension(NSTEP) :: output_field
-
- complex(selected_real_kind(15,300)), dimension(NFREC+1) :: V
-
- complex(selected_real_kind(15,300)) :: CY(2*NFREC),CR(2*NFREC)
-
- N=2*NFREC
-
- CY(1) = CR(1) * V(1) * RAIZ * dt
-
- DO J=2,N/2+1
- FILT = 1.0d0
- VC = V(J)
- CY(J)= CR(J)*VC * RAIZ * dt/ FILT
- JN = N-J+2
- CY(JN)=CONJG(CY(J))
- enddo
-
- CALL fourier_transform(N,CY,1.0d0)
-
- if (label==1 .or. label==3 .or. (label==2 .and. NSTEP==1)) then
-! coefficients to take time steps needed (t=0: first time step)
- mult=1
- delay=0
- else if(label==2 .and. NSTEP>1) then
-! coefficients to take time steps needed (t=i*deltat+1/2: one step on two starting at 1/2)
- mult=2
- delay=0
- else if(label==4) then
-! coefficients to take time steps needed (t=i*deltat+1: one step on two starting at 1)
- mult=2
- delay=1
- end if
-
- do J=1,NSTEP
- CY(mult*J+delay)=CY(mult*J+delay)/RAIZ/dt
- VT(mult*J+delay)=REAL(CY(mult*J+delay))
- output_field(J)=VT(mult*J+delay)
- enddo
-
-END SUBROUTINE SINTER
-
-!
-! Ricker time function
-!
-FUNCTION RIC(J,tp,ts,dt)
-
- implicit none
-
- include "constants.h"
-
- double precision :: A,RIC,tp,ts,dt
-
- integer j
-
- A=PI*(dt*(J-1)-ts)/tp
- A=A*A
- RIC=0.0d0
- IF(A>30.0d0) RETURN
- RIC=(A-0.5)*EXP(-A)
-
-END FUNCTION RIC
-
-!
-! first time derivative of Ricker time function
-!
-FUNCTION deRIC(J,tp,ts,dt)
-
- implicit none
-
- include "constants.h"
-
- double precision :: A,A_dot,deRIC,tp,ts,dt
- integer :: j
-
- A=PI*(dt*(J-1)-ts)/tp
- A=A*A
- A_dot=2*(PI/tp)**2*(dt*(J-1)-ts)
- deRIC=0.0d0
- IF(A>30.0d0) RETURN
- deRIC=A_dot*(1.5-A)*EXP(-A)
-
-END FUNCTION deRIC
-
-!
-! second time derivative of Ricker time function
-!
-FUNCTION de2RIC(J,tp,ts,dt)
-
- implicit none
-
- include "constants.h"
-
- double precision :: A,A_dot,A_dot_dot,de2RIC,tp,ts,dt
- integer j
-
- A=PI*(dt*(J-1)-ts)/tp
- A=A*A
- A_dot=2*(PI/tp)**2*(dt*(J-1)-ts)
- A_dot_dot=2*(PI/tp)**2
- de2RIC=0.0d0
- IF(A>30.0d0) RETURN
- de2RIC=(A_dot_dot*(1.5-A)-A_dot*A_dot-A_dot*(1.5-A)*A_dot)*EXP(-A)
-
-END FUNCTION de2RIC
-
-
-! Fourier transform
-SUBROUTINE fourier_transform(LX,CX,SIGNI)
-
- implicit none
-
- include "constants.h"
-
- integer LX,i,j,l,istep,m
-
- double precision SC
-
- complex(selected_real_kind(15,300)) :: CX(LX),CARG,CW,CTEMP
-
- double precision SIGNI
-
- J=1
- SC=SQRT(1.0d0/LX)
- DO I=1,LX
- IF (I<=J) then
- CTEMP=CX(J)*SC
- CX(J)=CX(I)*SC
- CX(I)=CTEMP
- end IF
- M=LX/2
- do while (M>=1 .and. M<J)
- J=J-M
- M=M/2
- end do
- J=J+M
- end DO
- L=1
-
- do while(L<LX)
- ISTEP=2*L
- DO M=1,L
- CARG=(0.0d0,1.0d0)*(PI*SIGNI*(M-1))/L
- CW=EXP(CARG)
- DO I=M,LX,ISTEP
- CTEMP=CW*CX(I+L)
- CX(I+L)=CX(I)-CTEMP
- CX(I)=CX(I)+CTEMP
- end DO
- end DO
-
- L=ISTEP
- end do
-
-END SUBROUTINE fourier_transform
-
Deleted: seismo/2D/SPECFEM2D/trunk/part_unstruct.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/part_unstruct.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/part_unstruct.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,1654 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!
-! This module contains subroutines related to unstructured meshes and partitioning of the
-! corresponding graphs.
-!
-
-module part_unstruct
-
- implicit none
-
- integer :: nelmnts
- integer, dimension(:), pointer :: elmnts
- integer, dimension(:), allocatable :: elmnts_bis
- integer, dimension(:), allocatable :: vwgt
- integer, dimension(:), allocatable :: glob2loc_elmnts
- integer, dimension(:), allocatable :: part
-
- integer :: nb_edges
- integer, dimension(:), allocatable :: adjwgt
-
- integer, dimension(:), allocatable :: xadj_g
- integer, dimension(:), allocatable :: adjncy_g
-
- integer :: nnodes
- double precision, dimension(:,:), allocatable :: nodes_coords
- integer, dimension(:), allocatable :: nnodes_elmnts
- integer, dimension(:), allocatable :: nodes_elmnts
- integer, dimension(:), allocatable :: glob2loc_nodes_nparts
- integer, dimension(:), allocatable :: glob2loc_nodes_parts
- integer, dimension(:), allocatable :: glob2loc_nodes
-
- ! interface data
- integer :: ninterfaces
- integer, dimension(:), allocatable :: tab_size_interfaces, tab_interfaces
-
- integer :: nelem_acoustic_surface
- integer, dimension(:,:), pointer :: acoustic_surface
- integer :: nelem_acoustic_surface_loc
-
- integer :: nelemabs
- integer, dimension(:,:), allocatable :: abs_surface
- logical, dimension(:,:), allocatable :: abs_surface_char
- integer, dimension(:), allocatable :: abs_surface_merge
- integer :: nelemabs_loc
-
- integer :: nelemabs_merge
- integer, dimension(:), allocatable :: ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right
-
- ! for acoustic/elastic coupled elements
- integer :: nedges_coupled
- integer, dimension(:,:), pointer :: edges_coupled
-
- ! for acoustic/poroelastic coupled elements
- integer :: nedges_acporo_coupled
- integer, dimension(:,:), pointer :: edges_acporo_coupled
-
- ! for poroelastic/elastic coupled elements
- integer :: nedges_elporo_coupled
- integer, dimension(:,:), pointer :: edges_elporo_coupled
-
-contains
-
- !-----------------------------------------------
- ! Read the mesh and storing it in array 'elmnts' (which is allocated here).
- ! 'num_start' is used to have the numbering of the nodes starting at '0'.
- ! 'nelmnts' is the number of elements, 'nnodes' is the number of nodes in the mesh.
- !-----------------------------------------------
- subroutine read_external_mesh_file(filename, num_start, ngnod)
-
- implicit none
- !include "constants.h"
-
- character(len=256), intent(in) :: filename
- integer, intent(out) :: num_start
- integer, intent(in) :: ngnod
-
- integer :: i,ier
-
- open(unit=990, file=trim(filename), form='formatted' , status='old', action='read',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening file: ',trim(filename)
- stop 'error read external mesh file'
- endif
-
- read(990,*) nelmnts
-
- allocate(elmnts(0:ngnod*nelmnts-1))
-
- do i = 0, nelmnts-1
- if(ngnod == 4) then
- read(990,*) elmnts(i*ngnod), elmnts(i*ngnod+1), elmnts(i*ngnod+2), elmnts(i*ngnod+3)
- else if(ngnod == 9) then
- read(990,*) elmnts(i*ngnod), elmnts(i*ngnod+1), elmnts(i*ngnod+2), elmnts(i*ngnod+3), &
- elmnts(i*ngnod+4), elmnts(i*ngnod+5), elmnts(i*ngnod+6), elmnts(i*ngnod+7), elmnts(i*ngnod+8)
- else
- stop 'error, ngnod should be either 4 or 9 for external meshes'
- endif
- enddo
-
- close(990)
-
- num_start = minval(elmnts)
- elmnts(:) = elmnts(:) - num_start
- nnodes = maxval(elmnts) + 1
-
- end subroutine read_external_mesh_file
-
- !-----------------------------------------------
- ! Read the nodes coordinates and storing it in array 'nodes_coords'
- !-----------------------------------------------
- subroutine read_nodes_coords(filename)
-
- implicit none
-
- character(len=256), intent(in) :: filename
-
- integer :: i,ier
-
- open(unit=991, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening file: ',trim(filename)
- stop 'error read external nodes coords file'
- endif
-
- read(991,*) nnodes
- allocate(nodes_coords(2,nnodes))
- do i = 1, nnodes
- read(991,*) nodes_coords(1,i), nodes_coords(2,i)
- enddo
- close(991)
-
- end subroutine read_nodes_coords
-
-
- !-----------------------------------------------
- ! Read the material for each element and storing it in array 'num_materials'
- !-----------------------------------------------
- subroutine read_mat(filename, num_material)
-
- implicit none
-
- character(len=256), intent(in) :: filename
- integer, dimension(1:nelmnts), intent(out) :: num_material
-
- integer :: i,ier
-
- open(unit=992, file=trim(filename), form='formatted' , status='old', action='read',iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening file: ',trim(filename)
- stop 'error read external mat file'
- endif
-
- do i = 1, nelmnts
- read(992,*) num_material(i)
- enddo
- close(992)
-
- end subroutine read_mat
-
-
- !-----------------------------------------------
- ! Read free surface.
- ! Edges from elastic elements are discarded.
- ! 'acoustic_surface' contains 1/ element number, 2/ number of nodes that form the free surface,
- ! 3/ first node on the free surface, 4/ second node on the free surface, if relevant (if 2/ is equal to 2)
- !-----------------------------------------------
- subroutine read_acoustic_surface(filename, num_material, &
- ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
-
- implicit none
-
- !include "constants.h"
-
- character(len=256), intent(in) :: filename
- integer, dimension(0:nelmnts-1) :: num_material
- integer, intent(in) :: ANISOTROPIC_MATERIAL
- integer, intent(in) :: nb_materials
- integer, dimension(1:nb_materials), intent(in) :: icodemat
- double precision, dimension(1:nb_materials), intent(in) :: phi
- integer, intent(in) :: num_start
-
-
- integer, dimension(:,:), allocatable :: acoustic_surface_tmp
- integer :: nelmnts_surface
- integer :: i,ier
- integer :: imaterial_number
-
-
- open(unit=993, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
- if( ier /= 0 ) then
- print*,'error opening file: ',trim(filename)
- stop 'error read acoustic surface file'
- endif
-
- read(993,*) nelmnts_surface
-
- allocate(acoustic_surface_tmp(4,nelmnts_surface))
-
- do i = 1, nelmnts_surface
- read(993,*) acoustic_surface_tmp(1,i), acoustic_surface_tmp(2,i), acoustic_surface_tmp(3,i), acoustic_surface_tmp(4,i)
-
- enddo
-
- close(993)
- acoustic_surface_tmp(1,:) = acoustic_surface_tmp(1,:) - num_start
- acoustic_surface_tmp(3,:) = acoustic_surface_tmp(3,:) - num_start
- acoustic_surface_tmp(4,:) = acoustic_surface_tmp(4,:) - num_start
-
- nelem_acoustic_surface = 0
- do i = 1, nelmnts_surface
- imaterial_number = num_material(acoustic_surface_tmp(1,i))
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
-
- endif
- enddo
-
- allocate(acoustic_surface(4,nelem_acoustic_surface))
-
- nelem_acoustic_surface = 0
- do i = 1, nelmnts_surface
- imaterial_number = num_material(acoustic_surface_tmp(1,i))
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
- nelem_acoustic_surface = nelem_acoustic_surface + 1
- acoustic_surface(:,nelem_acoustic_surface) = acoustic_surface_tmp(:,i)
- endif
- enddo
-
- end subroutine read_acoustic_surface
-
-
- !-----------------------------------------------
- ! Read absorbing surface.
- ! 'abs_surface' contains 1/ element number, 2/ number of nodes that form the absorbing edge
- ! (which currently must always be equal to two, see comment below),
- ! 3/ first node on the abs surface, 4/ second node on the abs surface
- !-----------------------------------------------
- subroutine read_abs_surface(filename, num_start)
-
- implicit none
- !include "constants.h"
-
- character(len=256), intent(in) :: filename
- integer, intent(in) :: num_start
-
- integer :: i,ier
-
- open(unit=994, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
- if( ier /= 0 ) then
- print *,'error opening file: ',trim(filename)
- stop 'error read absorbing surface file'
- endif
-
- read(994,*) nelemabs
-
- allocate(abs_surface(4,nelemabs))
-
- do i = 1, nelemabs
- read(994,*) abs_surface(1,i), abs_surface(2,i), abs_surface(3,i), abs_surface(4,i)
- if (abs_surface(2,i) /= 2) then
- print *,'The input format is currently limited: only two nodes per element can be listed.'
- print *,'If one of your elements has more than one edge along a given absorbing contour'
- print *,'(e.g., if that contour has a corner) then list it twice,'
- print *,'putting the first edge on the first line and the second edge on the second line.'
- print *,'if one of your elements has a single point along the absording contour rather than a full edge, do NOT list it'
- print *,'(it would have no weight in the contour integral anyway because it would consist of a single point).'
- print *,'If you are using 9-node elements, list only the first and last points of the edge and not the intermediate point'
- print *,'located around the middle of the edge; the right 9-node curvature will be restored automatically by the code.'
- stop 'only two nodes per element should be listed for absorbing edges'
- endif
- enddo
-
- close(994)
-
- abs_surface(1,:) = abs_surface(1,:) - num_start
- abs_surface(3,:) = abs_surface(3,:) - num_start
- abs_surface(4,:) = abs_surface(4,:) - num_start
-
- end subroutine read_abs_surface
-
-
- !-----------------------------------------------
- ! Creating dual graph (adjacency is defined by 'ncommonnodes' between two elements).
- !-----------------------------------------------
- subroutine mesh2dual_ncommonnodes(elmnts_l,ncommonnodes,xadj,adjncy)
-
- implicit none
- include "constants.h"
-
- integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
- integer, intent(in) :: ncommonnodes
- integer, dimension(0:nelmnts),intent(out) :: xadj
- integer, dimension(0:MAX_NEIGHBORS*nelmnts-1),intent(out) :: adjncy
-
- ! local parameters
- integer :: i, j, k, l, m, num_edges
- logical :: is_neighbour
- integer :: num_node, n
- integer :: elem_base, elem_target
- integer :: connectivity
-
- ! allocates memory for arrays
- if( .not. allocated(nnodes_elmnts) ) allocate(nnodes_elmnts(0:nnodes-1))
- if( .not. allocated(nodes_elmnts) ) allocate(nodes_elmnts(0:nsize*nnodes-1))
-
- ! initializes
- xadj(:) = 0
- adjncy(:) = 0
- nnodes_elmnts(:) = 0
- nodes_elmnts(:) = 0
- num_edges = 0
-
- ! list of elements per node
- do i = 0, NCORNERS*nelmnts-1
- nodes_elmnts(elmnts_l(i)*nsize + nnodes_elmnts(elmnts_l(i))) = i/NCORNERS
- nnodes_elmnts(elmnts_l(i)) = nnodes_elmnts(elmnts_l(i)) + 1
- enddo
-
- ! checking which elements are neighbours ('ncommonnodes' criteria)
- do j = 0, nnodes-1
- do k = 0, nnodes_elmnts(j)-1
- do l = k+1, nnodes_elmnts(j)-1
-
- connectivity = 0
- elem_base = nodes_elmnts(k+j*nsize)
- elem_target = nodes_elmnts(l+j*nsize)
- do n = 1, NCORNERS
- num_node = elmnts_l(NCORNERS*elem_base+n-1)
- do m = 0, nnodes_elmnts(num_node)-1
- if ( nodes_elmnts(m+num_node*nsize) == elem_target ) then
- connectivity = connectivity + 1
- endif
- enddo
- enddo
-
- ! sets adjacency (adjncy) and number of neighbors (xadj)
- ! according to ncommonnodes criteria
- if ( connectivity >= ncommonnodes) then
-
- is_neighbour = .false.
-
- do m = 0, xadj(nodes_elmnts(k+j*nsize))
- if ( .not.is_neighbour ) then
- if ( adjncy(nodes_elmnts(k+j*nsize)*MAX_NEIGHBORS+m) == nodes_elmnts(l+j*nsize) ) then
- is_neighbour = .true.
- endif
- endif
- enddo
- if ( .not.is_neighbour ) then
- adjncy(nodes_elmnts(k+j*nsize)*MAX_NEIGHBORS &
- + xadj(nodes_elmnts(k+j*nsize))) = nodes_elmnts(l+j*nsize)
-
- xadj(nodes_elmnts(k+j*nsize)) = xadj(nodes_elmnts(k+j*nsize)) + 1
- if (xadj(nodes_elmnts(k+j*nsize)) > MAX_NEIGHBORS) &
- stop 'ERROR : too much neighbours per element, modify the mesh.'
-
- adjncy(nodes_elmnts(l+j*nsize)*MAX_NEIGHBORS &
- + xadj(nodes_elmnts(l+j*nsize))) = nodes_elmnts(k+j*nsize)
-
- xadj(nodes_elmnts(l+j*nsize)) = xadj(nodes_elmnts(l+j*nsize)) + 1
- if (xadj(nodes_elmnts(l+j*nsize))>MAX_NEIGHBORS) &
- stop 'ERROR : too much neighbours per element, modify the mesh.'
-
- endif
- endif
- enddo
- enddo
- enddo
-
- ! making adjacency arrays compact (to be used for partitioning)
- do i = 0, nelmnts-1
- k = xadj(i)
- xadj(i) = num_edges
- do j = 0, k-1
- adjncy(num_edges) = adjncy(i*MAX_NEIGHBORS+j)
- num_edges = num_edges + 1
- enddo
- enddo
-
- xadj(nelmnts) = num_edges
-
- end subroutine mesh2dual_ncommonnodes
-
-
- !-----------------------------------------------
- ! Read the weight for each vertices and edges of the graph (not curretly used)
- !-----------------------------------------------
- subroutine read_weights()
-
- implicit none
-
- allocate(vwgt(0:nelmnts-1))
- allocate(adjwgt(0:nb_edges-1))
-
- vwgt(:) = 1
- adjwgt(:) = 1
-
- end subroutine read_weights
-
-
- !--------------------------------------------------
- ! construct local numbering for the elements in each partition
- !--------------------------------------------------
- subroutine Construct_glob2loc_elmnts(nparts)
-
- implicit none
- integer, intent(in) :: nparts
-
- integer :: num_glob, num_part
- integer, dimension(0:nparts-1) :: num_loc
-
-
- allocate(glob2loc_elmnts(0:nelmnts-1))
-
- ! initializes number of local elements per partition
- do num_part = 0, nparts-1
- num_loc(num_part) = 0
- enddo
-
- ! local numbering
- do num_glob = 0, nelmnts-1
- num_part = part(num_glob)
- glob2loc_elmnts(num_glob) = num_loc(num_part)
- num_loc(num_part) = num_loc(num_part) + 1
- enddo
-
- end subroutine Construct_glob2loc_elmnts
-
-
- !--------------------------------------------------
- ! construct local numbering for the nodes in each partition
- !--------------------------------------------------
- subroutine Construct_glob2loc_nodes(nparts)
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: nparts
-
- integer :: num_node
- integer :: el
- integer :: num_part
- integer :: size_glob2loc_nodes
- integer, dimension(0:nparts-1) :: parts_node
- integer, dimension(0:nparts-1) :: num_parts
-
- allocate(glob2loc_nodes_nparts(0:nnodes))
-
- size_glob2loc_nodes = 0
-
- parts_node(:) = 0
-
-
- do num_node = 0, nnodes-1
- glob2loc_nodes_nparts(num_node) = size_glob2loc_nodes
- do el = 0, nnodes_elmnts(num_node)-1
- parts_node(part(nodes_elmnts(el+nsize*num_node))) = 1
- enddo
-
- do num_part = 0, nparts-1
- if ( parts_node(num_part) == 1 ) then
- size_glob2loc_nodes = size_glob2loc_nodes + 1
- parts_node(num_part) = 0
- endif
- enddo
-
- enddo
-
- glob2loc_nodes_nparts(nnodes) = size_glob2loc_nodes
-
- allocate(glob2loc_nodes_parts(0:glob2loc_nodes_nparts(nnodes)-1))
- allocate(glob2loc_nodes(0:glob2loc_nodes_nparts(nnodes)-1))
-
- glob2loc_nodes(0) = 0
-
- parts_node(:) = 0
- num_parts(:) = 0
- size_glob2loc_nodes = 0
-
-
- do num_node = 0, nnodes-1
- do el = 0, nnodes_elmnts(num_node)-1
- parts_node(part(nodes_elmnts(el+nsize*num_node))) = 1
- enddo
- do num_part = 0, nparts-1
-
- if ( parts_node(num_part) == 1 ) then
- glob2loc_nodes_parts(size_glob2loc_nodes) = num_part
- glob2loc_nodes(size_glob2loc_nodes) = num_parts(num_part)
- size_glob2loc_nodes = size_glob2loc_nodes + 1
- num_parts(num_part) = num_parts(num_part) + 1
- parts_node(num_part) = 0
- endif
-
- enddo
- enddo
-
- end subroutine Construct_glob2loc_nodes
-
-
- !--------------------------------------------------
- ! Construct interfaces between each partitions.
- ! Two adjacent elements in distinct partitions make an entry in array tab_interfaces :
- ! 1/ first element, 2/ second element, 3/ number of common nodes, 4/ first node,
- ! 5/ second node, if relevant.
- ! No interface between acoustic, elastic, and poroelastic elements.
- !--------------------------------------------------
- subroutine Construct_interfaces(nparts, elmnts_l, &
- nb_materials, phi_material, num_material)
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: nparts
- integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
- integer, dimension(1:nelmnts), intent(in) :: num_material
- integer, intent(in) :: nb_materials
- double precision, dimension(1:nb_materials), intent(in) :: phi_material
-
- integer :: num_part, num_part_bis, el, el_adj, num_interface, num_edge, ncommon_nodes, &
- num_node, num_node_bis
- integer :: i, j
- logical :: is_acoustic_el, is_acoustic_el_adj, is_elastic_el, is_elastic_el_adj
-
- ninterfaces = 0
- do i = 0, nparts-1
- do j = i+1, nparts-1
- ninterfaces = ninterfaces + 1
- enddo
- enddo
-
- allocate(tab_size_interfaces(0:ninterfaces))
- tab_size_interfaces(:) = 0
-
- num_interface = 0
- num_edge = 0
-
- do num_part = 0, nparts-1
- do num_part_bis = num_part+1, nparts-1
- do el = 0, nelmnts-1
- if ( part(el) == num_part ) then
- ! sets material flag
- if ( phi_material(num_material(el+1)) < TINYVAL) then
- ! elastic element
- is_acoustic_el = .false.
- is_elastic_el = .true.
- elseif ( phi_material(num_material(el+1)) >= 1.d0) then
- ! acoustic element
- is_acoustic_el = .true.
- is_elastic_el = .false.
- else
- ! poroelastic element
- is_acoustic_el = .false.
- is_elastic_el = .false.
- endif
-
- ! looks at all neighbor elements
- do el_adj = xadj_g(el), xadj_g(el+1)-1
- ! sets neighbor material flag
- if ( phi_material(num_material(adjncy_g(el_adj)+1)) < TINYVAL) then
- is_acoustic_el_adj = .false.
- is_elastic_el_adj = .true.
- elseif ( phi_material(num_material(adjncy_g(el_adj)+1)) >= 1.d0) then
- is_acoustic_el_adj = .true.
- is_elastic_el_adj = .false.
- else
- is_acoustic_el_adj = .false.
- is_elastic_el_adj = .false.
- endif
- ! adds element if neighbor element lies in next parition
- ! and belongs to same material
- if ( (part(adjncy_g(el_adj)) == num_part_bis) .and. &
- (is_acoustic_el .eqv. is_acoustic_el_adj) .and. &
- (is_elastic_el .eqv. is_elastic_el_adj) ) then
- num_edge = num_edge + 1
- endif
- enddo
- endif
- enddo
- ! stores number of elements at interface
- tab_size_interfaces(num_interface+1) = tab_size_interfaces(num_interface) + num_edge
- num_edge = 0
- num_interface = num_interface + 1
-
- enddo
- enddo
-
- ! stores element indices for elements from above search at each interface
- num_interface = 0
- num_edge = 0
-
- allocate(tab_interfaces(0:(tab_size_interfaces(ninterfaces)*5-1)))
- tab_interfaces(:) = 0
-
- do num_part = 0, nparts-1
- do num_part_bis = num_part+1, nparts-1
- do el = 0, nelmnts-1
- if ( part(el) == num_part ) then
- if ( phi_material(num_material(el+1)) < TINYVAL) then
- is_acoustic_el = .false.
- is_elastic_el = .true.
- elseif ( phi_material(num_material(el+1)) >= 1.d0) then
- is_acoustic_el = .true.
- is_elastic_el = .false.
- else
- is_acoustic_el = .false.
- is_elastic_el = .false.
- endif
- do el_adj = xadj_g(el), xadj_g(el+1)-1
- if ( phi_material(num_material(adjncy_g(el_adj)+1)) < TINYVAL) then
- is_acoustic_el_adj = .false.
- is_elastic_el_adj = .true.
- elseif ( phi_material(num_material(adjncy_g(el_adj)+1)) >= 1.d0) then
- is_acoustic_el_adj = .true.
- is_elastic_el_adj = .false.
- else
- is_acoustic_el_adj = .false.
- is_elastic_el_adj = .false.
- endif
- if ( (part(adjncy_g(el_adj)) == num_part_bis) .and. &
- (is_acoustic_el .eqv. is_acoustic_el_adj) .and. &
- (is_elastic_el .eqv. is_elastic_el_adj) ) then
- tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+0) = el
- tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+1) = adjncy_g(el_adj)
- ncommon_nodes = 0
- do num_node = 0, 4-1
- do num_node_bis = 0, 4-1
- if ( elmnts_l(el*NCORNERS+num_node) == &
- elmnts_l(adjncy_g(el_adj)*NCORNERS+num_node_bis) ) then
- tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+3+ncommon_nodes) &
- = elmnts_l(el*NCORNERS+num_node)
- ncommon_nodes = ncommon_nodes + 1
- endif
- enddo
- enddo
- if ( ncommon_nodes > 0 ) then
- tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+2) = ncommon_nodes
- else
- print *, "Error while building interfaces!", ncommon_nodes
- stop 'fatal error'
- endif
- num_edge = num_edge + 1
- endif
- enddo
- endif
-
- enddo
- num_edge = 0
- num_interface = num_interface + 1
- enddo
- enddo
-
- end subroutine Construct_interfaces
-
-
- !--------------------------------------------------
- ! Write nodes (their coordinates) pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
- subroutine write_glob2loc_nodes_database(IIN_database, iproc, npgeo, num_phase)
-
- implicit none
-
- integer, intent(in) :: IIN_database
- integer, intent(in) :: iproc, num_phase
- integer, intent(inout) :: npgeo
-
- integer :: i, j
-
- if ( num_phase == 1 ) then
- npgeo = 0
-
- do i = 0, nnodes-1
- do j = glob2loc_nodes_nparts(i), glob2loc_nodes_nparts(i+1)-1
- if ( glob2loc_nodes_parts(j) == iproc ) then
- npgeo = npgeo + 1
- endif
- enddo
- enddo
- else
- do i = 0, nnodes-1
- do j = glob2loc_nodes_nparts(i), glob2loc_nodes_nparts(i+1)-1
- if ( glob2loc_nodes_parts(j) == iproc ) then
- write(IIN_database,*) glob2loc_nodes(j)+1, nodes_coords(1,i+1), nodes_coords(2,i+1)
- endif
- enddo
- enddo
- endif
-
- end subroutine Write_glob2loc_nodes_database
-
-
- !--------------------------------------------------
- ! Write elements (their nodes) pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
- subroutine write_partition_database(IIN_database, iproc, nspec, &
- num_modele, ngnod, num_phase)
-
- implicit none
-
- integer, intent(in) :: IIN_database
- integer, intent(in) :: num_phase, iproc
- integer, intent(inout) :: nspec
- integer, dimension(:) :: num_modele
- integer, intent(in) :: ngnod
-
- integer :: i,j,k
- integer, dimension(0:ngnod-1) :: loc_nodes
-
- if (num_phase == 1) then
-
- nspec = 0
-
- do i = 0, nelmnts-1
- if (part(i) == iproc) nspec = nspec + 1
- enddo
-
- else
- do i = 0, nelmnts-1
- if (part(i) == iproc) then
-
- do j = 0, ngnod-1
- do k = glob2loc_nodes_nparts(elmnts(i*ngnod+j)), glob2loc_nodes_nparts(elmnts(i*ngnod+j)+1)-1
- if (glob2loc_nodes_parts(k) == iproc) loc_nodes(j) = glob2loc_nodes(k)
- enddo
- enddo
- write(IIN_database,*) glob2loc_elmnts(i)+1, num_modele(i+1), (loc_nodes(k)+1, k=0,ngnod-1)
- endif
- enddo
-
- endif
-
- end subroutine write_partition_database
-
-
- !--------------------------------------------------
- ! Write interfaces (element and common nodes) pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
- subroutine Write_interfaces_database(IIN_database, nparts, iproc, &
- my_ninterface, my_interfaces, my_nb_interfaces, num_phase)
-
- implicit none
-
- integer, intent(in) :: IIN_database
- integer, intent(in) :: iproc
- integer, intent(in) :: nparts
- integer, intent(inout) :: my_ninterface
- integer, dimension(0:ninterfaces-1), intent(inout) :: my_interfaces
- integer, dimension(0:ninterfaces-1), intent(inout) :: my_nb_interfaces
-
- integer, dimension(2) :: local_nodes
- integer :: local_elmnt
- integer :: num_phase
-
- integer :: i, j, k, l
- integer :: num_interface
-
- num_interface = 0
-
- if ( num_phase == 1 ) then
-
- my_interfaces(:) = 0
- my_nb_interfaces(:) = 0
-
- do i = 0, nparts-1
- do j = i+1, nparts-1
- if ( (tab_size_interfaces(num_interface) < tab_size_interfaces(num_interface+1)) .and. &
- (i == iproc .or. j == iproc) ) then
- my_interfaces(num_interface) = 1
- my_nb_interfaces(num_interface) = tab_size_interfaces(num_interface+1) &
- - tab_size_interfaces(num_interface)
- endif
- num_interface = num_interface + 1
- enddo
- enddo
- my_ninterface = sum(my_interfaces(:))
-
- else
-
- do i = 0, nparts-1
- do j = i+1, nparts-1
- if ( my_interfaces(num_interface) == 1 ) then
- if ( i == iproc ) then
- write(IIN_database,*) j, my_nb_interfaces(num_interface)
- else
- write(IIN_database,*) i, my_nb_interfaces(num_interface)
- endif
-
- do k = tab_size_interfaces(num_interface), tab_size_interfaces(num_interface+1)-1
- if ( i == iproc ) then
- local_elmnt = glob2loc_elmnts(tab_interfaces(k*5+0))+1
- else
- local_elmnt = glob2loc_elmnts(tab_interfaces(k*5+1))+1
- endif
-
- if ( tab_interfaces(k*5+2) == 1 ) then
- ! common node (single point)
- do l = glob2loc_nodes_nparts(tab_interfaces(k*5+3)), &
- glob2loc_nodes_nparts(tab_interfaces(k*5+3)+1)-1
- if ( glob2loc_nodes_parts(l) == iproc ) then
- local_nodes(1) = glob2loc_nodes(l)+1
- endif
- enddo
-
- write(IIN_database,*) local_elmnt, tab_interfaces(k*5+2), &
- local_nodes(1), -1
- else
- if ( tab_interfaces(k*5+2) == 2 ) then
- ! common edge (two nodes)
- ! first node
- do l = glob2loc_nodes_nparts(tab_interfaces(k*5+3)), &
- glob2loc_nodes_nparts(tab_interfaces(k*5+3)+1)-1
- if ( glob2loc_nodes_parts(l) == iproc ) then
- local_nodes(1) = glob2loc_nodes(l)+1
- endif
- enddo
- ! second node
- do l = glob2loc_nodes_nparts(tab_interfaces(k*5+4)), &
- glob2loc_nodes_nparts(tab_interfaces(k*5+4)+1)-1
- if ( glob2loc_nodes_parts(l) == iproc ) then
- local_nodes(2) = glob2loc_nodes(l)+1
- endif
- enddo
-
- write(IIN_database,*) local_elmnt, tab_interfaces(k*5+2), &
- local_nodes(1), local_nodes(2)
- else
- write(IIN_database,*) "erreur_write_interface_", tab_interfaces(k*5+2)
- endif
- endif
- enddo
-
- endif
-
- num_interface = num_interface + 1
- enddo
- enddo
-
- endif
-
- end subroutine Write_interfaces_database
-
-
- !--------------------------------------------------
- ! Write a surface (elements and nodes on the surface) pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
- subroutine Write_surface_database(IIN_database, nsurface, surface, &
- nsurface_loc, iproc, num_phase)
-
- implicit none
- integer, intent(in) :: IIN_database
- integer, intent(in) :: iproc
- integer :: nsurface
- integer :: nsurface_loc
- integer, dimension(:,:), pointer :: surface
-
- integer, dimension(2) :: local_nodes
- integer :: local_elmnt
- integer :: num_phase
-
- integer :: i, l
-
- if ( num_phase == 1 ) then
-
- nsurface_loc = 0
-
- do i = 1, nsurface
- if ( part(surface(1,i)) == iproc ) then
- nsurface_loc = nsurface_loc + 1
- endif
- enddo
-
- else
-
- nsurface_loc = 0
-
- do i = 1, nsurface
- if ( part(surface(1,i)) == iproc ) then
- nsurface_loc = nsurface_loc + 1
-
- local_elmnt = glob2loc_elmnts(surface(1,i)) + 1
-
- if ( surface(2,i) == 1 ) then
- do l = glob2loc_nodes_nparts(surface(3,i)), &
- glob2loc_nodes_nparts(surface(3,i)+1)-1
- if ( glob2loc_nodes_parts(l) == iproc ) then
- local_nodes(1) = glob2loc_nodes(l)+1
- endif
- enddo
-
- write(IIN_database,*) local_elmnt, surface(2,i), local_nodes(1), -1
- endif
-
- if ( surface(2,i) == 2 ) then
- do l = glob2loc_nodes_nparts(surface(3,i)), &
- glob2loc_nodes_nparts(surface(3,i)+1)-1
- if ( glob2loc_nodes_parts(l) == iproc ) then
- local_nodes(1) = glob2loc_nodes(l)+1
- endif
- enddo
- do l = glob2loc_nodes_nparts(surface(4,i)), &
- glob2loc_nodes_nparts(surface(4,i)+1)-1
- if ( glob2loc_nodes_parts(l) == iproc ) then
- local_nodes(2) = glob2loc_nodes(l)+1
- endif
- enddo
-
- write(IIN_database,*) local_elmnt, surface(2,i), local_nodes(1), local_nodes(2)
- endif
-
- endif
-
- enddo
-
- endif
-
- end subroutine Write_surface_database
-
-
- !--------------------------------------------------
- ! Set absorbing boundaries by elements instead of edges.
- ! Excludes points that have both absorbing condition and coupled fluid/solid relation (this is the
- ! reason arrays ibegin_..., iend_... were included here).
- ! Under development : exluding points that have two different normals in two different elements.
- !--------------------------------------------------
-
- subroutine merge_abs_boundaries(nb_materials, phi_material, num_material, ngnod)
-
- implicit none
- include "constants.h"
-
- integer, intent(in) :: ngnod
- integer :: nb_materials
- double precision, dimension(nb_materials), intent(in) :: phi_material
- integer, dimension(1:nelmnts), intent(in) :: num_material
-
- logical, dimension(nb_materials) :: is_acoustic
- integer :: num_edge, nedge_bound
- integer :: match
- integer :: nb_elmnts_abs
- integer :: i
- integer :: temp
- integer :: iedge, inode1, inode2
-
- allocate(abs_surface_char(4,nelemabs))
- allocate(abs_surface_merge(nelemabs))
- abs_surface_char(:,:) = .false.
- abs_surface_merge(:) = -1
-
- nedge_bound = nelemabs
- nb_elmnts_abs = 0
-
- do num_edge = 1, nedge_bound
-
- match = 0
- do i = 1, nb_elmnts_abs
- if ( abs_surface(1,num_edge) == abs_surface_merge(i) ) then
- match = i
- exit
- endif
- enddo
-
- if ( match == 0 ) then
- nb_elmnts_abs = nb_elmnts_abs + 1
- match = nb_elmnts_abs
- endif
-
- abs_surface_merge(match) = abs_surface(1,num_edge)
-
-
- if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1)) ) then
- abs_surface_char(1,match) = .true.
-
- endif
-
- if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
- abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1)) ) then
- temp = abs_surface(4,num_edge)
- abs_surface(4,num_edge) = abs_surface(3,num_edge)
- abs_surface(3,num_edge) = temp
- abs_surface_char(1,match) = .true.
-
- endif
-
- if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
- abs_surface_char(4,match) = .true.
-
- endif
-
- if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
- abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
- temp = abs_surface(4,num_edge)
- abs_surface(4,num_edge) = abs_surface(3,num_edge)
- abs_surface(3,num_edge) = temp
- abs_surface_char(4,match) = .true.
-
- endif
-
- if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2)) ) then
- abs_surface_char(2,match) = .true.
-
- endif
-
- if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1) .and. &
- abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2)) ) then
- temp = abs_surface(4,num_edge)
- abs_surface(4,num_edge) = abs_surface(3,num_edge)
- abs_surface(3,num_edge) = temp
- abs_surface_char(2,match) = .true.
-
- endif
-
- if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
- temp = abs_surface(4,num_edge)
- abs_surface(4,num_edge) = abs_surface(3,num_edge)
- abs_surface(3,num_edge) = temp
- abs_surface_char(3,match) = .true.
-
- endif
-
- if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2) .and. &
- abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
- abs_surface_char(3,match) = .true.
-
- endif
-
- enddo
-
- nelemabs_merge = nb_elmnts_abs
-
- allocate(ibegin_bottom(nelemabs_merge))
- allocate(iend_bottom(nelemabs_merge))
- allocate(jbegin_right(nelemabs_merge))
- allocate(jend_right(nelemabs_merge))
- allocate(ibegin_top(nelemabs_merge))
- allocate(iend_top(nelemabs_merge))
- allocate(jbegin_left(nelemabs_merge))
- allocate(jend_left(nelemabs_merge))
-
- ibegin_bottom(:) = 1
- jbegin_right(:) = 1
- ibegin_top(:) = 1
- jbegin_left(:) = 1
- iend_bottom(:) = NGLLX
- jend_right(:) = NGLLZ
- iend_top(:) = NGLLX
- jend_left(:) = NGLLZ
-
- is_acoustic(:) = .false.
-
- do i = 1, nb_materials
- if (phi_material(i) >= 1.d0) then
- is_acoustic(i) = .true.
- endif
- enddo
-
- do num_edge = 1, nedge_bound
-
- match = 0
- do i = 1, nelemabs_merge
- if ( abs_surface(1,num_edge) == abs_surface_merge(i) ) then
- match = i
- exit
- endif
- enddo
-
- if ( is_acoustic(num_material(abs_surface(1,num_edge)+1)) ) then
-
- do iedge = 1, nedges_coupled
-
- do inode1 = 0, 3
- if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_coupled(1,iedge)+inode1) ) then
- do inode2 = 0, 3
- if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_coupled(2,iedge)+inode2) ) then
- if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) ) then
- ibegin_bottom(match) = 2
-
- endif
- if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
- jbegin_right(match) = 2
-
- endif
- if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
- ibegin_top(match) = 2
-
- endif
- if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) ) then
- jbegin_left(match) = 2
-
- endif
-
- endif
- enddo
-
- endif
-
- if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_coupled(1,iedge)+inode1) ) then
- do inode2 = 0, 3
- if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_coupled(2,iedge)+inode2) ) then
- if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) ) then
- iend_bottom(match) = NGLLX - 1
-
- endif
- if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
- jend_right(match) = NGLLZ - 1
-
- endif
- if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
- iend_top(match) = NGLLX - 1
-
- endif
- if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
- abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) ) then
- jend_left(match) = NGLLZ - 1
-
- endif
- endif
- enddo
-
- endif
-
- enddo
-
-
- enddo
-
- endif
-
- enddo
-
- end subroutine merge_abs_boundaries
-
-
- !--------------------------------------------------
- ! Write abs surface (elements and nodes on the surface) pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
-
- subroutine write_abs_merge_database(IIN_database, iproc, num_phase)
-
- implicit none
-
- integer, intent(in) :: IIN_database
- integer, intent(in) :: iproc
- integer, intent(in) :: num_phase
-
- integer :: i
-
- if ( num_phase == 1 ) then
- nelemabs_loc = 0
- do i = 1, nelemabs_merge
- if ( part(abs_surface_merge(i)) == iproc ) then
- nelemabs_loc = nelemabs_loc + 1
- endif
- enddo
- else
- do i = 1, nelemabs_merge
- if ( part(abs_surface_merge(i)) == iproc ) then
-
- write(IIN_database,*) glob2loc_elmnts(abs_surface_merge(i))+1, abs_surface_char(1,i), &
- abs_surface_char(2,i), abs_surface_char(3,i), abs_surface_char(4,i), &
- ibegin_bottom(i), iend_bottom(i), &
- jbegin_right(i), jend_right(i), &
- ibegin_top(i), iend_top(i), &
- jbegin_left(i), jend_left(i)
-
- endif
-
- enddo
- endif
-
- end subroutine write_abs_merge_database
-
-
-!! DK DK support for METIS now removed, we use SCOTCH instead
-!#ifdef USE_METIS
-! !--------------------------------------------------
-! ! Partitioning using METIS
-! !--------------------------------------------------
-! subroutine Part_metis(nelmnts, xadj, adjncy, vwgt, adjwgt, nparts, nb_edges, edgecut, part, metis_options)
-!
-! include "constants.h"
-!
-! integer, intent(in) :: nelmnts, nparts, nb_edges
-! integer, intent(inout) :: edgecut
-! integer, dimension(0:nelmnts), intent(in) :: xadj
-! integer, dimension(0:MAX_NEIGHBORS*nelmnts-1), intent(in) :: adjncy
-! integer, dimension(0:nelmnts-1), intent(in) :: vwgt
-! integer, dimension(0:nb_edges-1), intent(in) :: adjwgt
-! integer, dimension(:), pointer :: part
-! integer, dimension(0:4) :: metis_options
-!
-! integer :: wgtflag
-! integer :: num_start
-!
-! num_start = 0
-! wgtflag = 0
-!
-! call METIS_PartGraphRecursive(nelmnts, xadj(0), adjncy(0), vwgt(0), adjwgt(0), wgtflag, num_start, nparts, &
-! metis_options, edgecut, part(0));
-! !call METIS_PartGraphVKway(nelmnts, xadj(0), adjncy(0), vwgt(0), adjwgt(0), wgtflag, num_start, nparts, &
-! ! options, edgecut, part(0));
-!
-! end subroutine Part_metis
-!#endif
-
-
-#ifdef USE_SCOTCH
- !--------------------------------------------------
- ! Partitioning using SCOTCH
- !--------------------------------------------------
- subroutine Part_scotch(nparts, edgecut)
-
- implicit none
- include "constants.h"
-
- include "scotchf.h"
-
- integer, intent(in) :: nparts
- integer, intent(inout) :: edgecut
-
- double precision, dimension(SCOTCH_GRAPHDIM) :: SCOTCHGRAPH
- double precision, dimension(SCOTCH_STRATDIM) :: SCOTCHSTRAT
- integer :: IERR
-
- edgecut = vwgt(0)
- edgecut = 0
-
- ! we use default strategy for partitioning, thus omit specifing explicit strategy .
- call scotchfstratinit (SCOTCHSTRAT(1), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot initialize strat'
- STOP
- ENDIF
-
- CALL SCOTCHFGRAPHINIT (SCOTCHGRAPH (1), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot initialize graph'
- STOP
- ENDIF
-
- ! fills graph structure : see user manual (scotch_user5.1.pdf, page 72/73)
- ! arguments: #(1) graph_structure #(2) baseval(either 0/1) #(3) number_of_vertices
- ! #(4) adjacency_index_array #(5) adjacency_end_index_array (optional)
- ! #(6) vertex_load_array (optional) #(7) vertex_label_array
- ! #(7) number_of_arcs #(8) adjacency_array
- ! #(9) arc_load_array (optional) #(10) ierror
- CALL SCOTCHFGRAPHBUILD (SCOTCHGRAPH (1), 0, nelmnts, &
- xadj_g(0), xadj_g(0), &
- xadj_g(0), xadj_g(0), &
- nb_edges, &
- adjncy_g(0), adjwgt (0), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot build graph'
- STOP
- ENDIF
-
- CALL SCOTCHFGRAPHCHECK (SCOTCHGRAPH (1), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Invalid check'
- STOP
- ENDIF
-
- call scotchfgraphpart (SCOTCHGRAPH (1), nparts, SCOTCHSTRAT(1), part(0), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot part graph'
- STOP
- ENDIF
-
- CALL SCOTCHFGRAPHEXIT (SCOTCHGRAPH (1), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot destroy graph'
- STOP
- ENDIF
-
- call scotchfstratexit (SCOTCHSTRAT(1), IERR)
- IF (IERR .NE. 0) THEN
- PRINT *, 'ERROR : MAIN : Cannot destroy strat'
- STOP
- ENDIF
-
- end subroutine Part_scotch
-#endif
-
-
- !--------------------------------------------------
- ! Repartitioning : two coupled acoustic/elastic elements are transfered to the same partition
- !--------------------------------------------------
-
- subroutine acoustic_elastic_repartitioning (elmnts_l, nb_materials, &
- phi_material, num_material, nproc)
-
- implicit none
- include "constants.h"
-
- integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
- integer, intent(in) :: nproc, nb_materials
- double precision, dimension(nb_materials), intent(in) :: phi_material
- integer, dimension(1:nelmnts), intent(in) :: num_material
-
- ! local parameters
- integer, dimension(:), allocatable :: xadj_l
- integer, dimension(:), allocatable :: adjncy_l
- logical, dimension(nb_materials) :: is_acoustic, is_elastic
- integer :: i, num_edge
- integer :: el, el_adj
- logical :: is_repartitioned
-
- allocate(xadj_l(0:nelmnts))
- allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
-
- is_acoustic(:) = .false.
- is_elastic(:) = .false.
-
- do i = 1, nb_materials
- if (phi_material(i) >= 1.d0) then
- is_acoustic(i) = .true.
- endif
- if (phi_material(i) < TINYVAL) then
- is_elastic(i) = .true.
- endif
- enddo
-
- ! determines maximum neighbors based on 2 common nodes (common edge)
- call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
-
- nedges_coupled = 0
- do el = 0, nelmnts-1
- if ( is_acoustic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_coupled = nedges_coupled + 1
- endif
- enddo
- endif
- enddo
-
- allocate(edges_coupled(2,nedges_coupled))
-
- nedges_coupled = 0
- do el = 0, nelmnts-1
- if ( is_acoustic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_coupled = nedges_coupled + 1
- edges_coupled(1,nedges_coupled) = el
- edges_coupled(2,nedges_coupled) = adjncy_l(el_adj)
- endif
-
- enddo
- endif
- enddo
-
- do i = 1, nedges_coupled*nproc
- is_repartitioned = .false.
- do num_edge = 1, nedges_coupled
- if ( part(edges_coupled(1,num_edge)) /= part(edges_coupled(2,num_edge)) ) then
- if ( part(edges_coupled(1,num_edge)) < part(edges_coupled(2,num_edge)) ) then
- part(edges_coupled(2,num_edge)) = part(edges_coupled(1,num_edge))
- else
- part(edges_coupled(1,num_edge)) = part(edges_coupled(2,num_edge))
- endif
- is_repartitioned = .true.
- endif
-
- enddo
- if ( .not. is_repartitioned ) then
- exit
- endif
- enddo
-
- deallocate(xadj_l,adjncy_l)
-
- end subroutine acoustic_elastic_repartitioning
-
-
- !--------------------------------------------------
- ! Repartitioning : two coupled acoustic/poroelastic elements are transfered to the same partition
- !--------------------------------------------------
-
- subroutine acoustic_poro_repartitioning (elmnts_l, nb_materials, &
- phi_material, num_material, nproc)
-
- implicit none
- include "constants.h"
-
- integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
- integer, intent(in) :: nproc, nb_materials
- double precision, dimension(nb_materials), intent(in) :: phi_material
- integer, dimension(1:nelmnts), intent(in) :: num_material
-
- ! local parameters
- integer, dimension(:), allocatable :: xadj_l
- integer, dimension(:), allocatable :: adjncy_l
- logical, dimension(nb_materials) :: is_acoustic,is_poroelastic
- integer :: i, num_edge
- integer :: el, el_adj
- logical :: is_repartitioned
-
- allocate(xadj_l(0:nelmnts))
- allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
-
- is_acoustic(:) = .false.
- is_poroelastic(:) = .false.
-
- do i = 1, nb_materials
- if (phi_material(i) >=1.d0) then
- is_acoustic(i) = .true.
- endif
- if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
- is_poroelastic(i) = .true.
- endif
- enddo
-
- ! determines maximum neighbors based on 2 common nodes (common edge)
- call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
-
- nedges_acporo_coupled = 0
- do el = 0, nelmnts-1
- if ( is_acoustic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_poroelastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_acporo_coupled = nedges_acporo_coupled + 1
- endif
-
- enddo
- endif
- enddo
-
- print *, 'nedges_coupled (acoustic/poroelastic)', nedges_acporo_coupled
-
- allocate(edges_acporo_coupled(2,nedges_acporo_coupled))
-
- nedges_acporo_coupled = 0
- do el = 0, nelmnts-1
- if ( is_acoustic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_poroelastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_acporo_coupled = nedges_acporo_coupled + 1
- edges_acporo_coupled(1,nedges_acporo_coupled) = el
- edges_acporo_coupled(2,nedges_acporo_coupled) = adjncy_l(el_adj)
- endif
-
- enddo
- endif
- enddo
-
- do i = 1, nedges_acporo_coupled*nproc
- is_repartitioned = .false.
- do num_edge = 1, nedges_acporo_coupled
- if ( part(edges_acporo_coupled(1,num_edge)) /= part(edges_acporo_coupled(2,num_edge)) ) then
- if ( part(edges_acporo_coupled(1,num_edge)) < part(edges_acporo_coupled(2,num_edge)) ) then
- part(edges_acporo_coupled(2,num_edge)) = part(edges_acporo_coupled(1,num_edge))
- else
- part(edges_acporo_coupled(1,num_edge)) = part(edges_acporo_coupled(2,num_edge))
- endif
- is_repartitioned = .true.
- endif
-
- enddo
- if ( .not. is_repartitioned ) then
- exit
- endif
- enddo
-
- deallocate(xadj_l,adjncy_l)
-
- end subroutine acoustic_poro_repartitioning
-
-
- !--------------------------------------------------
- ! Repartitioning : two coupled poroelastic/elastic elements are transfered to the same partition
- !--------------------------------------------------
-
- subroutine poro_elastic_repartitioning (elmnts_l, nb_materials, &
- phi_material, num_material, nproc)
-
- implicit none
- include "constants.h"
-
- integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
- integer, intent(in) :: nproc, nb_materials
- double precision, dimension(nb_materials), intent(in) :: phi_material
- integer, dimension(1:nelmnts), intent(in) :: num_material
-
- ! local parameters
- integer, dimension(:), allocatable :: xadj_l
- integer, dimension(:), allocatable :: adjncy_l
- logical, dimension(nb_materials) :: is_elastic,is_poroelastic
- integer :: i, num_edge
- integer :: el, el_adj
- logical :: is_repartitioned
-
- allocate(xadj_l(0:nelmnts))
- allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
-
- is_elastic(:) = .false.
- is_poroelastic(:) = .false.
-
- do i = 1, nb_materials
- if (phi_material(i) < TINYVAL) then
- is_elastic(i) = .true.
- endif
- if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
- is_poroelastic(i) = .true.
- endif
- enddo
-
- ! determines maximum neighbors based on 2 common nodes (common edge)
- call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
-
- nedges_elporo_coupled = 0
- do el = 0, nelmnts-1
- if ( is_poroelastic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_elporo_coupled = nedges_elporo_coupled + 1
- endif
-
- enddo
- endif
- enddo
-
- print *, 'nedges_coupled (poroelastic/elastic)', nedges_elporo_coupled
-
- allocate(edges_elporo_coupled(2,nedges_elporo_coupled))
-
- nedges_elporo_coupled = 0
- do el = 0, nelmnts-1
- if ( is_poroelastic(num_material(el+1)) ) then
- do el_adj = xadj_l(el), xadj_l(el+1) - 1
- if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
- nedges_elporo_coupled = nedges_elporo_coupled + 1
- edges_elporo_coupled(1,nedges_elporo_coupled) = el
- edges_elporo_coupled(2,nedges_elporo_coupled) = adjncy_l(el_adj)
- endif
-
- enddo
- endif
- enddo
-
- do i = 1, nedges_elporo_coupled*nproc
- is_repartitioned = .false.
- do num_edge = 1, nedges_elporo_coupled
- if ( part(edges_elporo_coupled(1,num_edge)) /= part(edges_elporo_coupled(2,num_edge)) ) then
- if ( part(edges_elporo_coupled(1,num_edge)) < part(edges_elporo_coupled(2,num_edge)) ) then
- part(edges_elporo_coupled(2,num_edge)) = part(edges_elporo_coupled(1,num_edge))
- else
- part(edges_elporo_coupled(1,num_edge)) = part(edges_elporo_coupled(2,num_edge))
- endif
- is_repartitioned = .true.
- endif
-
- enddo
- if ( .not. is_repartitioned ) then
- exit
- endif
- enddo
-
- deallocate(xadj_l,adjncy_l)
-
- end subroutine poro_elastic_repartitioning
-
-
- !--------------------------------------------------
- ! Write fluid/solid edges (fluid (or porous) elements and corresponding solid (or porous) elements)
- ! pertaining to iproc partition in the corresponding Database
- !--------------------------------------------------
-
- subroutine write_fluidsolid_edges_database(IIN_database, nedges_coupled_bis, nedges_coupled_loc_bis, &
- edges_coupled_bis, iproc, num_phase)
-
- implicit none
-
- integer, intent(in) :: IIN_database
- integer, intent(in) :: nedges_coupled_bis
- integer, intent(inout) :: nedges_coupled_loc_bis
- integer, dimension(:,:), pointer :: edges_coupled_bis
- integer, intent(in) :: iproc
- integer, intent(in) :: num_phase
-
- integer :: i
-
- if ( num_phase == 1 ) then
- nedges_coupled_loc_bis = 0
- do i = 1, nedges_coupled_bis
- if ( part(edges_coupled_bis(1,i)) == iproc ) then
- nedges_coupled_loc_bis = nedges_coupled_loc_bis + 1
- endif
- enddo
- else
- do i = 1, nedges_coupled_bis
- if ( part(edges_coupled_bis(1,i)) == iproc ) then
- write(IIN_database,*) glob2loc_elmnts(edges_coupled_bis(1,i))+1, glob2loc_elmnts(edges_coupled_bis(2,i))+1
- endif
- enddo
- endif
-
- end subroutine write_fluidsolid_edges_database
-
-end module part_unstruct
Deleted: seismo/2D/SPECFEM2D/trunk/plotgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/plotgll.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/plotgll.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,258 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
-
-! output the Gauss-Lobatto-Legendre mesh in a gnuplot file
-
- implicit none
-
- include "constants.h"
-
- integer ispec,iy,ix,iglobnum,iglobnum2,ibloc,inode,npoin,npgeo,ngnod,nspec
-
- integer knods(ngnod,nspec),ibool(NGLLX,NGLLX,nspec)
-
- double precision coorg(NDIM,npgeo),coord(NDIM,npoin)
-
-! coordinates of the nodes for Gnuplot file
- integer, parameter :: MAXNGNOD = 9
- double precision xval(MAXNGNOD),zval(MAXNGNOD)
-
- character(len=70) name
-
-!
-!---- output the GLL mesh in a Gnuplot file
-!
-
- write(iout,*)
- write(iout,*) 'Generating gnuplot meshes...'
- write(iout,*)
-
-! create non empty files for the case of 4-node elements
-
- name='macros1.gnu'
- open(unit=30,file=name,status='unknown')
-
- name='macros2.gnu'
- open(unit=31,file=name,status='unknown')
- write(31,"('')")
-
- name='gllmesh1.gnu'
- open(unit=20,file=name,status='unknown')
-
- name='gllmesh2.gnu'
- open(unit=21,file=name,status='unknown')
- write(21,"('')")
-
- do ispec = 1,nspec
-
-!
-!---- plot the lines in xi-direction
-!
- do iy = 1,NGLLZ
- do ix = 1,NGLLX-1
-!
-!---- get the global point number
-!
- iglobnum = ibool(ix,iy,ispec)
-!
-!---- do the same for next point on horizontal line
-!
- iglobnum2 = ibool(ix+1,iy,ispec)
-
- write(20,*) coord(1,iglobnum),coord(2,iglobnum)
- write(20,*) coord(1,iglobnum2),coord(2,iglobnum2)
- write(20,"('')")
-
- if(iy == 1 .or. iy == NGLLZ) then
- write(21,*) coord(1,iglobnum),coord(2,iglobnum)
- write(21,*) coord(1,iglobnum2),coord(2,iglobnum2)
- write(21,"('')")
- endif
-
- enddo
- enddo
-
-!
-!---- plot the lines in eta-direction
-!
- do ix = 1,NGLLX
- do iy = 1,NGLLZ-1
-!
-!---- get the global point number
-!
- iglobnum = ibool(ix,iy,ispec)
-!
-!---- do the same for next point on vertical line
-!
- iglobnum2 = ibool(ix,iy+1,ispec)
-
- write(20,*) coord(1,iglobnum),coord(2,iglobnum)
- write(20,*) coord(1,iglobnum2),coord(2,iglobnum2)
- write(20,"('')")
-
- if(ix == 1 .or. ix == NGLLX) then
- write(21,*) coord(1,iglobnum),coord(2,iglobnum)
- write(21,*) coord(1,iglobnum2),coord(2,iglobnum2)
- write(21,"('')")
- endif
-
- enddo
- enddo
- enddo
-
-!
-!---- plot the macrobloc mesh using Gnuplot
-!
- do ibloc = 1,nspec
- do inode = 1,ngnod
-
- xval(inode) = coorg(1,knods(inode,ibloc))
- zval(inode) = coorg(2,knods(inode,ibloc))
-
- enddo
-
- if(ngnod == 4) then
-!
-!---- 4-node rectangular element
-!
-
-! draw the edges of the element using one color
- write(30,*) xval(1),zval(1)
- write(30,*) xval(2),zval(2)
- write(30,"('')")
- write(30,*) xval(2),zval(2)
- write(30,*) xval(3),zval(3)
- write(30,"('')")
- write(30,*) xval(3),zval(3)
- write(30,*) xval(4),zval(4)
- write(30,"('')")
- write(30,*) xval(4),zval(4)
- write(30,*) xval(1),zval(1)
- write(30,"('')")
-
- else
-
-!
-!---- 9-node rectangular element
-!
-
-! draw the edges of the element using one color
- write(30,*) xval(1),zval(1)
- write(30,*) xval(5),zval(5)
- write(30,"('')")
- write(30,*) xval(5),zval(5)
- write(30,*) xval(2),zval(2)
- write(30,"('')")
- write(30,*) xval(2),zval(2)
- write(30,*) xval(6),zval(6)
- write(30,"('')")
- write(30,*) xval(6),zval(6)
- write(30,*) xval(3),zval(3)
- write(30,"('')")
- write(30,*) xval(3),zval(3)
- write(30,*) xval(7),zval(7)
- write(30,"('')")
- write(30,*) xval(7),zval(7)
- write(30,*) xval(4),zval(4)
- write(30,"('')")
- write(30,*) xval(4),zval(4)
- write(30,*) xval(8),zval(8)
- write(30,"('')")
- write(30,*) xval(8),zval(8)
- write(30,*) xval(1),zval(1)
- write(30,"('')")
-
-! draw middle lines using another color
- write(31,*) xval(5),zval(5)
- write(31,*) xval(9),zval(9)
- write(31,"('')")
- write(31,*) xval(9),zval(9)
- write(31,*) xval(7),zval(7)
- write(31,"('')")
- write(31,*) xval(8),zval(8)
- write(31,*) xval(9),zval(9)
- write(31,"('')")
- write(31,*) xval(9),zval(9)
- write(31,*) xval(6),zval(6)
- write(31,"('')")
-
- endif
-
- enddo
-
- close(20)
- close(21)
-
- close(30)
- close(31)
-
-!
-!---- generate the command file for Gnuplot
-!
- open(unit=20,file='plotall_gll_mesh.gnu',status='unknown')
- write(20,*) 'set term x11'
- write(20,*) '# set term postscript landscape color solid "Helvetica" 22'
- write(20,*) '# set output "gll_mesh.ps"'
- write(20,*) 'set xlabel "X"'
- write(20,*) 'set ylabel "Y"'
- write(20,*) 'set title "Gauss-Lobatto-Legendre Mesh"'
- write(20,*) 'plot "gllmesh1.gnu" title '''' w l 2, "gllmesh2.gnu" title '''' w linesp 1 3'
- write(20,*) 'pause -1 "Hit any key to exit..."'
- close(20)
-
- open(unit=20,file='plotall_macro_mesh.gnu',status='unknown')
- write(20,*) 'set term x11'
- write(20,*) '# set term postscript landscape color solid "Helvetica" 22'
- write(20,*) '# set output "macro_mesh.ps"'
- write(20,*) 'set xlabel "X"'
- write(20,*) 'set ylabel "Y"'
- write(20,*) 'set title "Spectral Element (Macrobloc) Mesh"'
- write(20,*) 'plot "macros2.gnu" title '''' w l 2, "macros1.gnu" title '''' w linesp 1 3'
- write(20,*) 'pause -1 "Hit any key to exit..."'
- close(20)
-
- end subroutine plotgll
-
Deleted: seismo/2D/SPECFEM2D/trunk/plotpost.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/plotpost.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/plotpost.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,3070 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine plotpost(displ,coord,vpext,x_source,z_source,st_xval,st_zval,it,dt,coorg, &
- xinterp,zinterp,shapeint,Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
- poroelastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs,nelem_acoustic_surface, acoustic_edges, &
- simulation_title,npoin,npgeo,vpmin,vpmax,nrec,NSOURCES, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
- any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
- fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
- solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
- myrank,nproc,ier, &
- d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
- d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
- d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
- d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
- coorg_send_ps_velocity_model,RGB_send_ps_velocity_model, &
- coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model,&
- d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
- d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
- d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
- coorg_send_ps_element_mesh,color_send_ps_element_mesh, &
- coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
- d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs, &
- d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
- coorg_send_ps_abs,coorg_recv_ps_abs, &
- d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface, &
- d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
- coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
- d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field, &
- d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
- coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
-
-!
-! PostScript display routine
-!
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include 'mpif.h'
-#endif
-
-! color palette
- integer, parameter :: NUM_COLORS = 236
- double precision, dimension(NUM_COLORS) :: red,green,blue
-
- integer it,nrec,nelemabs,numat,pointsdisp,pointsdisp_loop,nspec
- integer i,npoin,npgeo,ngnod,NSOURCES
-
- integer kmato(nspec),knods(ngnod,nspec)
- integer ibool(NGLLX,NGLLZ,nspec)
-
- double precision xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
- double precision shapeint(ngnod,pointsdisp,pointsdisp)
- double precision Uxinterp(pointsdisp,pointsdisp)
- double precision Uzinterp(pointsdisp,pointsdisp)
- double precision flagrange(NGLLX,pointsdisp)
- double precision density(2,numat),poroelastcoef(4,3,numat),porosity(numat),tortuosity(numat)
-
- double precision dt,timeval
- double precision, dimension(NSOURCES) :: x_source,z_source
- double precision displ(3,npoin),coord(NDIM,npoin)
- double precision vpext(NGLLX,NGLLZ,nspec)
-
- double precision coorg(NDIM,npgeo)
- double precision, dimension(nrec) :: st_xval,st_zval
-
- integer numabs(nelemabs),codeabs(4,nelemabs)
- logical anyabs,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
- any_acoustic,any_poroelastic,plot_lowerleft_corner_only
-
-! for fluid/solid edge detection
- integer :: num_fluid_solid_edges,num_fluid_poro_edges,num_solid_poro_edges
- integer, dimension(num_fluid_solid_edges) :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge
- integer, dimension(num_fluid_poro_edges) :: fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge
- integer, dimension(num_solid_poro_edges) :: solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge
-
- double precision xmax,zmax,height,xw,zw,usoffset,sizex,sizez,vpmin,vpmax
-
-! for the file name
- character(len=100) :: file_name
-
-! to suppress useless white spaces in postscript lines
- character(len=100) :: postscript_line
- character(len=1), dimension(100) :: ch1,ch2
- equivalence (postscript_line,ch1)
- logical :: first
-
- double precision convert,x1,cpIloc,xa,za,xb,zb
- double precision z1,x2,z2,d,d1,d2,dummy,theta,thetaup,thetadown
-
- double precision :: mul_s,kappal_s,rhol_s
- double precision :: kappal_f,rhol_f
- double precision :: mul_fr,kappal_fr,phil,tortl
- double precision :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,rhol_bar
- double precision :: cpIsquare
-
- integer k,j,ispec,material,is,ir,imat,icol,l,line_length
- integer index_char,ii,ipoin,in,nnum,inum,ideb,ifin,iedge
-
- integer colors,numbers,subsamp,imagetype
- logical interpol,meshvect,modelvect,boundvect,assign_external_model
- double precision cutsnaps,sizemax_arrows
-
- double precision ratio_page,dispmax,xmin,zmin
-
-! title of the plot
- character(len=60) simulation_title
-
-! for free surface output
- integer :: nelem_acoustic_surface
- integer, dimension(4,max(1,nelem_acoustic_surface)) :: acoustic_edges
-
-#ifdef USE_MPI
- double precision :: xmin_glob, xmax_glob, zmin_glob, zmax_glob
- double precision :: dispmax_glob
-#endif
-
- double precision, dimension(:,:), allocatable :: coorg_send
- double precision, dimension(:,:), allocatable :: coorg_recv
- integer :: nspec_recv
- integer :: buffer_offset, RGB_offset
-
- integer :: nb_coorg_per_elem, nb_color_per_elem
- integer :: iproc, num_spec
- integer :: ier
- logical :: anyabs_glob, coupled_acoustic_elastic_glob, coupled_acoustic_poro_glob, &
- coupled_elastic_poro_glob
-#ifdef USE_MPI
- integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
-#endif
- integer :: myrank, nproc
-
-! plotpost arrays for postscript output
- integer :: d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
- d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
- d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
- d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model
- double precision, dimension(d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model) :: &
-coorg_send_ps_velocity_model
- double precision, dimension(d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model) :: &
-coorg_recv_ps_velocity_model
- double precision, dimension(d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model) :: &
-RGB_send_ps_velocity_model
- double precision, dimension(d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model) :: &
-RGB_recv_ps_velocity_model
- integer :: d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
- d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
- d1_color_send_ps_element_mesh, &
- d1_color_recv_ps_element_mesh
- double precision, dimension(d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh) :: &
-coorg_send_ps_element_mesh
- double precision, dimension(d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh) :: &
-coorg_recv_ps_element_mesh
- integer, dimension(d1_color_send_ps_element_mesh) :: &
-color_send_ps_element_mesh
- integer, dimension(d1_color_recv_ps_element_mesh) :: &
-color_recv_ps_element_mesh
- integer :: d1_coorg_send_ps_abs, d1_coorg_recv_ps_abs, &
- d2_coorg_send_ps_abs, d2_coorg_recv_ps_abs
- double precision, dimension(d1_coorg_send_ps_abs,d2_coorg_send_ps_abs) :: &
-coorg_send_ps_abs
- double precision, dimension(d1_coorg_recv_ps_abs,d2_coorg_recv_ps_abs) :: &
-coorg_recv_ps_abs
- integer :: d1_coorg_send_ps_free_surface, d1_coorg_recv_ps_free_surface, &
- d2_coorg_send_ps_free_surface, d2_coorg_recv_ps_free_surface
- double precision, dimension(d1_coorg_send_ps_free_surface,d2_coorg_send_ps_free_surface) :: &
-coorg_send_ps_free_surface
- double precision, dimension(d1_coorg_recv_ps_free_surface,d2_coorg_recv_ps_free_surface) :: &
-coorg_recv_ps_free_surface
- integer :: d1_coorg_send_ps_vector_field, d1_coorg_recv_ps_vector_field, &
- d2_coorg_send_ps_vector_field, d2_coorg_recv_ps_vector_field
- double precision, dimension(d1_coorg_send_ps_vector_field,d2_coorg_send_ps_vector_field) :: &
-coorg_send_ps_vector_field
- double precision, dimension(d1_coorg_recv_ps_vector_field,d2_coorg_recv_ps_vector_field) :: &
-coorg_recv_ps_vector_field
-
-#ifndef USE_MPI
-! this to avoid warnings by the compiler about unused variables in the case
-! of a serial code, therefore use them once and do nothing: just set them to zero
- nspec_recv = 0
- nb_coorg_per_elem = 0
- nb_color_per_elem = 0
- ier = 0
- num_spec = 0
- iproc = nproc
- coorg_recv_ps_velocity_model = 0
- RGB_recv_ps_velocity_model = 0
- coorg_recv_ps_element_mesh = 0
- color_recv_ps_element_mesh = 0
- coorg_recv_ps_abs = 0
- coorg_recv_ps_free_surface = 0
- coorg_recv_ps_vector_field = 0
- allocate(coorg_recv(1,1))
- deallocate(coorg_recv)
-#endif
-
-! A4 or US letter paper
- if(US_LETTER) then
- usoffset = 1.75d0
- sizex = 27.94d0
- sizez = 21.59d0
- else
- usoffset = 0.d0
- sizex = 29.7d0
- sizez = 21.d0
- endif
-
-! height of domain numbers in centimeters
- height = 0.25d0
-
-! define color palette in random order
-
-! red
- red(1) = 1.00000000000000
- green(1) = 0.000000000000000E+000
- blue(1) = 0.000000000000000E+000
-
-! DodgerBlue2
- red(2) = 0.109803921568627
- green(2) = 0.525490196078431
- blue(2) = 0.933333333333333
-
-! gold
- red(3) = 1.00000000000000
- green(3) = 0.840000000000000
- blue(3) = 0.000000000000000E+000
-
-! springgreen
- red(4) = 0.000000000000000E+000
- green(4) = 1.00000000000000
- blue(4) = 0.500000000000000
-
-! NavajoWhite
- red(5) = 1.00000000000000
- green(5) = 0.870588235294118
- blue(5) = 0.678431372549020
-
-! SteelBlue3
- red(6) = 0.309803921568627
- green(6) = 0.580392156862745
- blue(6) = 0.803921568627451
-
-! Ivory3
- red(7) = 0.803921568627451
- green(7) = 0.803921568627451
- blue(7) = 0.756862745098039
-
-! SkyBlue4
- red(8) = 0.290196078431373
- green(8) = 0.439215686274510
- blue(8) = 0.545098039215686
-
-! Snow
- red(9) = 0.980392156862745
- green(9) = 0.980392156862745
- blue(9) = 0.980392156862745
-
-! SteelBlue
- red(10) = 0.274509803921569
- green(10) = 0.509803921568627
- blue(10) = 0.705882352941177
-
-! Bisque3
- red(11) = 0.803921568627451
- green(11) = 0.717647058823529
- blue(11) = 0.619607843137255
-
-! Salmon
- red(12) = 0.980392156862745
- green(12) = 0.501960784313725
- blue(12) = 0.447058823529412
-
-! SlateBlue2
- red(13) = 0.478431372549020
- green(13) = 0.403921568627451
- blue(13) = 0.933333333333333
-
-! NavajoWhite2
- red(14) = 0.933333333333333
- green(14) = 0.811764705882353
- blue(14) = 0.631372549019608
-
-! MediumBlue
- red(15) = 0.000000000000000E+000
- green(15) = 0.000000000000000E+000
- blue(15) = 0.803921568627451
-
-! LightCoral
- red(16) = 0.941176470588235
- green(16) = 0.501960784313725
- blue(16) = 0.501960784313725
-
-! FloralWhite
- red(17) = 1.00000000000000
- green(17) = 0.980392156862745
- blue(17) = 0.941176470588235
-
-! Cornsilk3
- red(18) = 0.803921568627451
- green(18) = 0.784313725490196
- blue(18) = 0.694117647058824
-
-! GhostWhite
- red(19) = 0.972549019607843
- green(19) = 0.972549019607843
- blue(19) = 1.00000000000000
-
-! blue
- red(20) = 0.000000000000000E+000
- green(20) = 0.000000000000000E+000
- blue(20) = 1.00000000000000
-
-! Linen
- red(21) = 0.980392156862745
- green(21) = 0.941176470588235
- blue(21) = 0.901960784313726
-
-! peachpuff
- red(22) = 1.00000000000000
- green(22) = 0.850000000000000
- blue(22) = 0.730000000000000
-
-! Cornsilk1
- red(23) = 1.00000000000000
- green(23) = 0.972549019607843
- blue(23) = 0.862745098039216
-
-! LightSalmon
- red(24) = 1.00000000000000
- green(24) = 0.627450980392157
- blue(24) = 0.478431372549020
-
-! DeepSkyBlue1
- red(25) = 0.000000000000000E+000
- green(25) = 0.749019607843137
- blue(25) = 1.00000000000000
-
-! LemonChiffon4
- red(26) = 0.545098039215686
- green(26) = 0.537254901960784
- blue(26) = 0.439215686274510
-
-! PeachPuff1
- red(27) = 1.00000000000000
- green(27) = 0.854901960784314
- blue(27) = 0.725490196078431
-
-! BlanchedAlmond
- red(28) = 1.00000000000000
- green(28) = 0.921568627450980
- blue(28) = 0.803921568627451
-
-! SlateBlue3
- red(29) = 0.411764705882353
- green(29) = 0.349019607843137
- blue(29) = 0.803921568627451
-
-! LightSkyBlue1
- red(30) = 0.690196078431373
- green(30) = 0.886274509803922
- blue(30) = 1.00000000000000
-
-! DarkViolet
- red(31) = 0.580392156862745
- green(31) = 0.000000000000000E+000
- blue(31) = 0.827450980392157
-
-! Azure3
- red(32) = 0.756862745098039
- green(32) = 0.803921568627451
- blue(32) = 0.803921568627451
-
-! LavenderBlush3
- red(33) = 0.803921568627451
- green(33) = 0.756862745098039
- blue(33) = 0.772549019607843
-
-! Honeydew1
- red(34) = 0.941176470588235
- green(34) = 1.00000000000000
- blue(34) = 0.941176470588235
-
-! Ivory2
- red(35) = 0.933333333333333
- green(35) = 0.933333333333333
- blue(35) = 0.878431372549020
-
-! RosyBrown
- red(36) = 0.737254901960784
- green(36) = 0.560784313725490
- blue(36) = 0.560784313725490
-
-! Thistle
- red(37) = 0.847058823529412
- green(37) = 0.749019607843137
- blue(37) = 0.847058823529412
-
-! Orange
- red(38) = 1.00000000000000
- green(38) = 0.647058823529412
- blue(38) = 0.000000000000000E+000
-
-! DarkSeaGreen
- red(39) = 0.560784313725490
- green(39) = 0.737254901960784
- blue(39) = 0.560784313725490
-
-! Moccasin
- red(40) = 1.00000000000000
- green(40) = 0.894117647058824
- blue(40) = 0.709803921568627
-
-! DeepSkyBlue2
- red(41) = 0.000000000000000E+000
- green(41) = 0.698039215686274
- blue(41) = 0.933333333333333
-
-! SlateGray4
- red(42) = 0.423529411764706
- green(42) = 0.482352941176471
- blue(42) = 0.545098039215686
-
-! Beige
- red(43) = 0.960784313725490
- green(43) = 0.960784313725490
- blue(43) = 0.862745098039216
-
-! Gold
- red(44) = 1.00000000000000
- green(44) = 0.843137254901961
- blue(44) = 0.000000000000000E+000
-
-! SlateBlue
- red(45) = 0.415686274509804
- green(45) = 0.352941176470588
- blue(45) = 0.803921568627451
-
-! SteelBlue1
- red(46) = 0.388235294117647
- green(46) = 0.721568627450980
- blue(46) = 1.00000000000000
-
-! SaddleBrown
- red(47) = 0.545098039215686
- green(47) = 0.270588235294118
- blue(47) = 7.450980392156863E-002
-
-! Pink
- red(48) = 1.00000000000000
- green(48) = 0.752941176470588
- blue(48) = 0.796078431372549
-
-! Black
- red(49) = 0.000000000000000E+000
- green(49) = 0.000000000000000E+000
- blue(49) = 0.000000000000000E+000
-
-! SlateGrey
- red(50) = 0.439215686274510
- green(50) = 0.501960784313725
- blue(50) = 0.564705882352941
-
-! Ivory
- red(51) = 1.00000000000000
- green(51) = 1.00000000000000
- blue(51) = 0.941176470588235
-
-! OliveDrab
- red(52) = 0.419607843137255
- green(52) = 0.556862745098039
- blue(52) = 0.137254901960784
-
-! Ivory1
- red(53) = 1.00000000000000
- green(53) = 1.00000000000000
- blue(53) = 0.941176470588235
-
-! SkyBlue
- red(54) = 0.529411764705882
- green(54) = 0.807843137254902
- blue(54) = 0.921568627450980
-
-! MistyRose3
- red(55) = 0.803921568627451
- green(55) = 0.717647058823529
- blue(55) = 0.709803921568627
-
-! LimeGreen
- red(56) = 0.196078431372549
- green(56) = 0.803921568627451
- blue(56) = 0.196078431372549
-
-! Purple
- red(57) = 0.627450980392157
- green(57) = 0.125490196078431
- blue(57) = 0.941176470588235
-
-! SkyBlue2
- red(58) = 0.494117647058824
- green(58) = 0.752941176470588
- blue(58) = 0.933333333333333
-
-! Red
- red(59) = 1.00000000000000
- green(59) = 0.000000000000000E+000
- blue(59) = 0.000000000000000E+000
-
-! DarkKhaki
- red(60) = 0.741176470588235
- green(60) = 0.717647058823529
- blue(60) = 0.419607843137255
-
-! MediumTurquoise
- red(61) = 0.282352941176471
- green(61) = 0.819607843137255
- blue(61) = 0.800000000000000
-
-! Grey
- red(62) = 0.745098039215686
- green(62) = 0.745098039215686
- blue(62) = 0.745098039215686
-
-! Coral
- red(63) = 1.00000000000000
- green(63) = 0.498039215686275
- blue(63) = 0.313725490196078
-
-! NavajoWhite4
- red(64) = 0.545098039215686
- green(64) = 0.474509803921569
- blue(64) = 0.368627450980392
-
-! SlateBlue4
- red(65) = 0.278431372549020
- green(65) = 0.235294117647059
- blue(65) = 0.545098039215686
-
-! RoyalBlue4
- red(66) = 0.152941176470588
- green(66) = 0.250980392156863
- blue(66) = 0.545098039215686
-
-! YellowGreen
- red(67) = 0.603921568627451
- green(67) = 0.803921568627451
- blue(67) = 0.196078431372549
-
-! DeepSkyBlue3
- red(68) = 0.000000000000000E+000
- green(68) = 0.603921568627451
- blue(68) = 0.803921568627451
-
-! goldenrod
- red(69) = 0.854901960784314
- green(69) = 0.647058823529412
- blue(69) = 0.125490196078431
-
-! AntiqueWhite4
- red(70) = 0.545098039215686
- green(70) = 0.513725490196078
- blue(70) = 0.470588235294118
-
-! lemonchiffon
- red(71) = 1.00000000000000
- green(71) = 0.980000000000000
- blue(71) = 0.800000000000000
-
-! GreenYellow
- red(72) = 0.678431372549020
- green(72) = 1.00000000000000
- blue(72) = 0.184313725490196
-
-! LightSlateGray
- red(73) = 0.466666666666667
- green(73) = 0.533333333333333
- blue(73) = 0.600000000000000
-
-! RoyalBlue
- red(74) = 0.254901960784314
- green(74) = 0.411764705882353
- blue(74) = 0.882352941176471
-
-! DarkGreen
- red(75) = 0.000000000000000E+000
- green(75) = 0.392156862745098
- blue(75) = 0.000000000000000E+000
-
-! NavajoWhite3
- red(76) = 0.803921568627451
- green(76) = 0.701960784313725
- blue(76) = 0.545098039215686
-
-! Azure1
- red(77) = 0.941176470588235
- green(77) = 1.00000000000000
- blue(77) = 1.00000000000000
-
-! PowderBlue
- red(78) = 0.690196078431373
- green(78) = 0.878431372549020
- blue(78) = 0.901960784313726
-
-! slateblue
- red(79) = 0.420000000000000
- green(79) = 0.350000000000000
- blue(79) = 0.800000000000000
-
-! MediumOrchid
- red(80) = 0.729411764705882
- green(80) = 0.333333333333333
- blue(80) = 0.827450980392157
-
-! turquoise
- red(81) = 0.250000000000000
- green(81) = 0.880000000000000
- blue(81) = 0.820000000000000
-
-! Snow1
- red(82) = 1.00000000000000
- green(82) = 0.980392156862745
- blue(82) = 0.980392156862745
-
-! violet
- red(83) = 0.930000000000000
- green(83) = 0.510000000000000
- blue(83) = 0.930000000000000
-
-! DeepPink
- red(84) = 1.00000000000000
- green(84) = 7.843137254901961E-002
- blue(84) = 0.576470588235294
-
-! MistyRose4
- red(85) = 0.545098039215686
- green(85) = 0.490196078431373
- blue(85) = 0.482352941176471
-
-! PeachPuff3
- red(86) = 0.803921568627451
- green(86) = 0.686274509803922
- blue(86) = 0.584313725490196
-
-! MediumSeaGreen
- red(87) = 0.235294117647059
- green(87) = 0.701960784313725
- blue(87) = 0.443137254901961
-
-! Honeydew4
- red(88) = 0.513725490196078
- green(88) = 0.545098039215686
- blue(88) = 0.513725490196078
-
-! Tan
- red(89) = 0.823529411764706
- green(89) = 0.705882352941177
- blue(89) = 0.549019607843137
-
-! DarkGoldenrod
- red(90) = 0.721568627450980
- green(90) = 0.525490196078431
- blue(90) = 4.313725490196078E-002
-
-! Blue2
- red(91) = 0.000000000000000E+000
- green(91) = 0.000000000000000E+000
- blue(91) = 0.933333333333333
-
-! Maroon
- red(92) = 0.690196078431373
- green(92) = 0.188235294117647
- blue(92) = 0.376470588235294
-
-! LightSkyBlue3
- red(93) = 0.552941176470588
- green(93) = 0.713725490196078
- blue(93) = 0.803921568627451
-
-! LemonChiffon2
- red(94) = 0.933333333333333
- green(94) = 0.913725490196078
- blue(94) = 0.749019607843137
-
-! Snow3
- red(95) = 0.803921568627451
- green(95) = 0.788235294117647
- blue(95) = 0.788235294117647
-
-! Ivory4
- red(96) = 0.545098039215686
- green(96) = 0.545098039215686
- blue(96) = 0.513725490196078
-
-! AntiqueWhite3
- red(97) = 0.803921568627451
- green(97) = 0.752941176470588
- blue(97) = 0.690196078431373
-
-! Bisque4
- red(98) = 0.545098039215686
- green(98) = 0.490196078431373
- blue(98) = 0.419607843137255
-
-! Snow2
- red(99) = 0.933333333333333
- green(99) = 0.913725490196078
- blue(99) = 0.913725490196078
-
-! SlateGray1
- red(100) = 0.776470588235294
- green(100) = 0.886274509803922
- blue(100) = 1.00000000000000
-
-! Seashell2
- red(101) = 0.933333333333333
- green(101) = 0.898039215686275
- blue(101) = 0.870588235294118
-
-! Aquamarine
- red(102) = 0.498039215686275
- green(102) = 1.00000000000000
- blue(102) = 0.831372549019608
-
-! SlateGray2
- red(103) = 0.725490196078431
- green(103) = 0.827450980392157
- blue(103) = 0.933333333333333
-
-! White
- red(104) = 1.00000000000000
- green(104) = 1.00000000000000
- blue(104) = 1.00000000000000
-
-! LavenderBlush
- red(105) = 1.00000000000000
- green(105) = 0.941176470588235
- blue(105) = 0.960784313725490
-
-! DodgerBlue3
- red(106) = 9.411764705882353E-002
- green(106) = 0.454901960784314
- blue(106) = 0.803921568627451
-
-! RoyalBlue3
- red(107) = 0.227450980392157
- green(107) = 0.372549019607843
- blue(107) = 0.803921568627451
-
-! LightYellow
- red(108) = 1.00000000000000
- green(108) = 1.00000000000000
- blue(108) = 0.878431372549020
-
-! DeepSkyBlue
- red(109) = 0.000000000000000E+000
- green(109) = 0.749019607843137
- blue(109) = 1.00000000000000
-
-! AntiqueWhite2
- red(110) = 0.933333333333333
- green(110) = 0.874509803921569
- blue(110) = 0.800000000000000
-
-! CornflowerBlue
- red(111) = 0.392156862745098
- green(111) = 0.584313725490196
- blue(111) = 0.929411764705882
-
-! PeachPuff4
- red(112) = 0.545098039215686
- green(112) = 0.466666666666667
- blue(112) = 0.396078431372549
-
-! SpringGreen
- red(113) = 0.000000000000000E+000
- green(113) = 1.00000000000000
- blue(113) = 0.498039215686275
-
-! Honeydew
- red(114) = 0.941176470588235
- green(114) = 1.00000000000000
- blue(114) = 0.941176470588235
-
-! Honeydew2
- red(115) = 0.878431372549020
- green(115) = 0.933333333333333
- blue(115) = 0.878431372549020
-
-! LightSeaGreen
- red(116) = 0.125490196078431
- green(116) = 0.698039215686274
- blue(116) = 0.666666666666667
-
-! NavyBlue
- red(117) = 0.000000000000000E+000
- green(117) = 0.000000000000000E+000
- blue(117) = 0.501960784313725
-
-! Azure4
- red(118) = 0.513725490196078
- green(118) = 0.545098039215686
- blue(118) = 0.545098039215686
-
-! MediumAquamarine
- red(119) = 0.400000000000000
- green(119) = 0.803921568627451
- blue(119) = 0.666666666666667
-
-! SkyBlue3
- red(120) = 0.423529411764706
- green(120) = 0.650980392156863
- blue(120) = 0.803921568627451
-
-! LavenderBlush2
- red(121) = 0.933333333333333
- green(121) = 0.878431372549020
- blue(121) = 0.898039215686275
-
-! Bisque1
- red(122) = 1.00000000000000
- green(122) = 0.894117647058824
- blue(122) = 0.768627450980392
-
-! DarkOrange
- red(123) = 1.00000000000000
- green(123) = 0.549019607843137
- blue(123) = 0.000000000000000E+000
-
-! LightSteelBlue
- red(124) = 0.690196078431373
- green(124) = 0.768627450980392
- blue(124) = 0.870588235294118
-
-! SteelBlue2
- red(125) = 0.360784313725490
- green(125) = 0.674509803921569
- blue(125) = 0.933333333333333
-
-! LemonChiffon3
- red(126) = 0.803921568627451
- green(126) = 0.788235294117647
- blue(126) = 0.647058823529412
-
-! DarkSlateBlue
- red(127) = 0.282352941176471
- green(127) = 0.239215686274510
- blue(127) = 0.545098039215686
-
-! Seashell
- red(128) = 1.00000000000000
- green(128) = 0.960784313725490
- blue(128) = 0.933333333333333
-
-! Firebrick
- red(129) = 0.698039215686274
- green(129) = 0.133333333333333
- blue(129) = 0.133333333333333
-
-! LightGray
- red(130) = 0.827450980392157
- green(130) = 0.827450980392157
- blue(130) = 0.827450980392157
-
-! Blue
- red(131) = 0.000000000000000E+000
- green(131) = 0.000000000000000E+000
- blue(131) = 1.00000000000000
-
-! Bisque2
- red(132) = 0.933333333333333
- green(132) = 0.835294117647059
- blue(132) = 0.717647058823529
-
-! WhiteSmoke
- red(133) = 0.960784313725490
- green(133) = 0.960784313725490
- blue(133) = 0.960784313725490
-
-! SeaGreen
- red(134) = 0.180392156862745
- green(134) = 0.545098039215686
- blue(134) = 0.341176470588235
-
-! Burlywood
- red(135) = 0.870588235294118
- green(135) = 0.721568627450980
- blue(135) = 0.529411764705882
-
-! RoyalBlue2
- red(136) = 0.262745098039216
- green(136) = 0.431372549019608
- blue(136) = 0.933333333333333
-
-! RoyalBlue1
- red(137) = 0.282352941176471
- green(137) = 0.462745098039216
- blue(137) = 1.00000000000000
-
-! SteelBlue4
- red(138) = 0.211764705882353
- green(138) = 0.392156862745098
- blue(138) = 0.545098039215686
-
-! AliceBlue
- red(139) = 0.941176470588235
- green(139) = 0.972549019607843
- blue(139) = 1.00000000000000
-
-! LightSlateBlue
- red(140) = 0.517647058823529
- green(140) = 0.439215686274510
- blue(140) = 1.00000000000000
-
-! MistyRose1
- red(141) = 1.00000000000000
- green(141) = 0.894117647058824
- blue(141) = 0.882352941176471
-
-! SandyBrown
- red(142) = 0.956862745098039
- green(142) = 0.643137254901961
- blue(142) = 0.376470588235294
-
-! DarkOliveGreen
- red(143) = 0.333333333333333
- green(143) = 0.419607843137255
- blue(143) = 0.184313725490196
-
-! Yellow
- red(144) = 1.00000000000000
- green(144) = 1.00000000000000
- blue(144) = 0.000000000000000E+000
-
-! SlateGray3
- red(145) = 0.623529411764706
- green(145) = 0.713725490196078
- blue(145) = 0.803921568627451
-
-! HotPink
- red(146) = 1.00000000000000
- green(146) = 0.411764705882353
- blue(146) = 0.705882352941177
-
-! Violet
- red(147) = 0.933333333333333
- green(147) = 0.509803921568627
- blue(147) = 0.933333333333333
-
-! LightSkyBlue
- red(148) = 0.529411764705882
- green(148) = 0.807843137254902
- blue(148) = 0.980392156862745
-
-! Cornsilk2
- red(149) = 0.933333333333333
- green(149) = 0.909803921568627
- blue(149) = 0.803921568627451
-
-! MidnightBlue
- red(150) = 9.803921568627451E-002
- green(150) = 9.803921568627451E-002
- blue(150) = 0.439215686274510
-
-! AntiqueWhite
- red(151) = 0.980392156862745
- green(151) = 0.921568627450980
- blue(151) = 0.843137254901961
-
-! PaleGreen
- red(152) = 0.596078431372549
- green(152) = 0.984313725490196
- blue(152) = 0.596078431372549
-
-! MedSpringGreen
- red(153) = 0.000000000000000E+000
- green(153) = 0.980392156862745
- blue(153) = 0.603921568627451
-
-! DodgerBlue1
- red(154) = 0.117647058823529
- green(154) = 0.564705882352941
- blue(154) = 1.00000000000000
-
-! Blue3
- red(155) = 0.000000000000000E+000
- green(155) = 0.000000000000000E+000
- blue(155) = 0.803921568627451
-
-! Cyan
- red(156) = 0.000000000000000E+000
- green(156) = 1.00000000000000
- blue(156) = 1.00000000000000
-
-! LemonChiffon
- red(157) = 1.00000000000000
- green(157) = 0.980392156862745
- blue(157) = 0.803921568627451
-
-! mediumorchid
- red(158) = 0.730000000000000
- green(158) = 0.330000000000000
- blue(158) = 0.830000000000000
-
-! Turquoise
- red(159) = 0.250980392156863
- green(159) = 0.878431372549020
- blue(159) = 0.815686274509804
-
-! IndianRed
- red(160) = 0.803921568627451
- green(160) = 0.360784313725490
- blue(160) = 0.360784313725490
-
-! DodgerBlue
- red(161) = 0.117647058823529
- green(161) = 0.564705882352941
- blue(161) = 1.00000000000000
-
-! Seashell3
- red(162) = 0.803921568627451
- green(162) = 0.772549019607843
- blue(162) = 0.749019607843137
-
-! BlueViolet
- red(163) = 0.541176470588235
- green(163) = 0.168627450980392
- blue(163) = 0.886274509803922
-
-! DeepSkyBlue4
- red(164) = 0.000000000000000E+000
- green(164) = 0.407843137254902
- blue(164) = 0.545098039215686
-
-! PaleVioletRed
- red(165) = 0.858823529411765
- green(165) = 0.439215686274510
- blue(165) = 0.576470588235294
-
-! Azure2
- red(166) = 0.878431372549020
- green(166) = 0.933333333333333
- blue(166) = 0.933333333333333
-
-! greenyellow
- red(167) = 0.680000000000000
- green(167) = 1.00000000000000
- blue(167) = 0.180000000000000
-
-! LightGoldenrod
- red(168) = 0.933333333333333
- green(168) = 0.866666666666667
- blue(168) = 0.509803921568627
-
-! MistyRose
- red(169) = 1.00000000000000
- green(169) = 0.894117647058824
- blue(169) = 0.882352941176471
-
-! LightSkyBlue4
- red(170) = 0.376470588235294
- green(170) = 0.482352941176471
- blue(170) = 0.545098039215686
-
-! OrangeRed
- red(171) = 1.00000000000000
- green(171) = 0.270588235294118
- blue(171) = 0.000000000000000E+000
-
-! DimGrey
- red(172) = 0.411764705882353
- green(172) = 0.411764705882353
- blue(172) = 0.411764705882353
-
-! MediumVioletRed
- red(173) = 0.780392156862745
- green(173) = 8.235294117647059E-002
- blue(173) = 0.521568627450980
-
-! DarkSlateGray
- red(174) = 0.184313725490196
- green(174) = 0.309803921568627
- blue(174) = 0.309803921568627
-
-! yellow
- red(175) = 1.00000000000000
- green(175) = 1.00000000000000
- blue(175) = 0.000000000000000E+000
-
-! Plum
- red(176) = 0.866666666666667
- green(176) = 0.627450980392157
- blue(176) = 0.866666666666667
-
-! DarkTurquoise
- red(177) = 0.000000000000000E+000
- green(177) = 0.807843137254902
- blue(177) = 0.819607843137255
-
-! DodgerBlue4
- red(178) = 6.274509803921569E-002
- green(178) = 0.305882352941176
- blue(178) = 0.545098039215686
-
-! Cornsilk
- red(179) = 1.00000000000000
- green(179) = 0.972549019607843
- blue(179) = 0.862745098039216
-
-! SkyBlue1
- red(180) = 0.529411764705882
- green(180) = 0.807843137254902
- blue(180) = 1.00000000000000
-
-! Seashell1
- red(181) = 1.00000000000000
- green(181) = 0.960784313725490
- blue(181) = 0.933333333333333
-
-! lavender
- red(182) = 0.901960784313726
- green(182) = 0.901960784313726
- blue(182) = 0.980392156862745
-
-! Snow4
- red(183) = 0.545098039215686
- green(183) = 0.537254901960784
- blue(183) = 0.537254901960784
-
-! Peru
- red(184) = 0.803921568627451
- green(184) = 0.521568627450980
- blue(184) = 0.247058823529412
-
-! PeachPuff
- red(185) = 1.00000000000000
- green(185) = 0.854901960784314
- blue(185) = 0.725490196078431
-
-! Green
- red(186) = 0.000000000000000E+000
- green(186) = 1.00000000000000
- blue(186) = 0.000000000000000E+000
-
-! Blue1
- red(187) = 0.000000000000000E+000
- green(187) = 0.000000000000000E+000
- blue(187) = 1.00000000000000
-
-! Seashell4
- red(188) = 0.545098039215686
- green(188) = 0.525490196078431
- blue(188) = 0.509803921568627
-
-! dodgerblue
- red(189) = 0.120000000000000
- green(189) = 0.560000000000000
- blue(189) = 1.00000000000000
-
-! MistyRose2
- red(190) = 0.933333333333333
- green(190) = 0.835294117647059
- blue(190) = 0.823529411764706
-
-! Tomato
- red(191) = 1.00000000000000
- green(191) = 0.388235294117647
- blue(191) = 0.278431372549020
-
-! Wheat
- red(192) = 0.960784313725490
- green(192) = 0.870588235294118
- blue(192) = 0.701960784313725
-
-! LightBlue
- red(193) = 0.678431372549020
- green(193) = 0.847058823529412
- blue(193) = 0.901960784313726
-
-! Chocolate
- red(194) = 0.823529411764706
- green(194) = 0.411764705882353
- blue(194) = 0.117647058823529
-
-! Blue4
- red(195) = 0.000000000000000E+000
- green(195) = 0.000000000000000E+000
- blue(195) = 0.545098039215686
-
-! LavenderBlush1
- red(196) = 1.00000000000000
- green(196) = 0.941176470588235
- blue(196) = 0.960784313725490
-
-! Magenta
- red(197) = 1.00000000000000
- green(197) = 0.000000000000000E+000
- blue(197) = 1.00000000000000
-
-! darkturquoise
- red(198) = 0.000000000000000E+000
- green(198) = 0.810000000000000
- blue(198) = 0.820000000000000
-
-! blueviolet
- red(199) = 0.540000000000000
- green(199) = 0.170000000000000
- blue(199) = 0.890000000000000
-
-! MintCream
- red(200) = 0.960784313725490
- green(200) = 1.00000000000000
- blue(200) = 0.980392156862745
-
-! PaleGoldenrod
- red(201) = 0.933333333333333
- green(201) = 0.909803921568627
- blue(201) = 0.666666666666667
-
-! MediumPurple
- red(202) = 0.576470588235294
- green(202) = 0.439215686274510
- blue(202) = 0.858823529411765
-
-! PapayaWhip
- red(203) = 1.00000000000000
- green(203) = 0.937254901960784
- blue(203) = 0.835294117647059
-
-! LavenderBlush4
- red(204) = 0.545098039215686
- green(204) = 0.513725490196078
- blue(204) = 0.525490196078431
-
-! Cornsilk4
- red(205) = 0.545098039215686
- green(205) = 0.533333333333333
- blue(205) = 0.470588235294118
-
-! LtGoldenrodYello
- red(206) = 0.980392156862745
- green(206) = 0.980392156862745
- blue(206) = 0.823529411764706
-
-! limegreen
- red(207) = 0.200000000000000
- green(207) = 0.800000000000000
- blue(207) = 0.200000000000000
-
-! LemonChiffon1
- red(208) = 1.00000000000000
- green(208) = 0.980392156862745
- blue(208) = 0.803921568627451
-
-! DarkOrchid
- red(209) = 0.600000000000000
- green(209) = 0.196078431372549
- blue(209) = 0.800000000000000
-
-! SlateBlue1
- red(210) = 0.513725490196078
- green(210) = 0.435294117647059
- blue(210) = 1.00000000000000
-
-! chartreuse
- red(211) = 0.500000000000000
- green(211) = 1.00000000000000
- blue(211) = 0.000000000000000E+000
-
-! PaleTurquoise
- red(212) = 0.686274509803922
- green(212) = 0.933333333333333
- blue(212) = 0.933333333333333
-
-! NavajoWhite1
- red(213) = 1.00000000000000
- green(213) = 0.870588235294118
- blue(213) = 0.678431372549020
-
-! LightSkyBlue2
- red(214) = 0.643137254901961
- green(214) = 0.827450980392157
- blue(214) = 0.933333333333333
-
-! VioletRed
- red(215) = 0.815686274509804
- green(215) = 0.125490196078431
- blue(215) = 0.564705882352941
-
-! mocassin
- red(216) = 1.00000000000000
- green(216) = 0.890000000000000
- blue(216) = 0.710000000000000
-
-! OldLace
- red(217) = 0.992156862745098
- green(217) = 0.960784313725490
- blue(217) = 0.901960784313726
-
-! deeppink
- red(218) = 1.00000000000000
- green(218) = 8.000000000000000E-002
- blue(218) = 0.580000000000000
-
-! Honeydew3
- red(219) = 0.756862745098039
- green(219) = 0.803921568627451
- blue(219) = 0.756862745098039
-
-! Gainsboro
- red(220) = 0.862745098039216
- green(220) = 0.862745098039216
- blue(220) = 0.862745098039216
-
-! DarkSalmon
- red(221) = 0.913725490196078
- green(221) = 0.588235294117647
- blue(221) = 0.478431372549020
-
-! AntiqueWhite1
- red(222) = 1.00000000000000
- green(222) = 0.937254901960784
- blue(222) = 0.858823529411765
-
-! LightCyan
- red(223) = 0.878431372549020
- green(223) = 1.00000000000000
- blue(223) = 1.00000000000000
-
-! ForestGreen
- red(224) = 0.133333333333333
- green(224) = 0.545098039215686
- blue(224) = 0.133333333333333
-
-! Orchid
- red(225) = 0.854901960784314
- green(225) = 0.439215686274510
- blue(225) = 0.839215686274510
-
-! PeachPuff2
- red(226) = 0.933333333333333
- green(226) = 0.796078431372549
- blue(226) = 0.678431372549020
-
-! LightPink
- red(227) = 1.00000000000000
- green(227) = 0.713725490196078
- blue(227) = 0.756862745098039
-
-! Sienna
- red(228) = 0.627450980392157
- green(228) = 0.321568627450980
- blue(228) = 0.176470588235294
-
-! darkorchid
- red(229) = 0.600000000000000
- green(229) = 0.200000000000000
- blue(229) = 0.800000000000000
-
-! MediumSlateBlue
- red(230) = 0.482352941176471
- green(230) = 0.407843137254902
- blue(230) = 0.933333333333333
-
-! CadetBlue
- red(231) = 0.372549019607843
- green(231) = 0.619607843137255
- blue(231) = 0.627450980392157
-
-! LawnGreen
- red(232) = 0.486274509803922
- green(232) = 0.988235294117647
- blue(232) = 0.000000000000000E+000
-
-! Chartreuse
- red(233) = 0.498039215686275
- green(233) = 1.00000000000000
- blue(233) = 0.000000000000000E+000
-
-! Brown
- red(234) = 0.647058823529412
- green(234) = 0.164705882352941
- blue(234) = 0.164705882352941
-
-! Azure
- red(235) = 0.941176470588235
- green(235) = 1.00000000000000
- blue(235) = 1.00000000000000
-
-! Bisque
- red(236) = 1.00000000000000
- green(236) = 0.894117647058824
- blue(236) = 0.768627450980392
-
-! get minimum and maximum values of mesh coordinates
- xmin = minval(coord(1,:))
- zmin = minval(coord(2,:))
- xmax = maxval(coord(1,:))
- zmax = maxval(coord(2,:))
-
-#ifdef USE_MPI
- call MPI_ALLREDUCE (xmin, xmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (zmin, zmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (xmax, xmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (zmax, zmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- xmin = xmin_glob
- zmin = zmin_glob
- xmax = xmax_glob
- zmax = zmax_glob
-#endif
-
- if ( myrank == 0 ) then
- write(IOUT,*) 'X min, max = ',xmin,xmax
- write(IOUT,*) 'Z min, max = ',zmin,zmax
- endif
-
-! ratio of physical page size/size of the domain meshed
- ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
-
-! compute the maximum of the norm of the vector
- dispmax = maxval(sqrt(displ(1,:)**2 + displ(3,:)**2))
-#ifdef USE_MPI
- call MPI_ALLREDUCE (dispmax, dispmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- dispmax = dispmax_glob
-#endif
- if ( myrank == 0 ) then
- write(IOUT,*) 'Max norm = ',dispmax
- endif
-
-!
-!---- open PostScript file
-!
- if ( myrank == 0 ) then
- write(file_name,"('OUTPUT_FILES/vect',i7.7,'.ps')") it
- open(unit=24,file=file_name,status='unknown')
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% gray levels for the velocity model'
- write(24,*) '/BK {setgray fill} def'
- write(24,*) '% black and white version'
- write(24,*) '%/BK {pop 1 setgray fill} def'
- write(24,*) '%'
- write(24,*) '% magenta for vectors'
- write(24,*) '/Colvects {0 setlinewidth 1. 0. 1. RG} def'
- write(24,*) '% black and white version'
- write(24,*) '%/Colvects {0 setlinewidth 0. setgray} def'
- write(24,*) '%'
- write(24,*) '% chartreuse for macrobloc mesh'
- write(24,*) '/Colmesh {0 setlinewidth 0.5 1. 0. RG} def'
- write(24,*) '% black and white version'
- write(24,*) '%/Colmesh {0 setlinewidth 0. setgray} def'
- write(24,*) '%'
- write(24,*) '% cyan for sources and receivers'
- write(24,*) '/Colreceiv {0. 1. 1. RG} def'
- write(24,*) '% black and white version'
- write(24,*) '%/Colreceiv {0. setgray} def'
- write(24,*) '%'
- write(24,*) '% macro to draw an arrow'
- write(24,*) '/F {MV LR gsave LR ST grestore LR ST} def'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '0 setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- write(24,*) '%'
- write(24,*) '/vshift ',-height/2,' CM def'
- write(24,*) '/Rshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop neg vshift MR show } def'
- write(24,*) '/Cshow { currentpoint stroke MV'
- write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
- write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '% uncomment this to zoom on parts of the mesh'
- write(24,*) '% -32 CM -21 CM translate 3. 3. scale'
- write(24,*) '% -52 CM -24 CM translate 4. 4. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '24. CM 1.2 CM MV'
- write(24,610) usoffset,it
- write(24,*) '%'
-
- write(24,*) '24. CM 1.95 CM MV'
- timeval = it*dt
- if(timeval >= 1.d-3 .and. timeval < 1000.d0) then
- write(24,600) usoffset,timeval
- else
- write(24,601) usoffset,timeval
- endif
- write(24,*) '%'
- write(24,*) '24. CM 2.7 CM MV'
- write(24,640) usoffset,dispmax
- write(24,*) '%'
- write(24,*) '24. CM 3.45 CM MV'
- write(24,620) usoffset,cutsnaps*100.d0
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- if(colors == 1) write(24,*) '.4 .9 .9 setrgbcolor'
- write(24,*) '11 CM 1.1 CM MV'
- write(24,*) '(X axis) show'
- write(24,*) '%'
- write(24,*) '1.4 CM 9.5 CM MV'
- write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
- write(24,*) '(Z axis) show'
- write(24,*) 'grestore'
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.7 CM scalefont setfont'
- if(colors == 1) write(24,*) '.8 0 .8 setrgbcolor'
- write(24,*) '24.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- if(imagetype == 1) then
- write(24,*) '(Displacement vector field) show'
- else if(imagetype == 2) then
- write(24,*) '(Velocity vector field) show'
- else if(imagetype == 3) then
- write(24,*) '(Acceleration vector field) show'
- else
- call exit_MPI('Bad field code in PostScript display')
- endif
- write(24,*) 'grestore'
- write(24,*) '25.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
-
- if(coupled_acoustic_elastic) then
- write(24,*) '(Coupled Acoustic/Elastic Wave 2D - SEM) show'
- else if(coupled_acoustic_poro) then
- write(24,*) '(Coupled Acoustic/Poroelastic Wave 2D - SEM) show'
- else if(coupled_elastic_poro) then
- write(24,*) '(Coupled Elastic/Poroelastic Wave 2D - SEM) show'
- else if(any_acoustic) then
- write(24,*) '(Acoustic Wave 2D - Spectral Element Method) show'
- else if(any_poroelastic) then
- write(24,*) '(Poroelastic Wave 2D - Spectral Element Method) show'
- else
- write(24,*) '(Elastic Wave 2D - Spectral Element Method) show'
- endif
-
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- print the spectral elements mesh in PostScript
-!
-
- endif
-
-
- convert = PI / 180.d0
-
-!
-!---- draw the velocity model in background
-!
- if(modelvect) then
-
- buffer_offset = 0
- RGB_offset = 0
-
- do ispec=1,nspec
- do i=1,NGLLX-subsamp,subsamp
- do j=1,NGLLX-subsamp,subsamp
-
- if((vpmax-vpmin)/vpmin > 0.02d0) then
- if(assign_external_model) then
- x1 = (vpext(i,j,ispec)-vpmin) / (vpmax-vpmin)
- else
- material = kmato(ispec)
-! get elastic parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
- rhol_s = density(1,kmato(ispec))
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
-!frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
- rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
-!Biot coefficients for the input phi
- D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + FOUR_THIRDS*mul_fr
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
-! Approximated velocities (no viscous dissipation)
- afactor = rhol_bar - phil/tortl*rhol_f
- bfactor = H_biot + phil*rhol_bar/(tortl*rhol_f)*M_biot - 2.d0*phil/tortl*C_biot
- cfactor = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
- cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
- cpIloc = sqrt(cpIsquare)
- x1 = (cpIloc-vpmin)/(vpmax-vpmin)
- endif
- else
- x1 = 0.5d0
- endif
-
-! rescale to avoid very dark gray levels
- x1 = x1*0.7 + 0.2
- if(x1 > 1.d0) x1=1.d0
-
-! invert scale: white = vpmin, dark gray = vpmax
- x1 = 1.d0 - x1
-
- xw = coord(1,ibool(i,j,ispec))
- zw = coord(2,ibool(i,j,ispec))
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- if ( myrank == 0 ) then
- write(24,500) xw,zw
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_velocity_model(1,buffer_offset) = xw
- coorg_send_ps_velocity_model(2,buffer_offset) = zw
- endif
-
- xw = coord(1,ibool(i+subsamp,j,ispec))
- zw = coord(2,ibool(i+subsamp,j,ispec))
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- if ( myrank == 0 ) then
- write(24,499) xw,zw
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_velocity_model(1,buffer_offset) = xw
- coorg_send_ps_velocity_model(2,buffer_offset) = zw
- endif
-
- xw = coord(1,ibool(i+subsamp,j+subsamp,ispec))
- zw = coord(2,ibool(i+subsamp,j+subsamp,ispec))
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- if ( myrank == 0 ) then
- write(24,499) xw,zw
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_velocity_model(1,buffer_offset) = xw
- coorg_send_ps_velocity_model(2,buffer_offset) = zw
- endif
-
- xw = coord(1,ibool(i,j+subsamp,ispec))
- zw = coord(2,ibool(i,j+subsamp,ispec))
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- if ( myrank == 0 ) then
- write(24,499) xw,zw
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_velocity_model(1,buffer_offset) = xw
- coorg_send_ps_velocity_model(2,buffer_offset) = zw
- endif
-
-! display P-velocity model using gray levels
- if ( myrank == 0 ) then
- write(24,604) x1
- else
- RGB_offset = RGB_offset + 1
- RGB_send_ps_velocity_model(1,RGB_offset) = x1
- endif
-
- enddo
- enddo
- enddo
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (coorg_recv_ps_velocity_model(1,1), &
- 2*nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4, &
- MPI_DOUBLE_PRECISION, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (RGB_recv_ps_velocity_model(1,1), nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
- MPI_DOUBLE_PRECISION, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- buffer_offset = 0
- RGB_offset = 0
- do ispec = 1, nspec_recv
- do i=1,NGLLX-subsamp,subsamp
- do j=1,NGLLX-subsamp,subsamp
- buffer_offset = buffer_offset + 1
- write(24,500) coorg_recv_ps_velocity_model(1,buffer_offset), &
- coorg_recv_ps_velocity_model(2,buffer_offset)
- buffer_offset = buffer_offset + 1
- write(24,499) coorg_recv_ps_velocity_model(1,buffer_offset), &
- coorg_recv_ps_velocity_model(2,buffer_offset)
- buffer_offset = buffer_offset + 1
- write(24,499) coorg_recv_ps_velocity_model(1,buffer_offset), &
- coorg_recv_ps_velocity_model(2,buffer_offset)
- buffer_offset = buffer_offset + 1
- write(24,499) coorg_recv_ps_velocity_model(1,buffer_offset), &
- coorg_recv_ps_velocity_model(2,buffer_offset)
- RGB_offset = RGB_offset + 1
- write(24,604) RGB_recv_ps_velocity_model(1,RGB_offset)
- enddo
- enddo
- enddo
-
- enddo
- else
- call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (coorg_send_ps_velocity_model(1,1), 2*nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4, &
- MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
- call MPI_SEND (RGB_send_ps_velocity_model(1,1), nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
- MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
- endif
-
-
-#endif
-
-
- endif
-
-!
-!---- draw the spectral element mesh
-!
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- endif
-
- buffer_offset = 0
- RGB_offset = 0
-
- do ispec=1,nspec
-
- if ( myrank == 0 ) write(24,*) '% elem ',ispec
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- if ( myrank == 0 ) then
- write(24,*) 'mark'
- write(24,681) x1,z1
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x1
- coorg_send_ps_element_mesh(2,buffer_offset) = z1
- endif
-
- if(ngnod == 4) then
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
-
- else
-
-! draw curved lines if elements have 9 nodes
- do ir=2,pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
- enddo
-
- ir=pointsdisp
- do is=2,pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
- enddo
-
- is=pointsdisp
- do ir=pointsdisp-1,1,-1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
- enddo
-
- ir=1
- do is=pointsdisp-1,2,-1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,681) x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
- enddo
-
- endif
-
- if ( myrank == 0 ) then
- write(24,*) 'CO'
- endif
-
- if(colors == 1) then
-
-! use a different color for each material set
- imat = kmato(ispec)
- icol = mod(imat - 1,NUM_COLORS) + 1
-
- if ( myrank == 0 ) then
- if(meshvect) then
- write(24,680) red(icol),green(icol),blue(icol)
- else
- write(24,679) red(icol),green(icol),blue(icol)
- endif
- else
- RGB_offset = RGB_offset + 1
- color_send_ps_element_mesh(RGB_offset) = icol
- endif
-
- endif
-
- if ( myrank == 0 ) then
- if(meshvect) then
- if(modelvect) then
- write(24,*) 'Colmesh ST'
- else
- write(24,*) '0 setgray ST'
- endif
- endif
- endif
-
-! write the element number, the group number and the material number inside the element
- if(numbers == 1) then
-
- xw = (coorg(1,knods(1,ispec)) + coorg(1,knods(2,ispec)) + coorg(1,knods(3,ispec)) + coorg(1,knods(4,ispec))) / 4.d0
- zw = (coorg(2,knods(1,ispec)) + coorg(2,knods(2,ispec)) + coorg(2,knods(3,ispec)) + coorg(2,knods(4,ispec))) / 4.d0
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
-
- if ( myrank == 0 ) then
- if(colors == 1) write(24,*) '1 setgray'
- endif
-
- if ( myrank == 0 ) then
- write(24,500) xw,zw
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_element_mesh(1,buffer_offset) = x2
- coorg_send_ps_element_mesh(2,buffer_offset) = z2
- endif
-
-! write spectral element number
- if ( myrank == 0 ) then
- write(24,502) ispec
- else
- RGB_offset = RGB_offset + 1
- color_send_ps_element_mesh(RGB_offset) = ispec
- endif
-
- endif
-
- enddo
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
- nb_coorg_per_elem = 1
- if ( numbers == 1 ) then
- nb_coorg_per_elem = nb_coorg_per_elem + 1
- endif
- if ( ngnod == 4 ) then
- nb_coorg_per_elem = nb_coorg_per_elem + 4
- else
- nb_coorg_per_elem = nb_coorg_per_elem + 3*(pointsdisp-1)+(pointsdisp-2)
- endif
- nb_color_per_elem = 0
- if ( colors == 1 ) then
- nb_color_per_elem = nb_color_per_elem + 1
- endif
- if ( numbers == 1 ) then
- nb_color_per_elem = nb_color_per_elem + 1
- endif
-
- call MPI_RECV (coorg_recv_ps_element_mesh(1,1), 2*nspec_recv*nb_coorg_per_elem, &
- MPI_DOUBLE_PRECISION, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
- call MPI_RECV (color_recv_ps_element_mesh(1), nspec_recv*nb_coorg_per_elem, &
- MPI_INTEGER, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
-
- buffer_offset = 0
- RGB_offset = 0
- num_spec = nspec
- do ispec = 1, nspec_recv
- num_spec = num_spec + 1
- write(24,*) '% elem ',num_spec
- buffer_offset = buffer_offset + 1
- write(24,*) 'mark'
- write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- if ( ngnod == 4 ) then
- buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
-
- else
- do ir=2,pointsdisp
- buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- enddo
- do is=2,pointsdisp
- buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- enddo
- do ir=pointsdisp-1,1,-1
- buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- enddo
- do is=pointsdisp-1,2,-1
- buffer_offset = buffer_offset + 1
- write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- enddo
-
- endif
-
- write(24,*) 'CO'
- if ( colors == 1 ) then
- if(meshvect) then
- RGB_offset = RGB_offset + 1
- write(24,680) red(color_recv_ps_element_mesh(RGB_offset)),&
- green(color_recv_ps_element_mesh(RGB_offset)),&
- blue(color_recv_ps_element_mesh(RGB_offset))
- else
- RGB_offset = RGB_offset + 1
- write(24,679) red(color_recv_ps_element_mesh(RGB_offset)),&
- green(color_recv_ps_element_mesh(RGB_offset)),&
- blue(color_recv_ps_element_mesh(RGB_offset))
- endif
- endif
- if(meshvect) then
- if(modelvect) then
- write(24,*) 'Colmesh ST'
- else
- write(24,*) '0 setgray ST'
- endif
- endif
- if(numbers == 1) then
- if(colors == 1) write(24,*) '1 setgray'
- buffer_offset = buffer_offset + 1
- write(24,500) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
- RGB_offset = RGB_offset + 1
- write(24,502) color_recv_ps_element_mesh(RGB_offset)
- endif
-
- enddo
-
- enddo
- else
- call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 43, MPI_COMM_WORLD, ier)
- nb_coorg_per_elem = 1
- if ( numbers == 1 ) then
- nb_coorg_per_elem = nb_coorg_per_elem + 1
- endif
- if ( ngnod == 4 ) then
- nb_coorg_per_elem = nb_coorg_per_elem + 4
- else
- nb_coorg_per_elem = nb_coorg_per_elem + 3*(pointsdisp-1)+(pointsdisp-2)
- endif
- nb_color_per_elem = 0
- if ( colors == 1 ) then
- nb_color_per_elem = nb_color_per_elem + 1
- endif
- if ( numbers == 1 ) then
- nb_color_per_elem = nb_color_per_elem + 1
- endif
- call MPI_SEND (coorg_send_ps_element_mesh(1,1), 2*nspec*nb_coorg_per_elem, &
- MPI_DOUBLE_PRECISION, 0, 43, MPI_COMM_WORLD, ier)
- if ( nb_color_per_elem > 0 ) then
- call MPI_SEND (color_send_ps_element_mesh(1), nspec*nb_color_per_elem, &
- MPI_INTEGER, 0, 43, MPI_COMM_WORLD, ier)
- endif
-
- endif
-
-#endif
-
-!
-!--- draw absorbing boundaries with a thick color line
-!
- anyabs_glob = anyabs
-#ifdef USE_MPI
- call MPI_ALLREDUCE(anyabs, anyabs_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- if(anyabs_glob .and. boundvect) then
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% boundary conditions on the mesh'
- write(24,*) '%'
-
-! use green color
- write(24,*) '0 1 0 RG'
-
- write(24,*) '0.02 CM setlinewidth'
- endif
-
- buffer_offset = 0
-
- if ( anyabs ) then
- do inum = 1,nelemabs
- ispec = numabs(inum)
-
- do iedge = 1,4
-
- if(codeabs(iedge,inum) /= 0) then
-
- if(iedge == ITOP) then
- ideb = 3
- ifin = 4
- else if(iedge == IBOTTOM) then
- ideb = 1
- ifin = 2
- else if(iedge == ILEFT) then
- ideb = 4
- ifin = 1
- else if(iedge == IRIGHT) then
- ideb = 2
- ifin = 3
- else
- call exit_MPI('Wrong absorbing boundary code')
- endif
-
- x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
- z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
- x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
- z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,602) x1,z1,x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_abs(1,buffer_offset) = x1
- coorg_send_ps_abs(2,buffer_offset) = z1
- coorg_send_ps_abs(3,buffer_offset) = x2
- coorg_send_ps_abs(4,buffer_offset) = z2
- endif
-
- endif
- enddo
-
- enddo
- endif
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
- if ( nspec_recv > 0 ) then
- call MPI_RECV (coorg_recv_ps_abs(1,1), 4*nspec_recv, &
- MPI_DOUBLE_PRECISION, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
-
- buffer_offset = 0
- do ispec = 1, nspec_recv
- buffer_offset = buffer_offset + 1
- write(24,602) coorg_recv_ps_abs(1,buffer_offset), coorg_recv_ps_abs(2,buffer_offset), &
- coorg_recv_ps_abs(3,buffer_offset), coorg_recv_ps_abs(4,buffer_offset)
- enddo
- endif
- enddo
- else
- call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 44, MPI_COMM_WORLD, ier)
- if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send_ps_abs(1,1), 4*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
- endif
-
- endif
-
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0 setlinewidth'
- endif
-
- endif
-
-!
-!--- draw free surface with a thick color line
-!
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% free surface on the mesh'
- write(24,*) '%'
-
-! use orange color
- write(24,*) '1 0.66 0 RG'
-
- write(24,*) '0.02 CM setlinewidth'
- endif
-
- buffer_offset = 0
-
- if ( nelem_acoustic_surface > 0 ) then
- do inum = 1,nelem_acoustic_surface
- ispec = acoustic_edges(1,inum)
-
- x1 = (coorg(1,acoustic_edges(3,inum))-xmin)*ratio_page + orig_x
- z1 = (coorg(2,acoustic_edges(3,inum))-zmin)*ratio_page + orig_z
- x2 = (coorg(1,acoustic_edges(4,inum))-xmin)*ratio_page + orig_x
- z2 = (coorg(2,acoustic_edges(4,inum))-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,602) x1,z1,x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_free_surface(1,buffer_offset) = x1
- coorg_send_ps_free_surface(2,buffer_offset) = z1
- coorg_send_ps_free_surface(3,buffer_offset) = x2
- coorg_send_ps_free_surface(4,buffer_offset) = z2
- endif
-
- enddo
- endif
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
- if ( nspec_recv > 0 ) then
- call MPI_RECV (coorg_recv_ps_free_surface(1,1), 4*nspec_recv, &
- MPI_DOUBLE_PRECISION, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
-
- buffer_offset = 0
- do ispec = 1, nspec_recv
- buffer_offset = buffer_offset + 1
- write(24,602) coorg_recv_ps_free_surface(1,buffer_offset), coorg_recv_ps_free_surface(2,buffer_offset), &
- coorg_recv_ps_free_surface(3,buffer_offset), coorg_recv_ps_free_surface(4,buffer_offset)
- enddo
- endif
- enddo
- else
- call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 44, MPI_COMM_WORLD, ier)
- if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send_ps_free_surface(1,1), 4*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
- endif
-
- endif
-
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0 setlinewidth'
- endif
-
-!
-!---- draw the fluid-solid coupling edges with a thick color line
-!
- coupled_acoustic_elastic_glob = coupled_acoustic_elastic
-#ifdef USE_MPI
- call MPI_ALLREDUCE(coupled_acoustic_elastic, coupled_acoustic_elastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- if(coupled_acoustic_elastic_glob .and. boundvect) then
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% fluid-solid coupling edges in the mesh'
- write(24,*) '%'
-
- write(24,*) '0.02 CM setlinewidth'
- endif
-
- if ( myrank /= 0 .and. num_fluid_solid_edges > 0 ) allocate(coorg_send(4,num_fluid_solid_edges))
- buffer_offset = 0
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec = fluid_solid_acoustic_ispec(inum)
- iedge = fluid_solid_acoustic_iedge(inum)
-
-! use pink color
- if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
-
- if(iedge == ITOP) then
- ideb = 3
- ifin = 4
- else if(iedge == IBOTTOM) then
- ideb = 1
- ifin = 2
- else if(iedge == ILEFT) then
- ideb = 4
- ifin = 1
- else if(iedge == IRIGHT) then
- ideb = 2
- ifin = 3
- else
- call exit_MPI('Wrong fluid-solid coupling edge code')
- endif
-
- x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
- z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
- x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
- z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,602) x1,z1,x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x1
- coorg_send(2,buffer_offset) = z1
- coorg_send(3,buffer_offset) = x2
- coorg_send(4,buffer_offset) = z2
- endif
-
- enddo
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
- if ( nspec_recv > 0 ) then
- allocate(coorg_recv(4,nspec_recv))
- call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
- MPI_DOUBLE_PRECISION, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
-
- buffer_offset = 0
- do ispec = 1, nspec_recv
- buffer_offset = buffer_offset + 1
- write(24,*) '1 0.75 0.8 RG'
- write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
- coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
- enddo
- deallocate(coorg_recv)
- endif
- enddo
- else
- call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
- if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
- deallocate(coorg_send)
- endif
- endif
-
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0 setlinewidth'
- endif
-
- endif
-
-!
-!---- draw the fluid-porous coupling edges with a thick color line
-!
- coupled_acoustic_poro_glob = coupled_acoustic_poro
-#ifdef USE_MPI
- call MPI_ALLREDUCE(coupled_acoustic_poro, coupled_acoustic_poro_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- if(coupled_acoustic_poro_glob .and. boundvect) then
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% fluid-porous coupling edges in the mesh'
- write(24,*) '%'
-
- write(24,*) '0.02 CM setlinewidth'
- endif
-
- if ( myrank /= 0 .and. num_fluid_poro_edges > 0 ) allocate(coorg_send(4,num_fluid_poro_edges))
- buffer_offset = 0
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_poro_edges
-
-! get the edge of the acoustic element
- ispec = fluid_poro_acoustic_ispec(inum)
- iedge = fluid_poro_acoustic_iedge(inum)
-
-! use pink color
- if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
-
- if(iedge == ITOP) then
- ideb = 3
- ifin = 4
- else if(iedge == IBOTTOM) then
- ideb = 1
- ifin = 2
- else if(iedge == ILEFT) then
- ideb = 4
- ifin = 1
- else if(iedge == IRIGHT) then
- ideb = 2
- ifin = 3
- else
- call exit_MPI('Wrong fluid-solid coupling edge code')
- endif
-
- x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
- z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
- x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
- z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,602) x1,z1,x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x1
- coorg_send(2,buffer_offset) = z1
- coorg_send(3,buffer_offset) = x2
- coorg_send(4,buffer_offset) = z2
- endif
-
- enddo
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
- if ( nspec_recv > 0 ) then
- allocate(coorg_recv(4,nspec_recv))
- call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
- MPI_DOUBLE_PRECISION, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
-
- buffer_offset = 0
- do ispec = 1, nspec_recv
- buffer_offset = buffer_offset + 1
- write(24,*) '1 0.75 0.8 RG'
- write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
- coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
- enddo
- deallocate(coorg_recv)
- endif
- enddo
- else
- call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
- if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
- deallocate(coorg_send)
- endif
- endif
-
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0 setlinewidth'
- endif
-
- endif
-
-!
-!---- draw the solid-porous coupling edges with a thick color line
-!
- coupled_elastic_poro_glob = coupled_elastic_poro
-#ifdef USE_MPI
- call MPI_ALLREDUCE(coupled_elastic_poro, coupled_elastic_poro_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- if(coupled_elastic_poro_glob .and. boundvect) then
-
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) '% solid-porous coupling edges in the mesh'
- write(24,*) '%'
-
- write(24,*) '0.02 CM setlinewidth'
- endif
-
- if ( myrank /= 0 .and. num_solid_poro_edges > 0 ) allocate(coorg_send(4,num_solid_poro_edges))
- buffer_offset = 0
-
-! loop on all the coupling edges
- do inum = 1,num_solid_poro_edges
-
-! get the edge of the poroelastic element
- ispec = solid_poro_poroelastic_ispec(inum)
- iedge = solid_poro_poroelastic_iedge(inum)
-
-! use pink color
- if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
-
- if(iedge == ITOP) then
- ideb = 3
- ifin = 4
- else if(iedge == IBOTTOM) then
- ideb = 1
- ifin = 2
- else if(iedge == ILEFT) then
- ideb = 4
- ifin = 1
- else if(iedge == IRIGHT) then
- ideb = 2
- ifin = 3
- else
- call exit_MPI('Wrong fluid-solid coupling edge code')
- endif
-
- x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
- z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
- x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
- z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- x2 = x2 * centim
- z2 = z2 * centim
- if ( myrank == 0 ) then
- write(24,602) x1,z1,x2,z2
- else
- buffer_offset = buffer_offset + 1
- coorg_send(1,buffer_offset) = x1
- coorg_send(2,buffer_offset) = z1
- coorg_send(3,buffer_offset) = x2
- coorg_send(4,buffer_offset) = z2
- endif
-
- enddo
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
- if ( nspec_recv > 0 ) then
- allocate(coorg_recv(4,nspec_recv))
- call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
- MPI_DOUBLE_PRECISION, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
-
- buffer_offset = 0
- do ispec = 1, nspec_recv
- buffer_offset = buffer_offset + 1
- write(24,*) '1 0.75 0.8 RG'
- write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
- coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
- enddo
- deallocate(coorg_recv)
- endif
- enddo
- else
- call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
- if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
- deallocate(coorg_send)
- endif
- endif
-
-#endif
-
- if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0 setlinewidth'
- endif
-
- endif
-
-!
-!---- draw the normalized vector field
-!
-
- if ( myrank == 0 ) then
-! return if the maximum vector equals zero (no source)
- if(dispmax == 0.d0) then
- write(IOUT,*) 'null vector: returning!'
- return
- endif
-
- write(24,*) '%'
- write(24,*) '% vector field'
- write(24,*) '%'
-
-! color arrows if we draw the velocity model in the background
- if(modelvect) then
- write(24,*) 'Colvects'
- else
- write(24,*) '0 setgray'
- endif
- endif
-
- if(interpol) then
-
- if (myrank == 0) write(IOUT,*) 'Interpolating the vector field...'
-
-! option to plot only lowerleft corner value to avoid very large files if dense meshes
- if(plot_lowerleft_corner_only) then
- pointsdisp_loop = 1
- else
- pointsdisp_loop = pointsdisp
- endif
-
- buffer_offset = 0
-
- do ispec=1,nspec
-
-! interpolation on a uniform grid
-#ifdef USE_MPI
- if(myrank == 0 .and. mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec,' on processor 0'
-#else
- if(mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec
-#endif
-
- do i=1,pointsdisp_loop
- do j=1,pointsdisp_loop
-
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
-
- Uxinterp(i,j) = 0.d0
- Uzinterp(i,j) = 0.d0
-
- do k=1,NGLLX
- do l=1,NGLLX
-
- Uxinterp(i,j) = Uxinterp(i,j) + displ(1,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
- Uzinterp(i,j) = Uzinterp(i,j) + displ(3,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
-
- enddo
- enddo
-
- x1 =(xinterp(i,j)-xmin)*ratio_page
- z1 =(zinterp(i,j)-zmin)*ratio_page
-
- x2 = Uxinterp(i,j)*sizemax_arrows/dispmax
- z2 = Uzinterp(i,j)*sizemax_arrows/dispmax
-
- d = sqrt(x2**2 + z2**2)
-
-! ignore if vector is too small
- if(d > cutsnaps*sizemax_arrows) then
-
- d1 = d * ARROW_RATIO
- d2 = d1 * cos(ARROW_ANGLE*convert)
-
- dummy = x2/d
- if(dummy > 0.9999d0) dummy = 0.9999d0
- if(dummy < -0.9999d0) dummy = -0.9999d0
- theta = acos(dummy)
-
- if(z2 < 0.d0) theta = 360.d0*convert - theta
- thetaup = theta - ARROW_ANGLE*convert
- thetadown = theta + ARROW_ANGLE*convert
-
-! draw the vector
- x1 = (orig_x+x1) * centim
- z1 = (orig_z+z1) * centim
- x2 = x2 * centim
- z2 = z2 * centim
- xa = -d2*cos(thetaup)
- za = -d2*sin(thetaup)
- xa = xa * centim
- za = za * centim
- xb = -d2*cos(thetadown)
- zb = -d2*sin(thetadown)
- xb = xb * centim
- zb = zb * centim
- if ( myrank == 0 ) then
- write(postscript_line,700) xb,zb,xa,za,x2,z2,x1,z1
-
-! suppress useless white spaces to make PostScript file smaller
-! suppress leading white spaces again, if any
- postscript_line = adjustl(postscript_line)
-
- line_length = len_trim(postscript_line)
- index_char = 1
- first = .false.
- do ii = 1,line_length-1
- if(ch1(ii) /= ' ' .or. first) then
- if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
- ch2(index_char) = ch1(ii)
- index_char = index_char + 1
- first = .true.
- endif
- endif
- enddo
- ch2(index_char) = ch1(line_length)
- write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
-
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_vector_field(1,buffer_offset) = xb
- coorg_send_ps_vector_field(2,buffer_offset) = zb
- coorg_send_ps_vector_field(3,buffer_offset) = xa
- coorg_send_ps_vector_field(4,buffer_offset) = za
- coorg_send_ps_vector_field(5,buffer_offset) = x2
- coorg_send_ps_vector_field(6,buffer_offset) = z2
- coorg_send_ps_vector_field(7,buffer_offset) = x1
- coorg_send_ps_vector_field(8,buffer_offset) = z1
- endif
-
- endif
-
- enddo
- enddo
- enddo
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 46, MPI_COMM_WORLD, request_mpi_status, ier)
- if ( nspec_recv > 0 ) then
- call MPI_RECV (coorg_recv_ps_vector_field(1,1), 8*nspec_recv, &
- MPI_DOUBLE_PRECISION, iproc, 46, MPI_COMM_WORLD, request_mpi_status, ier)
-
- buffer_offset = 0
- do ispec = 1, nspec_recv
- buffer_offset = buffer_offset + 1
- write(postscript_line,700) coorg_recv_ps_vector_field(1,buffer_offset), &
- coorg_recv_ps_vector_field(2,buffer_offset), &
- coorg_recv_ps_vector_field(3,buffer_offset), coorg_recv_ps_vector_field(4,buffer_offset), &
- coorg_recv_ps_vector_field(5,buffer_offset), coorg_recv_ps_vector_field(6,buffer_offset), &
- coorg_recv_ps_vector_field(7,buffer_offset), coorg_recv_ps_vector_field(8,buffer_offset)
-
- ! suppress useless white spaces to make PostScript file smaller
- ! suppress leading white spaces again, if any
- postscript_line = adjustl(postscript_line)
-
- line_length = len_trim(postscript_line)
- index_char = 1
- first = .false.
- do ii = 1,line_length-1
- if(ch1(ii) /= ' ' .or. first) then
- if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
- ch2(index_char) = ch1(ii)
- index_char = index_char + 1
- first = .true.
- endif
- endif
- enddo
- ch2(index_char) = ch1(line_length)
- write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
- enddo
- endif
- enddo
- else
- call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 46, MPI_COMM_WORLD, ier)
- if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send_ps_vector_field(1,1), 8*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 46, MPI_COMM_WORLD, ier)
- endif
-
- endif
-
-#endif
-
-
-! draw the vectors at the nodes of the mesh if we do not interpolate the display on a regular grid
- else
-
- buffer_offset = 0
-
- do ipoin=1,npoin
-
- x1 =(coord(1,ipoin)-xmin)*ratio_page
- z1 =(coord(2,ipoin)-zmin)*ratio_page
-
- x2 = displ(1,ipoin)*sizemax_arrows/dispmax
- z2 = displ(3,ipoin)*sizemax_arrows/dispmax
-
- d = sqrt(x2**2 + z2**2)
-
-! ignore if vector is too small
- if(d > cutsnaps*sizemax_arrows) then
-
- d1 = d * ARROW_RATIO
- d2 = d1 * cos(ARROW_ANGLE*convert)
-
- dummy = x2/d
- if(dummy > 0.9999d0) dummy = 0.9999d0
- if(dummy < -0.9999d0) dummy = -0.9999d0
- theta = acos(dummy)
-
- if(z2 < 0.d0) theta = 360.d0*convert - theta
- thetaup = theta - ARROW_ANGLE*convert
- thetadown = theta + ARROW_ANGLE*convert
-
-! draw the vector
- x1 = (orig_x+x1) * centim
- z1 = (orig_z+z1) * centim
- x2 = x2 * centim
- z2 = z2 * centim
- xa = -d2*cos(thetaup)
- za = -d2*sin(thetaup)
- xa = xa * centim
- za = za * centim
- xb = -d2*cos(thetadown)
- zb = -d2*sin(thetadown)
- xb = xb * centim
- zb = zb * centim
- if ( myrank == 0 ) then
- write(postscript_line,700) xb,zb,xa,za,x2,z2,x1,z1
-
-! suppress useless white spaces to make PostScript file smaller
-! suppress leading white spaces again, if any
- postscript_line = adjustl(postscript_line)
-
- line_length = len_trim(postscript_line)
- index_char = 1
- first = .false.
- do ii = 1,line_length-1
- if(ch1(ii) /= ' ' .or. first) then
- if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
- ch2(index_char) = ch1(ii)
- index_char = index_char + 1
- first = .true.
- endif
- endif
- enddo
- ch2(index_char) = ch1(line_length)
- write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
-
- else
- buffer_offset = buffer_offset + 1
- coorg_send_ps_vector_field(1,buffer_offset) = xb
- coorg_send_ps_vector_field(2,buffer_offset) = zb
- coorg_send_ps_vector_field(3,buffer_offset) = xa
- coorg_send_ps_vector_field(4,buffer_offset) = za
- coorg_send_ps_vector_field(5,buffer_offset) = x2
- coorg_send_ps_vector_field(6,buffer_offset) = z2
- coorg_send_ps_vector_field(7,buffer_offset) = x1
- coorg_send_ps_vector_field(8,buffer_offset) = z1
- endif
- endif
-
- enddo
-
-#ifdef USE_MPI
- if (myrank == 0 ) then
-
- do iproc = 1, nproc-1
- call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 47, MPI_COMM_WORLD, request_mpi_status, ier)
- if ( nspec_recv > 0 ) then
- call MPI_RECV (coorg_recv_ps_vector_field(1,1), 8*nspec_recv, &
- MPI_DOUBLE_PRECISION, iproc, 47, MPI_COMM_WORLD, request_mpi_status, ier)
-
- buffer_offset = 0
- do ispec = 1, nspec_recv
- buffer_offset = buffer_offset + 1
- write(postscript_line,700) coorg_recv_ps_vector_field(1,buffer_offset), &
- coorg_recv_ps_vector_field(2,buffer_offset), &
- coorg_recv_ps_vector_field(3,buffer_offset), coorg_recv_ps_vector_field(4,buffer_offset), &
- coorg_recv_ps_vector_field(5,buffer_offset), coorg_recv_ps_vector_field(6,buffer_offset), &
- coorg_recv_ps_vector_field(7,buffer_offset), coorg_recv_ps_vector_field(8,buffer_offset)
-
- ! suppress useless white spaces to make PostScript file smaller
- ! suppress leading white spaces again, if any
- postscript_line = adjustl(postscript_line)
-
- line_length = len_trim(postscript_line)
- index_char = 1
- first = .false.
- do ii = 1,line_length-1
- if(ch1(ii) /= ' ' .or. first) then
- if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
- ch2(index_char) = ch1(ii)
- index_char = index_char + 1
- first = .true.
- endif
- endif
- enddo
- ch2(index_char) = ch1(line_length)
- write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
- enddo
- endif
- enddo
- else
- call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 47, MPI_COMM_WORLD, ier)
- if ( buffer_offset > 0 ) then
- call MPI_SEND (coorg_send_ps_vector_field(1,1), 8*buffer_offset, &
- MPI_DOUBLE_PRECISION, 0, 47, MPI_COMM_WORLD, ier)
- endif
- endif
-
-#endif
-
- endif
-
- if ( myrank == 0 ) then
- write(24,*) '0 setgray'
-
-! sources and receivers in color if velocity model
- if(modelvect) then
- write(24,*) 'Colreceiv'
- else
- write(24,*) '0 setgray'
- endif
-
-!
-!---- write position of the source
-!
- do i=1,NSOURCES
- if(i == 1) write(24,*) '% beginning of source line'
- if(i == NSOURCES) write(24,*) '% end of source line'
- xw = x_source(i)
- zw = z_source(i)
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- write(24,500) xw,zw
- write(24,*) 'Cross'
- enddo
-
-!
-!---- write position of the receivers
-!
- do i=1,nrec
- if(i == 1) write(24,*) '% beginning of receiver line'
- if(i == nrec) write(24,*) '% end of receiver line'
-
- xw = st_xval(i)
- zw = st_zval(i)
-
- xw = (xw-xmin)*ratio_page + orig_x
- zw = (zw-zmin)*ratio_page + orig_z
- xw = xw * centim
- zw = zw * centim
- write(24,500) xw,zw
- write(24,*) 'Diamond'
- enddo
-
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
- endif
-
- 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a100,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
- 600 format(f6.3,' neg CM 0 MR (Time =',f8.3,' s) show')
- 601 format(f6.3,' neg CM 0 MR (Time =',1pe12.3,' s) show')
- 610 format(f6.3,' neg CM 0 MR (Time step = ',i7,') show')
- 620 format(f6.3,' neg CM 0 MR (Cut =',f5.2,' \%) show')
- 640 format(f6.3,' neg CM 0 MR (Max norm =',1pe12.3,') show')
-
- 499 format(f8.3,1x,f8.3,' L')
- 500 format(f8.3,1x,f8.3,' M')
- 502 format('fN (',i4,') Cshow')
- 679 format(f12.6,1x,f12.6,1x,f12.6,' RG fill stroke')
- 680 format(f12.6,1x,f12.6,1x,f12.6,' RG GF')
- 681 format(f6.2,1x,f6.2)
- 602 format(f6.2,1x,f6.2,' M ',f6.2,1x,f6.2,' L ST')
- 604 format('CP ',f12.6,' BK')
- 700 format(8(f6.2,1x),'F')
-
- end subroutine plotpost
-
Deleted: seismo/2D/SPECFEM2D/trunk/precision_mpi.h.in
===================================================================
--- seismo/2D/SPECFEM2D/trunk/precision_mpi.h.in 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/precision_mpi.h.in 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,17 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 2 D V e r s i o n 6 . 1
-!
-!=====================================================================
-
-! @configure_input@
-
-!
-! solver in single or double precision depending on the machine
-!
-! set to MPI_REAL to run in single precision
-! set to MPI_DOUBLE_PRECISION to run in double precision
-!
-! ALSO CHANGE FILE constants.h ACCORDINGLY
-!
- integer, parameter :: CUSTOM_MPI_TYPE = @CUSTOM_MPI_TYPE@
Deleted: seismo/2D/SPECFEM2D/trunk/prepare_absorb.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/prepare_absorb.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/prepare_absorb.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,522 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine prepare_absorb_files(myrank,any_elastic,any_poroelastic,any_acoustic, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,SIMULATION_TYPE)
-
- implicit none
- include "constants.h"
-
- integer :: myrank,SIMULATION_TYPE
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- logical :: any_elastic,any_poroelastic,any_acoustic
-
- ! local parameters
- character(len=150) :: outputname,outputname2
-
-
- if(any_elastic) then
-
- !--- left absorbing boundary
- if( nspec_xmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_elastic_left',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=35,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=35,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of left absorbing boundary
-
- !--- right absorbing boundary
- if( nspec_xmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_elastic_right',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=36,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=36,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of right absorbing boundary
-
- !--- bottom absorbing boundary
- if( nspec_zmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_elastic_bottom',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=37,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=37,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of bottom absorbing boundary
-
- !--- top absorbing boundary
- if( nspec_zmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_elastic_top',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=38,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=38,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of top absorbing boundary
-
- endif ! any_elastic
-
- if(any_poroelastic) then
-
- !--- left absorbing boundary
- if( nspec_xmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_poro_s_left',myrank,'.bin'
- write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_left',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=45,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- open(unit=25,file='OUTPUT_FILES/'//outputname2,status='old',&
- form='unformatted')
- else
- open(unit=45,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- open(unit=25,file='OUTPUT_FILES/'//outputname2,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of left absorbing boundary
-
- !--- right absorbing boundary
- if( nspec_xmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_poro_s_right',myrank,'.bin'
- write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_right',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=46,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- open(unit=26,file='OUTPUT_FILES/'//outputname2,status='old',&
- form='unformatted')
- else
- open(unit=46,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- open(unit=26,file='OUTPUT_FILES/'//outputname2,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of right absorbing boundary
-
- !--- bottom absorbing boundary
- if( nspec_zmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_poro_s_bottom',myrank,'.bin'
- write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_bottom',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=47,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- open(unit=29,file='OUTPUT_FILES/'//outputname2,status='old',&
- form='unformatted')
- else
- open(unit=47,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- open(unit=29,file='OUTPUT_FILES/'//outputname2,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of bottom absorbing boundary
-
- !--- top absorbing boundary
- if( nspec_zmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_poro_s_top',myrank,'.bin'
- write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_top',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=48,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- open(unit=28,file='OUTPUT_FILES/'//outputname2,status='old',&
- form='unformatted')
- else
- open(unit=48,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- open(unit=28,file='OUTPUT_FILES/'//outputname2,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of top absorbing boundary
-
- endif !any_poroelastic
-
- if(any_acoustic) then
-
- !--- left absorbing boundary
- if( nspec_xmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_acoustic_left',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=65,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=65,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of left absorbing boundary
-
- !--- right absorbing boundary
- if( nspec_xmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_acoustic_right',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=66,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=66,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of right absorbing boundary
-
- !--- bottom absorbing boundary
- if( nspec_zmin >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_acoustic_bottom',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=67,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=67,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of bottom absorbing boundary
-
- !--- top absorbing boundary
- if( nspec_zmax >0 ) then
- write(outputname,'(a,i6.6,a)') 'absorb_acoustic_top',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- open(unit=68,file='OUTPUT_FILES/'//outputname,status='old',&
- form='unformatted')
- else
- open(unit=68,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted')
- endif
-
- endif ! end of top absorbing boundary
-
- endif !any_acoustic
-
-
- end subroutine prepare_absorb_files
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_absorb_elastic(NSTEP,p_sv, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_elastic_left,b_absorb_elastic_right, &
- b_absorb_elastic_bottom,b_absorb_elastic_top)
-
- implicit none
- include "constants.h"
-
- logical :: p_sv
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer :: NSTEP
- real(kind=CUSTOM_REAL) :: b_absorb_elastic_left(3,NGLLZ,nspec_xmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_elastic_right(3,NGLLZ,nspec_xmax,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_elastic_bottom(3,NGLLX,nspec_zmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_elastic_top(3,NGLLX,nspec_zmax,NSTEP)
-
- ! local parameters
- integer :: ispec,i,it
-
- do it =1, NSTEP
-
- !--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLZ
- read(35) b_absorb_elastic_left(1,i,ispec,it)
- enddo
- do i=1,NGLLZ
- read(35) b_absorb_elastic_left(3,i,ispec,it)
- enddo
- b_absorb_elastic_left(2,:,ispec,it) = ZERO
- else!SH (membrane) waves
- do i=1,NGLLZ
- read(35) b_absorb_elastic_left(2,i,ispec,it)
- enddo
- b_absorb_elastic_left(1,:,ispec,it) = ZERO
- b_absorb_elastic_left(3,:,ispec,it) = ZERO
- endif
-
- enddo
- endif
-
- !--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLZ
- read(36) b_absorb_elastic_right(1,i,ispec,it)
- enddo
- do i=1,NGLLZ
- read(36) b_absorb_elastic_right(3,i,ispec,it)
- enddo
- b_absorb_elastic_right(2,:,ispec,it) = ZERO
- else!SH (membrane) waves
- do i=1,NGLLZ
- read(36) b_absorb_elastic_right(2,i,ispec,it)
- enddo
- b_absorb_elastic_right(1,:,ispec,it) = ZERO
- b_absorb_elastic_right(3,:,ispec,it) = ZERO
- endif
-
- enddo
- endif
-
- !--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLX
- read(37) b_absorb_elastic_bottom(1,i,ispec,it)
- enddo
- do i=1,NGLLX
- read(37) b_absorb_elastic_bottom(3,i,ispec,it)
- enddo
- b_absorb_elastic_bottom(2,:,ispec,it) = ZERO
- else!SH (membrane) waves
- do i=1,NGLLZ
- read(37) b_absorb_elastic_bottom(2,i,ispec,it)
- enddo
- b_absorb_elastic_bottom(1,:,ispec,it) = ZERO
- b_absorb_elastic_bottom(3,:,ispec,it) = ZERO
- endif
-
- enddo
- endif
-
- !--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLX
- read(38) b_absorb_elastic_top(1,i,ispec,it)
- enddo
- do i=1,NGLLX
- read(38) b_absorb_elastic_top(3,i,ispec,it)
- enddo
- b_absorb_elastic_top(2,:,ispec,it) = ZERO
- else!SH (membrane) waves
- do i=1,NGLLZ
- read(38) b_absorb_elastic_top(2,i,ispec,it)
- enddo
- b_absorb_elastic_top(1,:,ispec,it) = ZERO
- b_absorb_elastic_top(3,:,ispec,it) = ZERO
- endif
-
- enddo
- endif
-
- enddo
-
- end subroutine prepare_absorb_elastic
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_absorb_poroelastic(NSTEP, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_poro_s_left,b_absorb_poro_w_left, &
- b_absorb_poro_s_right,b_absorb_poro_w_right, &
- b_absorb_poro_s_bottom,b_absorb_poro_w_bottom, &
- b_absorb_poro_s_top,b_absorb_poro_w_top)
-
- implicit none
- include "constants.h"
-
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
-
- integer :: NSTEP
- real(kind=CUSTOM_REAL) :: b_absorb_poro_s_left(NDIM,NGLLZ,nspec_xmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_s_right(NDIM,NGLLZ,nspec_xmax,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_s_bottom(NDIM,NGLLX,nspec_zmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_s_top(NDIM,NGLLX,nspec_zmax,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_w_left(NDIM,NGLLZ,nspec_xmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_w_right(NDIM,NGLLZ,nspec_xmax,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_w_bottom(NDIM,NGLLX,nspec_zmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_poro_w_top(NDIM,NGLLX,nspec_zmax,NSTEP)
-
- ! local parameters
- integer :: ispec,i,it,id
-
- do it =1, NSTEP
-
- !--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
- do id =1,2
- do i=1,NGLLZ
- read(45) b_absorb_poro_s_left(id,i,ispec,it)
- read(25) b_absorb_poro_w_left(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
- !--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
- do id =1,2
- do i=1,NGLLZ
- read(46) b_absorb_poro_s_right(id,i,ispec,it)
- read(26) b_absorb_poro_w_right(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
- !--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
- do id =1,2
- do i=1,NGLLX
- read(47) b_absorb_poro_s_bottom(id,i,ispec,it)
- read(29) b_absorb_poro_w_bottom(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
- !--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
- do id =1,2
- do i=1,NGLLX
- read(48) b_absorb_poro_s_top(id,i,ispec,it)
- read(28) b_absorb_poro_w_top(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
- enddo
-
- end subroutine prepare_absorb_poroelastic
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_absorb_acoustic(NSTEP, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_acoustic_left,b_absorb_acoustic_right, &
- b_absorb_acoustic_bottom,b_absorb_acoustic_top)
-
- implicit none
- include "constants.h"
-
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
-
- integer :: NSTEP
- real(kind=CUSTOM_REAL) :: b_absorb_acoustic_left(NGLLZ,nspec_xmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_acoustic_right(NGLLZ,nspec_xmax,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_acoustic_bottom(NGLLX,nspec_zmin,NSTEP)
- real(kind=CUSTOM_REAL) :: b_absorb_acoustic_top(NGLLX,nspec_zmax,NSTEP)
-
-
- ! local parameters
- integer :: ispec,i,it
-
- do it =1, NSTEP
-
- !--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
- do i=1,NGLLZ
- read(65) b_absorb_acoustic_left(i,ispec,it)
- enddo
- enddo
- endif
-
- !--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
- do i=1,NGLLZ
- read(66) b_absorb_acoustic_right(i,ispec,it)
- enddo
- enddo
- endif
-
- !--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
- do i=1,NGLLX
- read(67) b_absorb_acoustic_bottom(i,ispec,it)
- enddo
- enddo
- endif
-
- !--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
- do i=1,NGLLX
- read(68) b_absorb_acoustic_top(i,ispec,it)
- enddo
- enddo
- endif
-
- enddo
-
- end subroutine prepare_absorb_acoustic
-
\ No newline at end of file
Deleted: seismo/2D/SPECFEM2D/trunk/prepare_assemble_MPI.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/prepare_assemble_MPI.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/prepare_assemble_MPI.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,340 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!
-! This file contains subroutines related to assembling (of the mass matrix, potential_dot_dot and
-! accel_elastic, accels_poroelastic, accelw_poroelastic).
-! These subroutines are for the most part not used in the sequential version.
-!
-
-#ifdef USE_MPI
-
-!-----------------------------------------------
-! Determines the points that are on the interfaces with other partitions, to help
-! build the communication buffers, and determines which elements are considered 'inner'
-! (no points in common with other partitions) and 'outer' (at least one point in common
-! with neighbouring partitions).
-! We have both acoustic and (poro)elastic buffers, for coupling between acoustic and (poro)elastic elements
-! led us to have two sets of communications.
-!-----------------------------------------------
- subroutine prepare_assemble_MPI(nspec,ibool,knods, ngnod,npoin, elastic, poroelastic, &
- ninterface, max_interface_size, &
- my_nelmnts_neighbours, my_interfaces, &
- ibool_interfaces_acoustic, ibool_interfaces_elastic, &
- ibool_interfaces_poroelastic, &
- nibool_interfaces_acoustic, nibool_interfaces_elastic, &
- nibool_interfaces_poroelastic, &
- inum_interfaces_acoustic, inum_interfaces_elastic, &
- inum_interfaces_poroelastic, &
- ninterface_acoustic, ninterface_elastic, ninterface_poroelastic, &
- mask_ispec_inner_outer )
-
- implicit none
-
- include 'constants.h'
-
- integer, intent(in) :: nspec, npoin, ngnod
- logical, dimension(nspec), intent(in) :: elastic, poroelastic
- integer, dimension(ngnod,nspec), intent(in) :: knods
- integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
-
- integer :: ninterface
- integer :: max_interface_size
- integer, dimension(ninterface) :: my_nelmnts_neighbours
- integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
- integer, dimension(NGLLX*max_interface_size,ninterface) :: &
- ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
- integer, dimension(ninterface) :: &
- nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
-
- integer, dimension(ninterface), intent(out) :: &
- inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
- integer, intent(out) :: ninterface_acoustic, ninterface_elastic, ninterface_poroelastic
-
- logical, dimension(nspec), intent(inout) :: mask_ispec_inner_outer
-
- ! local parameters
- integer :: num_interface
- integer :: ispec_interface
- logical, dimension(npoin) :: mask_ibool_acoustic
- logical, dimension(npoin) :: mask_ibool_elastic
- logical, dimension(npoin) :: mask_ibool_poroelastic
- integer :: ixmin, ixmax, izmin, izmax, ix, iz
- integer, dimension(ngnod) :: n
- integer :: e1, e2, itype, ispec, k, sens, iglob
- integer :: npoin_interface_acoustic
- integer :: npoin_interface_elastic
- integer :: npoin_interface_poroelastic
-
- ! initializes
- ibool_interfaces_acoustic(:,:) = 0
- nibool_interfaces_acoustic(:) = 0
- ibool_interfaces_elastic(:,:) = 0
- nibool_interfaces_elastic(:) = 0
- ibool_interfaces_poroelastic(:,:) = 0
- nibool_interfaces_poroelastic(:) = 0
-
- do num_interface = 1, ninterface
- ! initializes interface point counters
- npoin_interface_acoustic = 0
- npoin_interface_elastic = 0
- npoin_interface_poroelastic = 0
- mask_ibool_acoustic(:) = .false.
- mask_ibool_elastic(:) = .false.
- mask_ibool_poroelastic(:) = .false.
-
- do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
- ! element id
- ispec = my_interfaces(1,ispec_interface,num_interface)
- ! type of interface: 1 = common point, 2 = common edge
- itype = my_interfaces(2,ispec_interface,num_interface)
- ! element control node ids
- do k = 1, ngnod
- n(k) = knods(k,ispec)
- end do
- ! common node ids
- e1 = my_interfaces(3,ispec_interface,num_interface)
- e2 = my_interfaces(4,ispec_interface,num_interface)
-
- call get_edge(ngnod, n, itype, e1, e2, ixmin, ixmax, izmin, izmax, sens)
-
- do iz = izmin, izmax, sens
- do ix = ixmin, ixmax, sens
- ! global index
- iglob = ibool(ix,iz,ispec)
-
- ! checks to which material this common interface belongs
- if ( elastic(ispec) ) then
- ! elastic element
- if(.not. mask_ibool_elastic(iglob)) then
- mask_ibool_elastic(iglob) = .true.
- npoin_interface_elastic = npoin_interface_elastic + 1
- ibool_interfaces_elastic(npoin_interface_elastic,num_interface) = iglob
- end if
- else if ( poroelastic(ispec) ) then
- ! poroelastic element
- if(.not. mask_ibool_poroelastic(iglob)) then
- mask_ibool_poroelastic(iglob) = .true.
- npoin_interface_poroelastic = npoin_interface_poroelastic + 1
- ibool_interfaces_poroelastic(npoin_interface_poroelastic,num_interface) = iglob
- end if
- else
- ! acoustic element
- if(.not. mask_ibool_acoustic(iglob)) then
- mask_ibool_acoustic(iglob) = .true.
- npoin_interface_acoustic = npoin_interface_acoustic + 1
- ibool_interfaces_acoustic(npoin_interface_acoustic,num_interface) = iglob
- end if
- end if
- end do
- end do
-
- end do
-
- ! stores counters for interface points
- nibool_interfaces_acoustic(num_interface) = npoin_interface_acoustic
- nibool_interfaces_elastic(num_interface) = npoin_interface_elastic
- nibool_interfaces_poroelastic(num_interface) = npoin_interface_poroelastic
-
- ! sets inner/outer element flags
- do ispec = 1, nspec
- do iz = 1, NGLLZ
- do ix = 1, NGLLX
- if ( mask_ibool_acoustic(ibool(ix,iz,ispec)) &
- .or. mask_ibool_elastic(ibool(ix,iz,ispec)) &
- .or. mask_ibool_poroelastic(ibool(ix,iz,ispec)) ) then
- mask_ispec_inner_outer(ispec) = .true.
- endif
-
- enddo
- enddo
- enddo
-
- end do
-
- ! sets number of interfaces for each material domain
- ninterface_acoustic = 0
- ninterface_elastic = 0
- ninterface_poroelastic = 0
-
- ! loops over all MPI interfaces
- do num_interface = 1, ninterface
- ! sets acoustic MPI interface (local) indices in range [1,ninterface_acoustic]
- if ( nibool_interfaces_acoustic(num_interface) > 0 ) then
- ninterface_acoustic = ninterface_acoustic + 1
- inum_interfaces_acoustic(ninterface_acoustic) = num_interface
- end if
- ! elastic
- if ( nibool_interfaces_elastic(num_interface) > 0 ) then
- ninterface_elastic = ninterface_elastic + 1
- inum_interfaces_elastic(ninterface_elastic) = num_interface
- end if
- ! poroelastic
- if ( nibool_interfaces_poroelastic(num_interface) > 0 ) then
- ninterface_poroelastic = ninterface_poroelastic + 1
- inum_interfaces_poroelastic(ninterface_poroelastic) = num_interface
- end if
- end do
-
- end subroutine prepare_assemble_MPI
-
-
-!-----------------------------------------------
-! Get the points (ixmin, ixmax, izmin and izmax) on an node/edge for one element.
-! 'sens' is used to have DO loops with increment equal to 'sens' (-/+1).
-!-----------------------------------------------
- subroutine get_edge ( ngnod, n, itype, e1, e2, ixmin, ixmax, izmin, izmax, sens )
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: ngnod
- integer, dimension(ngnod), intent(in) :: n
- integer, intent(in) :: itype, e1, e2
- integer, intent(out) :: ixmin, ixmax, izmin, izmax
- integer, intent(out) :: sens
-
- if ( itype == 1 ) then
-
- ! common single point
-
- ! checks which corner point is given
- if ( e1 == n(1) ) then
- ixmin = 1
- ixmax = 1
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- if ( e1 == n(4) ) then
- ixmin = 1
- ixmax = 1
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- sens = 1
-
- else if( itype == 2 ) then
-
- ! common edge
-
- ! checks which edge and corner points are given
- if ( e1 == n(1) ) then
- ixmin = 1
- izmin = 1
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- izmax = 1
- sens = 1
- end if
- if ( e2 == n(4) ) then
- ixmax = 1
- izmax = NGLLZ
- sens = 1
- end if
- end if
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- izmin = 1
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- izmax = NGLLZ
- sens = 1
- end if
- if ( e2 == n(1) ) then
- ixmax = 1
- izmax = 1
- sens = -1
- end if
- end if
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- izmin = NGLLZ
- if ( e2 == n(4) ) then
- ixmax = 1
- izmax = NGLLZ
- sens = -1
- end if
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- izmax = 1
- sens = -1
- end if
- end if
- if ( e1 == n(4) ) then
- ixmin = 1
- izmin = NGLLZ
- if ( e2 == n(1) ) then
- ixmax = 1
- izmax = 1
- sens = -1
- end if
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- izmax = NGLLZ
- sens = 1
- end if
- end if
-
- else
-
- call exit_MPI('ERROR get_edge unknown type')
-
- end if
-
- end subroutine get_edge
-
-#endif
Deleted: seismo/2D/SPECFEM2D/trunk/prepare_color_image.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/prepare_color_image.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/prepare_color_image.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,436 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine prepare_color_image_init(NX_IMAGE_color,NZ_IMAGE_color, &
- xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image, &
- coord,npoin,npgeo)
-
- implicit none
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: NX_IMAGE_color,NZ_IMAGE_color
-
- integer :: npoin,npgeo
- double precision, dimension(NDIM,npoin) :: coord
-
- double precision :: xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image
-
- ! local parameters
- integer :: npgeo_glob
- double precision :: xmin_color_image_loc, xmax_color_image_loc, &
- zmin_color_image_loc,zmax_color_image_loc
-#ifdef USE_MPI
- integer :: ier
-#endif
-
- ! horizontal size of the image
- xmin_color_image_loc = minval(coord(1,:))
- xmax_color_image_loc = maxval(coord(1,:))
-
- ! vertical size of the image, slightly increase it to go beyond maximum topography
- zmin_color_image_loc = minval(coord(2,:))
- zmax_color_image_loc = maxval(coord(2,:))
-
-! global values
- xmin_color_image = xmin_color_image_loc
- xmax_color_image = xmax_color_image_loc
- zmin_color_image = zmin_color_image_loc
- zmax_color_image = zmax_color_image_loc
- npgeo_glob = npgeo
-
-#ifdef USE_MPI
- call MPI_ALLREDUCE(xmin_color_image_loc, xmin_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE(xmax_color_image_loc, xmax_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE(zmin_color_image_loc, zmin_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE(zmax_color_image_loc, zmax_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE(npgeo, npgeo_glob, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ier)
-#endif
-
- zmax_color_image = zmin_color_image + 1.05d0 * (zmax_color_image - zmin_color_image)
-
- ! compute number of pixels in the horizontal direction based on typical number
- ! of spectral elements in a given direction (may give bad results for very elongated models)
- NX_IMAGE_color = nint(sqrt(dble(npgeo_glob))) * (NGLLX-1) + 1
-
- ! compute number of pixels in the vertical direction based on ratio of sizes
- NZ_IMAGE_color = nint(NX_IMAGE_color * (zmax_color_image - zmin_color_image) &
- / (xmax_color_image - xmin_color_image))
-
- ! convert pixel sizes to even numbers because easier to reduce size,
- ! create MPEG movies in postprocessing
- NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
- NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
-
- ! check that image size is not too big
- if (NX_IMAGE_color > 99999) call exit_MPI('output image too big : NX_IMAGE_color > 99999.')
- if (NZ_IMAGE_color > 99999) call exit_MPI('output image too big : NZ_IMAGE_color > 99999.')
-
- end subroutine prepare_color_image_init
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_color_image_pixels(myrank,NX_IMAGE_color,NZ_IMAGE_color, &
- xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image, &
- coord,npoin,coorg,npgeo,nspec,ngnod,knods,ibool, &
- nb_pixel_loc,iglob_image_color)
-
- implicit none
- include "constants.h"
-
- integer :: myrank
- integer :: NX_IMAGE_color,NZ_IMAGE_color
- double precision :: xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image
-
- integer :: npoin,nspec,npgeo,ngnod
- double precision, dimension(NDIM,npoin) :: coord
- double precision, dimension(NDIM,npgeo) :: coorg
-
- integer, dimension(ngnod,nspec) :: knods
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- integer :: nb_pixel_loc
- integer, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: iglob_image_color
-
- ! local parameters
- double precision :: size_pixel_horizontal,size_pixel_vertical
- double precision, dimension(2,4) :: elmnt_coords
- double precision :: i_coord, j_coord
- double precision :: dist_pixel, dist_min_pixel
- integer :: min_i, min_j, max_i, max_j
- integer :: ispec,i,j,k,l,iglob
- logical :: pixel_is_in
-
- ! create all the pixels
- if (myrank == 0) then
- write(IOUT,*)
- write(IOUT,*) 'locating all the pixels of color images'
- endif
-
- size_pixel_horizontal = (xmax_color_image - xmin_color_image) / dble(NX_IMAGE_color-1)
- size_pixel_vertical = (zmax_color_image - zmin_color_image) / dble(NZ_IMAGE_color-1)
-
- iglob_image_color(:,:) = -1
-
- ! checking which pixels are inside each elements
-
- nb_pixel_loc = 0
- do ispec = 1, nspec
-
- do k = 1, 4
- elmnt_coords(1,k) = coorg(1,knods(k,ispec))
- elmnt_coords(2,k) = coorg(2,knods(k,ispec))
- enddo
-
- ! avoid working on the whole pixel grid
- min_i = floor(minval((elmnt_coords(1,:) - xmin_color_image))/size_pixel_horizontal) + 1
- max_i = ceiling(maxval((elmnt_coords(1,:) - xmin_color_image))/size_pixel_horizontal) + 1
- min_j = floor(minval((elmnt_coords(2,:) - zmin_color_image))/size_pixel_vertical) + 1
- max_j = ceiling(maxval((elmnt_coords(2,:) - zmin_color_image))/size_pixel_vertical) + 1
-
- ! avoid edge effects
- if(min_i < 1) min_i = 1
- if(min_j < 1) min_j = 1
-
- if(max_i > NX_IMAGE_color) max_i = NX_IMAGE_color
- if(max_j > NZ_IMAGE_color) max_j = NZ_IMAGE_color
-
- do j = min_j, max_j
- do i = min_i, max_i
- i_coord = (i-1)*size_pixel_horizontal + xmin_color_image
- j_coord = (j-1)*size_pixel_vertical + zmin_color_image
-
- ! checking if the pixel is inside the element (must be a convex quadrilateral)
- call is_in_convex_quadrilateral( elmnt_coords, i_coord, j_coord, pixel_is_in)
-
- ! if inside, getting the nearest point inside the element!
- if ( pixel_is_in ) then
- dist_min_pixel = HUGEVAL
- do k = 1, NGLLX
- do l = 1, NGLLZ
- iglob = ibool(k,l,ispec)
- dist_pixel = (coord(1,iglob)-i_coord)**2 + (coord(2,iglob)-j_coord)**2
- if (dist_pixel < dist_min_pixel) then
- dist_min_pixel = dist_pixel
- iglob_image_color(i,j) = iglob
-
- endif
-
- enddo
- enddo
- if ( dist_min_pixel >= HUGEVAL ) then
- call exit_MPI('Error in detecting pixel for color image')
-
- endif
- nb_pixel_loc = nb_pixel_loc + 1
-
- endif
-
- enddo
- enddo
- enddo
-
- end subroutine prepare_color_image_pixels
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine prepare_color_image_vp(npoin,image_color_vp_display,iglob_image_color, &
- NX_IMAGE_color,NZ_IMAGE_color,nb_pixel_loc, &
- num_pixel_loc,nspec,poroelastic,ibool,kmato, &
- numat,density,poroelastcoef,porosity,tortuosity, &
- nproc,myrank,assign_external_model,vpext)
-
-! stores P-velocity model in image_color_vp_display
-
- implicit none
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: npoin,nspec
- integer :: NX_IMAGE_color,NZ_IMAGE_color
- double precision, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: image_color_vp_display
- integer, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: iglob_image_color
-
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: kmato
-
- logical, dimension(nspec) :: poroelastic
-
- integer :: nb_pixel_loc
- integer, dimension(nb_pixel_loc) :: num_pixel_loc
-
- logical :: assign_external_model
- integer :: nproc,myrank
- integer :: numat
- double precision, dimension(2,numat) :: density
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(numat) :: porosity,tortuosity
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext
-
- ! local parameters
- double precision, dimension(:), allocatable :: vp_display
- double precision :: rhol,mul_relaxed,lambdal_relaxed
- double precision :: rhol_s,rhol_f,rhol_bar,phil,tortl,mul_s,kappal_s,kappal_f, &
- mul_fr,kappal_fr
- double precision :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,&
- M_biot,B_biot,cpIsquare,cpIIsquare,cssquare
- double precision :: gamma1,gamma2,gamma3,gamma4,ratio
- integer :: i,j,k,ispec
-#ifdef USE_MPI
- double precision, dimension(:), allocatable :: data_pixel_recv
- double precision, dimension(:), allocatable :: data_pixel_send
- integer, dimension(:,:), allocatable :: num_pixel_recv
- integer, dimension(:), allocatable :: nb_pixel_per_proc
- integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
- integer :: ier,iproc
-#else
- integer :: dummy
-#endif
-
- ! to display the P-velocity model in background on color images
- allocate(vp_display(npoin))
-
- do ispec = 1,nspec
-
- if(poroelastic(ispec)) then
- !get parameters of current spectral element
- phil = porosity(kmato(ispec))
- tortl = tortuosity(kmato(ispec))
- !solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec))
- kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4.d0*mul_s/3.d0
- rhol_s = density(1,kmato(ispec))
- !fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec))
- rhol_f = density(2,kmato(ispec))
- !frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec))
- kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4.d0*mul_fr/3.d0
- rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
- !Biot coefficients for the input phi
- D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
- + kappal_fr + 4.d0*mul_fr/3.d0
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
- B_biot = H_biot - 4.d0*mul_fr/3.d0
- ! Approximated velocities (no viscous dissipation)
- afactor = rhol_bar - phil/tortl*rhol_f
- bfactor = H_biot + phil*rhol_bar/(tortl*rhol_f)*M_biot - TWO*phil/tortl*C_biot
- cfactor = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
- cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
- cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
- cssquare = mul_fr/afactor
-
- ! Approximated ratio r = amplitude "w" field/amplitude "s" field (no viscous dissipation)
- ! used later for wavespeed kernels calculation, which are presently implemented for inviscid case,
- ! contrary to primary and density-normalized kernels, which are consistent with viscous fluid case.
- gamma1 = H_biot - phil/tortl*C_biot
- gamma2 = C_biot - phil/tortl*M_biot
- gamma3 = phil/tortl*( M_biot*(afactor/rhol_f + phil/tortl) - C_biot)
- gamma4 = phil/tortl*( C_biot*(afactor/rhol_f + phil/tortl) - H_biot)
- ratio = HALF*(gamma1 - gamma3)/gamma4 &
- + HALF*sqrt((gamma1-gamma3)**2/gamma4**2 &
- + 4.d0 * gamma2/gamma4)
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
- vp_display(ibool(i,j,ispec)) = sqrt(cpIsquare)
- enddo
- enddo
-
- else
- ! get relaxed elastic parameters of current spectral element
- rhol = density(1,kmato(ispec))
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- do j = 1,NGLLZ
- do i = 1,NGLLX
- !--- if external medium, get elastic parameters of current grid point
- if(assign_external_model) then
- vp_display(ibool(i,j,ispec)) = vpext(i,j,ispec)
- else
- vp_display(ibool(i,j,ispec)) = sqrt((lambdal_relaxed + 2.d0*mul_relaxed) / rhol)
- endif
- enddo
- enddo
- endif !if(poroelastic(ispec)) then
- enddo
-
- ! getting velocity for each local pixels
- image_color_vp_display(:,:) = 0.d0
-
- do k = 1, nb_pixel_loc
- j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
- i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
- image_color_vp_display(i,j) = vp_display(iglob_image_color(i,j))
- enddo
-
-! assembling array image_color_vp_display on process zero for color output
-#ifdef USE_MPI
-
- allocate(nb_pixel_per_proc(nproc))
- nb_pixel_per_proc(:) = 0
- call MPI_GATHER( nb_pixel_loc, 1, MPI_INTEGER, nb_pixel_per_proc(1), &
- 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ier)
-
-
- if ( myrank == 0 ) then
- allocate(num_pixel_recv(maxval(nb_pixel_per_proc(:)),nproc))
- allocate(data_pixel_recv(maxval(nb_pixel_per_proc(:))))
- endif
- allocate(data_pixel_send(nb_pixel_loc))
-
- if (nproc > 1) then
- if (myrank == 0) then
- do iproc = 1, nproc-1
-
- call MPI_RECV(num_pixel_recv(1,iproc+1),nb_pixel_per_proc(iproc+1), MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
-
- call MPI_RECV(data_pixel_recv(1),nb_pixel_per_proc(iproc+1), MPI_DOUBLE_PRECISION, &
- iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
-
- do k = 1, nb_pixel_per_proc(iproc+1)
- j = ceiling(real(num_pixel_recv(k,iproc+1)) / real(NX_IMAGE_color))
- i = num_pixel_recv(k,iproc+1) - (j-1)*NX_IMAGE_color
-
- ! checks bounds
- if( i < 1 .or. i > NX_IMAGE_color .or. j < 1 .or. j > NZ_IMAGE_color ) then
- print*,'image vp bounds:',myrank,iproc,k, &
- num_pixel_recv(k,iproc+1),nb_pixel_per_proc(iproc+1)
- print*,' i: ',i,NX_IMAGE_color
- print*,' j: ',j,NZ_IMAGE_color
- endif
-
- image_color_vp_display(i,j) = data_pixel_recv(k)
- enddo
- enddo
-
- else
- do k = 1, nb_pixel_loc
- j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
- i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
- data_pixel_send(k) = vp_display(iglob_image_color(i,j))
- enddo
-
- call MPI_SEND(num_pixel_loc(1),nb_pixel_loc,MPI_INTEGER, &
- 0, 42, MPI_COMM_WORLD, ier)
-
- call MPI_SEND(data_pixel_send(1),nb_pixel_loc,MPI_DOUBLE_PRECISION, &
- 0, 43, MPI_COMM_WORLD, ier)
-
- endif
- endif
-
- deallocate(nb_pixel_per_proc)
- deallocate(data_pixel_send)
- if( myrank == 0 ) then
- deallocate(num_pixel_recv)
- deallocate(data_pixel_recv)
- endif
-#else
- ! to avoid compiler warnings
- dummy = myrank
- dummy = nproc
-#endif
-
- end subroutine prepare_color_image_vp
Deleted: seismo/2D/SPECFEM2D/trunk/prepare_initialfield.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/prepare_initialfield.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/prepare_initialfield.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,395 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine prepare_initialfield(myrank,any_acoustic,any_poroelastic,over_critical_angle, &
- NSOURCES,source_type,angleforce,x_source,z_source,f0, &
- npoin,numat,poroelastcoef,density,coord, &
- angleforce_refl,c_inc,c_refl,cploc,csloc,time_offset, &
- A_plane, B_plane, C_plane, &
- accel_elastic,veloc_elastic,displ_elastic)
-
- implicit none
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: myrank
- logical :: any_acoustic,any_poroelastic
-
- integer :: NSOURCES
- integer, dimension(NSOURCES) :: source_type
- double precision, dimension(NSOURCES) :: angleforce,x_source,z_source,f0
-
- integer :: npoin,numat
- double precision, dimension(4,3,numat) :: poroelastcoef
- double precision, dimension(2,numat) :: density
- double precision, dimension(NDIM,npoin) :: coord
-
- double precision :: angleforce_refl,c_inc,c_refl,cploc,csloc
- double precision :: time_offset,x0_source,z0_source
- double precision, dimension(2) :: A_plane, B_plane, C_plane
-
- real(kind=CUSTOM_REAL), dimension(3,npoin) :: accel_elastic,veloc_elastic,displ_elastic
-
- logical :: over_critical_angle
-
- ! local parameters
- integer :: numat_local,i
- double precision :: denst,lambdaplus2mu,mu,p
- double precision :: PP,PS,SP,SS
- double precision :: xmax, xmin, zmax, zmin,x,z,t
-#ifdef USE_MPI
- double precision :: xmax_glob, xmin_glob, zmax_glob, zmin_glob
- integer :: ier
-#endif
- double precision, external :: ricker_Bielak_displ,ricker_Bielak_veloc,ricker_Bielak_accel
-
- ! user output
- if (myrank == 0) then
- write(IOUT,*)
- !! DK DK reading of an initial field from an external file has been suppressed
- !! DK DK and replaced with the implementation of an analytical plane wave
- !! DK DK write(IOUT,*) 'Reading initial fields from external file...'
- write(IOUT,*) 'Implementing an analytical initial plane wave...'
- write(IOUT,*)
- endif
-
- if(any_acoustic .or. any_poroelastic) &
- call exit_MPI('initial field currently implemented for purely elastic simulation only')
-
- !=======================================================================
- !
- ! Calculation of the initial field for a plane wave
- !
- !=======================================================================
-
- if (myrank == 0) then
- write(IOUT,*) 'Number of grid points: ',npoin
- write(IOUT,*)
- write(IOUT,*) '*** calculation of the initial plane wave ***'
- write(IOUT,*)
- write(IOUT,*) 'To change the initial plane wave, change source_type in DATA/SOURCE'
- write(IOUT,*) 'and use 1 for a plane P wave, 2 for a plane SV wave, 3 for a Rayleigh wave'
- write(IOUT,*)
-
- ! only implemented for one source
- if(NSOURCES > 1) call exit_MPI('calculation of the initial wave is only implemented for one source')
- if (source_type(1) == 1) then
- write(IOUT,*) 'initial P wave of', angleforce(1)*180.d0/pi, 'degrees introduced.'
- else if (source_type(1) == 2) then
- write(IOUT,*) 'initial SV wave of', angleforce(1)*180.d0/pi, ' degrees introduced.'
-
- else if (source_type(1) == 3) then
- write(IOUT,*) 'Rayleigh wave introduced.'
- else
- call exit_MPI('Unrecognized source_type: should be 1 for plane P waves, 2 for plane SV waves, 3 for Rayleigh wave')
- endif
-
- if ((angleforce(1) < 0.0d0 .or. angleforce(1) >= pi/2.d0) .and. source_type(1) /= 3) then
- call exit_MPI("incorrect angleforce: must have 0 <= angleforce < 90")
- endif
- endif
-
- ! only implemented for homogeneous media therefore only 1 material supported
- numat_local = numat
- if (numat /= 1) then
- if (myrank == 0) write(IOUT,*) 'not possible to have several materials with a plane wave, using the first material'
- numat_local = 1
- endif
-
- mu = poroelastcoef(2,1,numat_local)
- lambdaplus2mu = poroelastcoef(3,1,numat_local)
- denst = density(1,numat_local)
-
- cploc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
-
- ! P wave case
- if (source_type(1) == 1) then
-
- p=sin(angleforce(1))/cploc
- c_inc = cploc
- c_refl = csloc
-
- angleforce_refl = asin(p*c_refl)
-
- ! from formulas (5.26) and (5.27) p 140 in Aki & Richards (1980)
- PP = (- cos(2.d0*angleforce_refl)**2/csloc**3 &
- + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc) / &
- ( cos(2.d0*angleforce_refl)**2/csloc**3 &
- + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc)
-
- PS = 4.d0*p*cos(angleforce(1))*cos(2.d0*angleforce_refl) / &
- (csloc**2*(cos(2.d0*angleforce_refl)**2/csloc**3 &
- +4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc))
-
- if (myrank == 0) then
- write(IOUT,*) 'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi
- endif
-
- ! from Table 5.1 p141 in Aki & Richards (1980)
- ! we put the opposite sign on z coefficients because z axis is oriented from bottom to top
- A_plane(1) = sin(angleforce(1)); A_plane(2) = cos(angleforce(1))
- B_plane(1) = PP * sin(angleforce(1)); B_plane(2) = - PP * cos(angleforce(1))
- C_plane(1) = PS * cos(angleforce_refl); C_plane(2) = PS * sin(angleforce_refl)
-
- ! SV wave case
- else if (source_type(1) == 2) then
-
- p=sin(angleforce(1))/csloc
- c_inc = csloc
- c_refl = cploc
-
- ! if this coefficient is greater than 1, we are beyond the critical SV wave angle and there cannot be a converted P wave
- if (p*c_refl<=1.d0) then
- angleforce_refl = asin(p*c_refl)
-
- ! from formulas (5.30) and (5.31) p 140 in Aki & Richards (1980)
- SS = (cos(2.d0*angleforce(1))**2/csloc**3 &
- - 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc) / &
- (cos(2.d0*angleforce(1))**2/csloc**3 &
- + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc)
- SP = 4.d0*p*cos(angleforce(1))*cos(2*angleforce(1)) / &
- (cploc*csloc*(cos(2.d0*angleforce(1))**2/csloc**3&
- +4.d0*p**2*cos(angleforce_refl)*cos(angleforce(1))/cploc))
-
- if (myrank == 0) then
- write(IOUT,*) 'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi
- endif
-
- ! SV45 degree incident plane wave is a particular case
- else if (angleforce(1)>pi/4.d0-1.0d-11 .and. angleforce(1)<pi/4.d0+1.0d-11) then
- angleforce_refl = 0.d0
- SS = -1.0d0
- SP = 0.d0
- else
- over_critical_angle=.true.
- angleforce_refl = 0.d0
- SS = 0.0d0
- SP = 0.d0
- endif
-
- ! from Table 5.1 p141 in Aki & Richards (1980)
- ! we put the opposite sign on z coefficients because z axis is oriented from bottom to top
- A_plane(1) = cos(angleforce(1)); A_plane(2) = - sin(angleforce(1))
- B_plane(1) = SS * cos(angleforce(1)); B_plane(2) = SS * sin(angleforce(1))
- C_plane(1) = SP * sin(angleforce_refl); C_plane(2) = - SP * cos(angleforce_refl)
-
- ! Rayleigh case
- else if (source_type(1) == 3) then
- over_critical_angle=.true.
- A_plane(1)=0.d0; A_plane(2)=0.d0
- B_plane(1)=0.d0; B_plane(2)=0.d0
- C_plane(1)=0.d0; C_plane(2)=0.d0
- endif
-
- ! get minimum and maximum values of mesh coordinates
- xmin = minval(coord(1,:))
- zmin = minval(coord(2,:))
- xmax = maxval(coord(1,:))
- zmax = maxval(coord(2,:))
-
-#ifdef USE_MPI
- call MPI_ALLREDUCE (xmin, xmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (zmin, zmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (xmax, xmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (zmax, zmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
- xmin = xmin_glob
- zmin = zmin_glob
- xmax = xmax_glob
- zmax = zmax_glob
-#endif
-
- ! initialize the time offset to put the plane wave not too close to the irregularity on the free surface
- if (abs(angleforce(1))<1.d0*pi/180.d0 .and. source_type(1)/=3) then
- time_offset=-1.d0*(zmax-zmin)/2.d0/c_inc
- else
- time_offset=0.d0
- endif
-
- ! to correctly center the initial plane wave in the mesh
- x0_source=x_source(1)
- z0_source=z_source(1)
-
- if (myrank == 0) then
- write(IOUT,*)
- write(IOUT,*) 'You can modify the location of the initial plane wave by changing xs and zs in DATA/Par_File.'
- write(IOUT,*) ' for instance: xs=',x_source(1),' zs=',z_source(1), ' (zs must be the height of the free surface)'
- write(IOUT,*)
- endif
-
- if (.not. over_critical_angle) then
-
- do i = 1,npoin
-
- x = coord(1,i)
- z = coord(2,i)
-
- ! z is from bottom to top therefore we take -z to make parallel with Aki & Richards
- z = z0_source - z
- x = x - x0_source
-
- t = 0.d0 + time_offset
-
- ! formulas for the initial displacement for a plane wave from Aki & Richards (1980)
- displ_elastic(1,i) = &
- A_plane(1) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
- + B_plane(1) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
- + C_plane(1) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
- displ_elastic(3,i) = &
- A_plane(2) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
- + B_plane(2) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
- + C_plane(2) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
-
- ! formulas for the initial velocity for a plane wave (first derivative in time of the displacement)
- veloc_elastic(1,i) = &
- A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
- + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
- + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
- veloc_elastic(3,i) = &
- A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
- + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
- + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
-
- ! formulas for the initial acceleration for a plane wave (second derivative in time of the displacement)
- accel_elastic(1,i) = &
- A_plane(1) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
- + B_plane(1) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
- + C_plane(1) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
- accel_elastic(3,i) = &
- A_plane(2) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
- + B_plane(2) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
- + C_plane(2) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
-
- enddo
-
- endif
-
- end subroutine prepare_initialfield
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine prepare_initialfield_paco(myrank,nelemabs,left_bound,right_bound,bot_bound, &
- numabs,codeabs,ibool,nspec, &
- source_type,NSOURCES,c_inc,c_refl, &
- count_bottom,count_left,count_right)
-
- implicit none
- include "constants.h"
-
- integer :: myrank
-
- integer :: nelemabs
- integer :: left_bound(nelemabs*NGLLX)
- integer :: right_bound(nelemabs*NGLLX)
- integer :: bot_bound(nelemabs*NGLLZ)
- integer,dimension(nelemabs) :: numabs
- logical, dimension(4,nelemabs) :: codeabs
-
- integer :: nspec
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
-
- integer :: NSOURCES
- integer :: source_type(NSOURCES)
-
- double precision :: c_inc,c_refl
-
- integer :: count_bottom,count_left,count_right
-
- ! local parameters
- integer :: ispecabs,ispec,i,j,iglob,ibegin,iend
-
- if (myrank == 0) then
- if (source_type(1) /= 3 ) &
- write(IOUT,*) 'You are beyond the critical angle ( > ',asin(c_inc/c_refl)*180d0/pi,')'
-
- write(IOUT,*) '*************'
- write(IOUT,*) 'We have to compute the initial field in the frequency domain'
- write(IOUT,*) 'and then convert it to the time domain (can be long... be patient...)'
- write(IOUT,*) '*************'
- endif
-
- count_bottom=0
- count_left=0
- count_right=0
- do ispecabs=1,nelemabs
- ispec=numabs(ispecabs)
- if(codeabs(ILEFT,ispecabs)) then
- i = 1
- do j = 1,NGLLZ
- count_left=count_left+1
- iglob = ibool(i,j,ispec)
- left_bound(count_left)=iglob
- enddo
- endif
- if(codeabs(IRIGHT,ispecabs)) then
- i = NGLLX
- do j = 1,NGLLZ
- count_right=count_right+1
- iglob = ibool(i,j,ispec)
- right_bound(count_right)=iglob
- enddo
- endif
- if(codeabs(IBOTTOM,ispecabs)) then
- j = 1
- ! exclude corners to make sure there is no contradiction regarding the normal
- ibegin = 1
- iend = NGLLX
- if(codeabs(ILEFT,ispecabs)) ibegin = 2
- if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
- do i = ibegin,iend
- count_bottom=count_bottom+1
- iglob = ibool(i,j,ispec)
- bot_bound(count_bottom)=iglob
- enddo
- endif
- enddo
-
- end subroutine prepare_initialfield_paco
-
Deleted: seismo/2D/SPECFEM2D/trunk/prepare_source_time_function.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/prepare_source_time_function.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/prepare_source_time_function.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,160 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine prepare_source_time_function(myrank,NSTEP,NSOURCES,source_time_function, &
- time_function_type,f0,tshift_src,factor,aval, &
- t0,nb_proc_source,deltat)
-
-! prepares source_time_function array
-
- implicit none
- include "constants.h"
-
- integer :: myrank,NSTEP
-
- integer :: NSOURCES
- integer, dimension(NSOURCES) :: time_function_type
- double precision, dimension(NSOURCES) :: f0,tshift_src,factor
- double precision, dimension(NSOURCES) :: aval
- double precision :: t0
- integer,dimension(NSOURCES) :: nb_proc_source
- double precision :: deltat
-
- real(kind=CUSTOM_REAL),dimension(NSOURCES,NSTEP) :: source_time_function
-
- ! local parameters
- double precision :: stf_used,time
- double precision, dimension(NSOURCES) :: hdur,hdur_gauss
- double precision, external :: netlib_specfun_erf
- integer :: it,i_source
-
-
- ! user output
- if (myrank == 0) then
- write(IOUT,*)
- write(IOUT,*) 'Saving the source time function in a text file...'
- write(IOUT,*)
- open(unit=55,file='OUTPUT_FILES/source.txt',status='unknown')
- endif
-
- ! ! loop on all the sources
- ! do i_source=1,NSOURCES
-
- ! loop on all the time steps
- do it = 1,NSTEP
-
- ! note: t0 is the simulation start time, tshift_src is the time shift of the source
- ! relative to this start time
-
- ! compute current time
- time = (it-1)*deltat
-
- stf_used = 0.d0
-
- ! loop on all the sources
- do i_source=1,NSOURCES
-
- if( time_function_type(i_source) == 1 ) then
-
- ! Ricker (second derivative of a Gaussian) source time function
- source_time_function(i_source,it) = - factor(i_source) * &
- (ONE-TWO*aval(i_source)*(time-t0-tshift_src(i_source))**2) * &
- exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
-
- ! source_time_function(i_source,it) = - factor(i_source) * &
- ! TWO*aval(i_source)*sqrt(aval(i_source))*&
- ! (time-t0-tshift_src(i_source))/pi * exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
-
- else if( time_function_type(i_source) == 2 ) then
-
- ! first derivative of a Gaussian source time function
- source_time_function(i_source,it) = - factor(i_source) * &
- TWO*aval(i_source)*(time-t0-tshift_src(i_source)) * &
- exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
-
- else if(time_function_type(i_source) == 3 .or. time_function_type(i_source) == 4) then
-
- ! Gaussian or Dirac (we use a very thin Gaussian instead) source time function
- source_time_function(i_source,it) = factor(i_source) * &
- exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
-
- else if(time_function_type(i_source) == 5) then
-
- ! Heaviside source time function (we use a very thin error function instead)
- hdur(i_source) = 1.d0 / f0(i_source)
- hdur_gauss(i_source) = hdur(i_source) * 5.d0 / 3.d0
- source_time_function(i_source,it) = factor(i_source) * 0.5d0*(1.0d0 + &
- netlib_specfun_erf(SOURCE_DECAY_MIMIC_TRIANGLE*(time-t0-tshift_src(i_source))/hdur_gauss(i_source)))
-
- else
- call exit_MPI('unknown source time function')
- endif
-
- stf_used = stf_used + source_time_function(i_source,it)
-
- enddo
-
- ! output relative time in third column, in case user wants to check it as well
- ! if (myrank == 0 .and. i_source==1 ) write(55,*) sngl(time-t0-tshift_src(1)),real(source_time_function(1,it),4),sngl(time)
- if (myrank == 0) then
- ! note: earliest start time of the simulation is: (it-1)*deltat - t0
- write(55,*) sngl(time-t0),sngl(stf_used),sngl(time)
- endif
-
- !enddo
- enddo
-
- if (myrank == 0) close(55)
-
- ! nb_proc_source is the number of processes that own the source (the nearest point). It can be greater
- ! than one if the nearest point is on the interface between several partitions with an explosive source.
- ! since source contribution is linear, the source_time_function is cut down by that number (it would have been similar
- ! if we just had elected one of those processes).
- do i_source=1,NSOURCES
- source_time_function(i_source,:) = source_time_function(i_source,:) / nb_proc_source(i_source)
- enddo
-
- end subroutine prepare_source_time_function
Deleted: seismo/2D/SPECFEM2D/trunk/read_databases.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/read_databases.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/read_databases.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,836 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine read_databases_init(myrank,ipass, &
- simulation_title,SIMULATION_TYPE,SAVE_FORWARD,npgeo, &
- gnuplot,interpol,NTSTEP_BETWEEN_OUTPUT_INFO, &
- output_postscript_snapshot,output_color_image,colors,numbers, &
- meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows, &
- anglerec,initialfield,add_Bielak_conditions, &
- seismotype,imagetype,assign_external_model,READ_EXTERNAL_SEP_FILE, &
- outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON, &
- TURN_VISCATTENUATION_ON,Q0,freq0,p_sv, &
- NSTEP,deltat,NTSTEP_BETWEEN_OUTPUT_SEISMO,NSOURCES)
-
-! starts reading in parameters from input Database file
-
- implicit none
- include "constants.h"
-
- integer :: myrank,ipass
- character(len=60) simulation_title
- integer :: SIMULATION_TYPE,npgeo
- integer :: colors,numbers,subsamp,seismotype,imagetype
- logical :: SAVE_FORWARD,gnuplot,interpol,output_postscript_snapshot, &
- output_color_image
- logical :: meshvect,modelvect,boundvect,initialfield,add_Bielak_conditions, &
- assign_external_model,READ_EXTERNAL_SEP_FILE, &
- outputgrid,OUTPUT_ENERGY,p_sv
- logical :: TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON
-
- double precision :: cutsnaps,sizemax_arrows,anglerec
- double precision :: Q0,freq0
- double precision :: deltat
-
- integer :: NSTEP,NSOURCES
- integer :: NTSTEP_BETWEEN_OUTPUT_INFO,NTSTEP_BETWEEN_OUTPUT_SEISMO
-
- ! local parameters
- integer :: ier
- character(len=80) :: datlin
- character(len=256) :: prname
-
- ! opens Database file
- write(prname,230) myrank
- open(unit=IIN,file=prname,status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_MPI('error opening file OUTPUT/Database***')
-
- !--- read job title and skip remaining titles of the input file
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a50)") simulation_title
-
- !---- print the date, time and start-up banner
- if (myrank == 0 .and. ipass == 1) call datim(simulation_title)
-
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*)
- write(IOUT,*) '*********************'
- write(IOUT,*) '**** ****'
- write(IOUT,*) '**** SPECFEM2D ****'
- write(IOUT,*) '**** ****'
- write(IOUT,*) '*********************'
- endif
-
- !---- read parameters from input file
- read(IIN,"(a80)") datlin
- read(IIN,*) SIMULATION_TYPE, SAVE_FORWARD
-
- read(IIN,"(a80)") datlin
- read(IIN,*) npgeo
-
- read(IIN,"(a80)") datlin
- read(IIN,*) gnuplot,interpol
-
- read(IIN,"(a80)") datlin
- read(IIN,*) NTSTEP_BETWEEN_OUTPUT_INFO
-
- read(IIN,"(a80)") datlin
- read(IIN,*) output_postscript_snapshot,output_color_image,colors,numbers
-
- read(IIN,"(a80)") datlin
- read(IIN,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
- cutsnaps = cutsnaps / 100.d0
-
- read(IIN,"(a80)") datlin
- read(IIN,*) anglerec
-
- read(IIN,"(a80)") datlin
- read(IIN,*) initialfield,add_Bielak_conditions
- if(add_Bielak_conditions .and. .not. initialfield) &
- stop 'need to have an initial field to add Bielak plane wave conditions'
-
- read(IIN,"(a80)") datlin
- read(IIN,*) seismotype,imagetype
- if(seismotype < 1 .or. seismotype > 6) call exit_MPI('Wrong type for seismogram output')
- if(imagetype < 1 .or. imagetype > 4) call exit_MPI('Wrong type for snapshots')
-
- if(SAVE_FORWARD .and. (seismotype /= 1 .and. seismotype /= 6)) then
- print*, '***** WARNING *****'
- print*, 'seismotype =',seismotype
- print*, 'Save forward wavefield => seismogram must be in displacement for (poro)elastic or potential for acoustic'
- print*, 'Seismotype must be changed to 1 (elastic/poroelastic adjoint source) or 6 (acoustic adjoint source)'
- stop
- endif
-
- read(IIN,"(a80)") datlin
- read(IIN,*) assign_external_model,READ_EXTERNAL_SEP_FILE
-
- read(IIN,"(a80)") datlin
- read(IIN,*) outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON
-
- read(IIN,"(a80)") datlin
- read(IIN,*) TURN_VISCATTENUATION_ON,Q0,freq0
-
- read(IIN,"(a80)") datlin
- read(IIN,*) p_sv
-
- !---- check parameters read
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,200) npgeo,NDIM
- write(IOUT,600) NTSTEP_BETWEEN_OUTPUT_INFO,colors,numbers
- write(IOUT,700) seismotype,anglerec
- write(IOUT,750) initialfield,add_Bielak_conditions,assign_external_model,&
- READ_EXTERNAL_SEP_FILE,TURN_ATTENUATION_ON, &
- outputgrid,OUTPUT_ENERGY
- write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
- endif
-
- !---- read time step
- read(IIN,"(a80)") datlin
- read(IIN,*) NSTEP,deltat
- if (myrank == 0 .and. ipass == 1) write(IOUT,703) NSTEP,deltat,NSTEP*deltat
-
- if( SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. &
- (TURN_ATTENUATION_ON .or. TURN_VISCATTENUATION_ON) ) then
- print*, '*************** WARNING ***************'
- print*, 'Anisotropy & Attenuation & Viscous damping are not presently implemented for adjoint calculations'
- stop
- endif
-
- NTSTEP_BETWEEN_OUTPUT_SEISMO = min(NSTEP,NTSTEP_BETWEEN_OUTPUT_INFO)
-
- !---- read source information
- read(IIN,"(a80)") datlin
- read(IIN,*) NSOURCES
-
- ! output formats
-230 format('./OUTPUT_FILES/Database',i5.5)
-
-200 format(//1x,'C o n t r o l',/1x,13('='),//5x,&
- 'Number of spectral element control nodes. . .(npgeo) =',i8/5x, &
- 'Number of space dimensions. . . . . . . . . . (NDIM) =',i8)
-
-600 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Display frequency . . . (NTSTEP_BETWEEN_OUTPUT_INFO) = ',i6/ 5x, &
- 'Color display . . . . . . . . . . . . . . . (colors) = ',i6/ 5x, &
- ' == 0 black and white display ', / 5x, &
- ' == 1 color display ', /5x, &
- 'Numbered mesh . . . . . . . . . . . . . . .(numbers) = ',i6/ 5x, &
- ' == 0 do not number the mesh ', /5x, &
- ' == 1 number the mesh ')
-
-700 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Seismograms recording type . . . . . . .(seismotype) = ',i6/5x, &
- 'Angle for first line of receivers. . . . .(anglerec) = ',f6.2)
-
-750 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Read external initial field. . . . . .(initialfield) = ',l6/5x, &
- 'Add Bielak conditions . . . .(add_Bielak_conditions) = ',l6/5x, &
- 'Assign external model . . . .(assign_external_model) = ',l6/5x, &
- 'Read external SEP file . . .(READ_EXTERNAL_SEP_FILE) = ',l6/5x, &
- 'Turn attenuation on or off. . .(TURN_ATTENUATION_ON) = ',l6/5x, &
- 'Save grid in external file or not. . . .(outputgrid) = ',l6/5x, &
- 'Save a file with total energy or not.(OUTPUT_ENERGY) = ',l6)
-
-800 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Vector display type . . . . . . . . . . .(imagetype) = ',i6/5x, &
- 'Percentage of cut for vector plots . . . .(cutsnaps) = ',f6.2/5x, &
- 'Subsampling for velocity model display. . .(subsamp) = ',i6)
-
-703 format(//' I t e r a t i o n s '/1x,19('='),//5x, &
- 'Number of time iterations . . . . .(NSTEP) =',i8,/5x, &
- 'Time step increment. . . . . . . .(deltat) =',1pe15.6,/5x, &
- 'Total simulation duration . . . . . (ttot) =',1pe15.6)
-
- end subroutine read_databases_init
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_sources(NSOURCES,source_type,time_function_type, &
- x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce)
-
-! reads source parameters
-
- implicit none
- include "constants.h"
-
- integer :: NSOURCES
- integer, dimension(NSOURCES) :: source_type,time_function_type
- double precision, dimension(NSOURCES) :: x_source,z_source, &
- Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
-
- ! local parameters
- integer :: i_source
- character(len=80) :: datlin
-
- ! initializes
- source_type(:) = 0
- time_function_type(:) = 0
- x_source(:) = 0.d0
- z_source(:) = 0.d0
- Mxx(:) = 0.d0
- Mzz(:) = 0.d0
- Mxz(:) = 0.d0
- f0(:) = 0.d0
- tshift_src(:) = 0.d0
- factor(:) = 0.d0
- angleforce(:) = 0.d0
-
- ! reads in source info from Database file
- do i_source=1,NSOURCES
- read(IIN,"(a80)") datlin
- read(IIN,*) source_type(i_source),time_function_type(i_source), &
- x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
- factor(i_source),angleforce(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
- enddo
-
- end subroutine read_databases_sources
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_atten(N_SLS,f0_attenuation)
-
-! reads attenuation information
-
- implicit none
- include "constants.h"
-
- integer :: N_SLS
- double precision :: f0_attenuation
-
- ! local parameters
- character(len=80) :: datlin
-
- read(IIN,"(a80)") datlin
- read(IIN,*) N_SLS, f0_attenuation
-
- end subroutine read_databases_atten
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_coorg_elem(myrank,ipass,npgeo,coorg,numat,ngnod,nspec, &
- pointsdisp,plot_lowerleft_corner_only, &
- nelemabs,nelem_acoustic_surface, &
- num_fluid_solid_edges,num_fluid_poro_edges, &
- num_solid_poro_edges,nnodes_tangential_curve)
-
-! reads the spectral macrobloc nodal coordinates
-
- implicit none
- include "constants.h"
-
- integer :: myrank,ipass,npgeo
- double precision, dimension(NDIM,npgeo) :: coorg
-
- integer :: numat,ngnod,nspec
- integer :: pointsdisp
- logical :: plot_lowerleft_corner_only
- integer :: nelemabs,nelem_acoustic_surface, &
- num_fluid_solid_edges,num_fluid_poro_edges, &
- num_solid_poro_edges,nnodes_tangential_curve
-
- ! local parameters
- integer :: ipoin,ip,id
- double precision, dimension(:), allocatable :: coorgread
- character(len=80) :: datlin
-
- ! initializes
- coorg(:,:) = 0.d0
-
- ! reads the spectral macrobloc nodal coordinates
- read(IIN,"(a80)") datlin
-
- ! reads in values
- ipoin = 0
- allocate(coorgread(NDIM))
- do ip = 1,npgeo
- ! reads coordinates
- read(IIN,*) ipoin,(coorgread(id),id =1,NDIM)
-
- if(ipoin<1 .or. ipoin>npgeo) call exit_MPI('Wrong control point number')
-
- ! saves coordinate array
- coorg(:,ipoin) = coorgread
-
- enddo
- deallocate(coorgread)
-
- !---- read the basic properties of the spectral elements
- read(IIN,"(a80)") datlin
- read(IIN,*) numat,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
-
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,*) nelemabs,nelem_acoustic_surface,num_fluid_solid_edges,num_fluid_poro_edges,&
- num_solid_poro_edges,nnodes_tangential_curve
-
- !---- print element group main parameters
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,107)
- write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
- endif
-
- ! output formats
-107 format(/5x,'--> Isoparametric Spectral Elements <--',//)
-
-207 format(5x,'Number of spectral elements . . . . . (nspec) =',i7,/5x, &
- 'Number of control nodes per element . (ngnod) =',i7,/5x, &
- 'Number of points in X-direction . . . (NGLLX) =',i7,/5x, &
- 'Number of points in Y-direction . . . (NGLLZ) =',i7,/5x, &
- 'Number of points per element. . .(NGLLX*NGLLZ) =',i7,/5x, &
- 'Number of points for display . . .(pointsdisp) =',i7,/5x, &
- 'Number of element material sets . . . (numat) =',i7,/5x, &
- 'Number of absorbing elements . . . .(nelemabs) =',i7)
-
- end subroutine read_databases_coorg_elem
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_mato(ipass,nspec,ngnod,kmato,knods, &
- perm,antecedent_list)
-
-! reads spectral macrobloc data
-
- implicit none
- include "constants.h"
-
- integer :: ipass,ngnod,nspec
- integer, dimension(nspec) :: kmato
- integer, dimension(ngnod,nspec) :: knods
-
- integer, dimension(nspec) :: perm,antecedent_list
-
- ! local parameters
- integer :: n,k,ispec,kmato_read
- integer, dimension(:), allocatable :: knods_read
- character(len=80) :: datlin
-
- ! initializes
- kmato(:) = 0
- knods(:,:) = 0
-
- ! reads spectral macrobloc data
- read(IIN,"(a80)") datlin
-
- ! reads in values
- allocate(knods_read(ngnod))
- n = 0
- do ispec = 1,nspec
- ! format: #element_id #material_id #node_id1 #node_id2 #...
- read(IIN,*) n,kmato_read,(knods_read(k), k=1,ngnod)
- if(ipass == 1) then
- ! material association
- kmato(n) = kmato_read
- ! element control node indices
- knods(:,n)= knods_read(:)
- else if(ipass == 2) then
- kmato(perm(antecedent_list(n))) = kmato_read
- knods(:,perm(antecedent_list(n)))= knods_read(:)
- else
- call exit_MPI('error: maximum is 2 passes')
- endif
- enddo
- deallocate(knods_read)
-
-
- end subroutine read_databases_mato
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_ninterface(ninterface,max_interface_size)
-
-! reads in interface dimensions
-
- implicit none
- include "constants.h"
-
- integer :: ninterface,max_interface_size
-
- ! local parameters
- character(len=80) :: datlin
-
- read(IIN,"(a80)") datlin
- read(IIN,*) ninterface, max_interface_size
-
- end subroutine read_databases_ninterface
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_interfaces(ipass,ninterface,nspec,max_interface_size, &
- my_neighbours,my_nelmnts_neighbours,my_interfaces, &
- perm,antecedent_list)
-
-! reads in interfaces
-
- implicit none
- include "constants.h"
-
- integer :: ipass,nspec
- integer :: ninterface,max_interface_size
- integer, dimension(ninterface) :: my_neighbours,my_nelmnts_neighbours
- integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
-
- integer, dimension(nspec) :: perm,antecedent_list
-
- ! local parameters
- integer :: num_interface,ie,my_interfaces_read
-
- ! initializes
- my_neighbours(:) = -1
- my_nelmnts_neighbours(:) = 0
- my_interfaces(:,:,:) = -1
-
- ! reads in interfaces
- do num_interface = 1, ninterface
- ! format: #process_interface_id #number_of_elements_on_interface
- ! where
- ! process_interface_id = rank of (neighbor) process to share MPI interface with
- ! number_of_elements_on_interface = number of interface elements
- read(IIN,*) my_neighbours(num_interface), my_nelmnts_neighbours(num_interface)
-
- ! loops over interface elements
- do ie = 1, my_nelmnts_neighbours(num_interface)
- ! format: #(1)spectral_element_id #(2)interface_type #(3)node_id1 #(4)node_id2
- !
- ! interface types:
- ! 1 - corner point only
- ! 2 - element edge
- read(IIN,*) my_interfaces_read, my_interfaces(2,ie,num_interface), &
- my_interfaces(3,ie,num_interface), my_interfaces(4,ie,num_interface)
-
- if(ipass == 1) then
- my_interfaces(1,ie,num_interface) = my_interfaces_read
- else if(ipass == 2) then
- my_interfaces(1,ie,num_interface) = perm(antecedent_list(my_interfaces_read))
- else
- call exit_MPI('error: maximum number of passes is 2')
- endif
-
- enddo
- enddo
-
- end subroutine read_databases_interfaces
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_absorbing(myrank,ipass,nelemabs,nspec,anyabs, &
- ibegin_bottom,iend_bottom,jbegin_right,jend_right, &
- ibegin_top,iend_top,jbegin_left,jend_left, &
- numabs,codeabs,perm,antecedent_list, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- ib_right,ib_left,ib_bottom,ib_top)
-
-! reads in absorbing edges
-
- implicit none
- include "constants.h"
-
- integer :: myrank,ipass,nspec
- integer :: nelemabs
- integer, dimension(nelemabs) :: numabs,ibegin_bottom,iend_bottom, &
- ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
- logical, dimension(4,nelemabs) :: codeabs
- logical :: anyabs
- integer, dimension(nspec) :: perm,antecedent_list
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
-
- integer, dimension(nelemabs) :: ib_right,ib_left,ib_bottom,ib_top
-
- ! local parameters
- integer :: inum,numabsread
- logical :: codeabsread(4)
- character(len=80) :: datlin
-
- ! initializes
- codeabs(:,:) = .false.
-
- ibegin_bottom(:) = 0
- iend_bottom(:) = 0
- ibegin_top(:) = 0
- iend_top(:) = 0
-
- jbegin_left(:) = 0
- jend_left(:) = 0
- jbegin_right(:) = 0
- jend_right(:) = 0
-
- nspec_xmin = 0
- nspec_xmax = 0
- nspec_zmin = 0
- nspec_zmax = 0
-
- ib_right(:) = 0
- ib_left(:) = 0
- ib_bottom(:) = 0
- ib_top(:) = 0
-
- ! reads in absorbing edges
- read(IIN,"(a80)") datlin
-
- ! reads in values
- if( anyabs ) then
- ! reads absorbing boundaries
- do inum = 1,nelemabs
- read(IIN,*) numabsread,codeabsread(1),codeabsread(2),codeabsread(3),&
- codeabsread(4), ibegin_bottom(inum), iend_bottom(inum), &
- jbegin_right(inum), jend_right(inum), ibegin_top(inum), &
- iend_top(inum), jbegin_left(inum), jend_left(inum)
-
- if(numabsread < 1 .or. numabsread > nspec) &
- call exit_MPI('Wrong absorbing element number')
-
- if(ipass == 1) then
- numabs(inum) = numabsread
- else if(ipass == 2) then
- numabs(inum) = perm(antecedent_list(numabsread))
- else
- call exit_MPI('error: maximum number of passes is 2')
- endif
-
- codeabs(IBOTTOM,inum) = codeabsread(1)
- codeabs(IRIGHT,inum) = codeabsread(2)
- codeabs(ITOP,inum) = codeabsread(3)
- codeabs(ILEFT,inum) = codeabsread(4)
- enddo
-
- ! boundary element numbering
- do inum = 1,nelemabs
- if (codeabs(IBOTTOM,inum)) then
- nspec_zmin = nspec_zmin + 1
- ib_bottom(inum) = nspec_zmin
- endif
- if (codeabs(IRIGHT,inum)) then
- nspec_xmax = nspec_xmax + 1
- ib_right(inum) = nspec_xmax
- endif
- if (codeabs(ITOP,inum)) then
- nspec_zmax = nspec_zmax + 1
- ib_top(inum) = nspec_zmax
- endif
- if (codeabs(ILEFT,inum)) then
- nspec_xmin = nspec_xmin + 1
- ib_left(inum) = nspec_xmin
- endif
- enddo
-
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Number of absorbing elements: ',nelemabs
- write(IOUT,*) ' nspec_xmin = ',nspec_xmin
- write(IOUT,*) ' nspec_xmax = ',nspec_xmax
- write(IOUT,*) ' nspec_zmin = ',nspec_zmin
- write(IOUT,*) ' nspec_zmax = ',nspec_zmax
- write(IOUT,*)
- endif
-
- endif
-
- end subroutine read_databases_absorbing
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_free_surf(ipass,nelem_acoustic_surface,nspec, &
- acoustic_edges,perm,antecedent_list,any_acoustic_edges)
-
-! reads acoustic free surface data
-
- implicit none
- include "constants.h"
-
- integer :: ipass,nspec
- integer :: nelem_acoustic_surface
- integer, dimension(4,nelem_acoustic_surface) :: acoustic_edges
- logical :: any_acoustic_edges
-
- integer, dimension(nspec) :: perm,antecedent_list
-
- ! local parameters
- integer :: inum,acoustic_edges_read
- character(len=80) :: datlin
-
- ! initializes
- acoustic_edges(:,:) = 0
-
- ! reads in any possible free surface edges
- read(IIN,"(a80)") datlin
-
- if( any_acoustic_edges ) then
- do inum = 1,nelem_acoustic_surface
- read(IIN,*) acoustic_edges_read, acoustic_edges(2,inum), acoustic_edges(3,inum), &
- acoustic_edges(4,inum)
-
- if(ipass == 1) then
- acoustic_edges(1,inum) = acoustic_edges_read
- else if(ipass == 2) then
- acoustic_edges(1,inum) = perm(antecedent_list(acoustic_edges_read))
- else
- call exit_MPI('error: maximum number of passes is 2')
- endif
-
- enddo
-
- endif
-
- end subroutine read_databases_free_surf
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_coupled(ipass,nspec,num_fluid_solid_edges,any_fluid_solid_edges, &
- fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec, &
- num_fluid_poro_edges,any_fluid_poro_edges, &
- fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec, &
- num_solid_poro_edges,any_solid_poro_edges, &
- solid_poro_elastic_ispec,solid_poro_poroelastic_ispec, &
- perm,antecedent_list)
-
-! reads acoustic elastic coupled edges
-! reads acoustic poroelastic coupled edges
-! reads poroelastic elastic coupled edges
-
- implicit none
- include "constants.h"
-
- integer :: ipass,nspec
-
- integer :: num_fluid_solid_edges
- logical :: any_fluid_solid_edges
- integer, dimension(num_fluid_solid_edges) :: fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec
-
- integer :: num_fluid_poro_edges
- logical :: any_fluid_poro_edges
- integer, dimension(num_fluid_poro_edges) :: fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec
-
- integer :: num_solid_poro_edges
- logical :: any_solid_poro_edges
- integer, dimension(num_solid_poro_edges) :: solid_poro_elastic_ispec,solid_poro_poroelastic_ispec
-
- integer, dimension(nspec) :: perm,antecedent_list
-
- ! local parameters
- integer :: inum
- integer :: fluid_solid_acoustic_ispec_read,fluid_solid_elastic_ispec_read, &
- fluid_poro_acoustic_ispec_read,fluid_poro_poro_ispec_read, &
- solid_poro_poro_ispec_read,solid_poro_elastic_ispec_read
- character(len=80) :: datlin
-
- ! initializes
- fluid_solid_acoustic_ispec(:) = 0
- fluid_solid_elastic_ispec(:) = 0
- fluid_poro_acoustic_ispec(:) = 0
- fluid_poro_poroelastic_ispec(:) = 0
- solid_poro_elastic_ispec(:) = 0
- solid_poro_poroelastic_ispec(:) = 0
-
- ! reads acoustic elastic coupled edges
- read(IIN,"(a80)") datlin
-
- if ( any_fluid_solid_edges ) then
- do inum = 1, num_fluid_solid_edges
- read(IIN,*) fluid_solid_acoustic_ispec_read,fluid_solid_elastic_ispec_read
-
- if(ipass == 1) then
- fluid_solid_acoustic_ispec(inum) = fluid_solid_acoustic_ispec_read
- fluid_solid_elastic_ispec(inum) = fluid_solid_elastic_ispec_read
- else if(ipass == 2) then
- fluid_solid_acoustic_ispec(inum) = perm(antecedent_list(fluid_solid_acoustic_ispec_read))
- fluid_solid_elastic_ispec(inum) = perm(antecedent_list(fluid_solid_elastic_ispec_read))
- else
- call exit_MPI('error: maximum number of passes is 2')
- endif
- enddo
- endif
-
- ! reads acoustic poroelastic coupled edges
- read(IIN,"(a80)") datlin
-
- if ( any_fluid_poro_edges ) then
- do inum = 1, num_fluid_poro_edges
- read(IIN,*) fluid_poro_acoustic_ispec_read,fluid_poro_poro_ispec_read
-
- if(ipass == 1) then
- fluid_poro_acoustic_ispec(inum) = fluid_poro_acoustic_ispec_read
- fluid_poro_poroelastic_ispec(inum) = fluid_poro_poro_ispec_read
- else if(ipass == 2) then
- fluid_poro_acoustic_ispec(inum) = perm(antecedent_list(fluid_poro_acoustic_ispec_read))
- fluid_poro_poroelastic_ispec(inum) = perm(antecedent_list(fluid_poro_poro_ispec_read))
- else
- call exit_MPI('error: maximum number of passes is 2')
- endif
- enddo
- endif
-
- ! reads poroelastic elastic coupled edges
- read(IIN,"(a80)") datlin
-
- if ( any_solid_poro_edges ) then
- do inum = 1, num_solid_poro_edges
- read(IIN,*) solid_poro_poro_ispec_read,solid_poro_elastic_ispec_read
-
- if(ipass == 1) then
- solid_poro_elastic_ispec(inum) = solid_poro_elastic_ispec_read
- solid_poro_poroelastic_ispec(inum) = solid_poro_poro_ispec_read
- else if(ipass == 2) then
- solid_poro_elastic_ispec(inum) = perm(antecedent_list(solid_poro_elastic_ispec_read))
- solid_poro_poroelastic_ispec(inum) = perm(antecedent_list(solid_poro_poro_ispec_read))
- else
- call exit_MPI('error: maximum number of passes is 2')
- endif
- enddo
- endif
-
- end subroutine read_databases_coupled
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine read_databases_final(nnodes_tangential_curve,nodes_tangential_curve, &
- force_normal_to_surface,rec_normal_to_surface, &
- any_tangential_curve )
-
-! reads tangential detection curve
-! and closes Database file
-
- implicit none
- include "constants.h"
-
- integer :: nnodes_tangential_curve
- logical :: any_tangential_curve
- double precision, dimension(2,nnodes_tangential_curve) :: nodes_tangential_curve
-
- logical :: force_normal_to_surface,rec_normal_to_surface
-
- ! local parameters
- integer :: i
- character(len=80) :: datlin
-
- ! initializes
- nodes_tangential_curve(:,:) = 0.d0
-
- ! reads tangential detection curve
- read(IIN,"(a80)") datlin
- read(IIN,*) force_normal_to_surface,rec_normal_to_surface
-
- if( any_tangential_curve ) then
- do i = 1, nnodes_tangential_curve
- read(IIN,*) nodes_tangential_curve(1,i),nodes_tangential_curve(2,i)
- enddo
- else
- force_normal_to_surface = .false.
- rec_normal_to_surface = .false.
- endif
-
- ! closes input Database file
- close(IIN)
-
- end subroutine read_databases_final
-
-
\ No newline at end of file
Deleted: seismo/2D/SPECFEM2D/trunk/read_external_model.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/read_external_model.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/read_external_model.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,188 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine read_external_model(any_acoustic,any_elastic,any_poroelastic, &
- elastic,poroelastic,anisotropic,nspec,npoin,N_SLS,ibool, &
- f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
- inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent, &
- inv_tau_sigma_nu1,inv_tau_sigma_nu2,phi_nu1,phi_nu2,Mu_nu1,Mu_nu2,&
- coord,kmato,myrank,rhoext,vpext,vsext, &
- Qp_attenuationext,Qs_attenuationext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,READ_EXTERNAL_SEP_FILE)
-
- implicit none
- include "constants.h"
-
- integer :: nspec,myrank,npoin
- double precision :: f0_attenuation
-
- ! Mesh
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- double precision, dimension(NDIM,npoin) :: coord
-
- ! Material properties
- logical :: any_acoustic,any_elastic,any_poroelastic,READ_EXTERNAL_SEP_FILE
- integer, dimension(nspec) :: kmato
- logical, dimension(nspec) :: elastic,poroelastic
- double precision, dimension(NGLLX,NGLLZ,nspec) :: rhoext,vpext,vsext
-
- ! for attenuation
- integer :: N_SLS
- double precision :: Mu_nu1_sent,Mu_nu2_sent
- double precision, dimension(N_SLS) :: inv_tau_sigma_nu1_sent,phi_nu1_sent, &
- inv_tau_sigma_nu2_sent,phi_nu2_sent
- double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu1,phi_nu1, &
- inv_tau_sigma_nu2,phi_nu2
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
- double precision, dimension(NGLLX,NGLLZ,nspec) :: Qp_attenuationext,Qs_attenuationext
-
- ! for anisotropy
- logical, dimension(nspec) :: anisotropic
- double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c13ext,c15ext,c33ext,c35ext,c55ext
-
- ! Local variables
- integer :: i,j,ispec,iglob
- double precision :: previous_vsext
- double precision :: tmp1, tmp2,tmp3
-
- if(READ_EXTERNAL_SEP_FILE) then
- write(IOUT,*)
- write(IOUT,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
- write(IOUT,*) 'Assigning external velocity and density model (elastic (no attenuation) and/or acoustic)...'
- write(IOUT,*) 'Read outside SEG model...'
- write(IOUT,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
-
- open(unit=1001,file='DATA/model_velocity.dat_input',status='unknown')
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- read(1001,*) tmp1,tmp2,tmp3,rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec)
- ! vsext(i,j,ispec)=0.0
- ! Qp, Qs : dummy values. If attenuation needed than the "read" line and model_velocity.dat_input
- ! need to be modified to provide Qp & Qs values
- Qp_attenuationext(i,j,ispec) = 10.d0
- Qs_attenuationext(i,j,ispec) = 10.d0
- end do
- end do
- end do
- close(1001)
-
- else
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
- call define_external_model(coord(1,iglob),coord(2,iglob),kmato(ispec),myrank,&
- rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec), &
- Qp_attenuationext(i,j,ispec),Qs_attenuationext(i,j,ispec),&
- c11ext(i,j,ispec),c13ext(i,j,ispec),c15ext(i,j,ispec), &
- c33ext(i,j,ispec),c35ext(i,j,ispec),c55ext(i,j,ispec))
-
- if((c11ext(i,j,ispec) /= 0) .or. (c13ext(i,j,ispec) /= 0) .or. (c15ext(i,j,ispec) /= 0) .or. &
- (c33ext(i,j,ispec) /= 0) .or. (c35ext(i,j,ispec) /= 0) .or. (c55ext(i,j,ispec) /= 0)) then
- ! vp, vs : dummy values, trick to avoid floating point errors
- vpext(i,j,ispec) = 20.d0
- vsext(i,j,ispec) = 10.d0
- end if
- end do
- end do
- end do
- end if
-
- ! initializes
- any_acoustic = .false.
- any_elastic = .false.
- any_poroelastic = .false.
-
- anisotropic(:) = .false.
- elastic(:) = .false.
- poroelastic(:) = .false.
-
- do ispec = 1,nspec
- previous_vsext = -1.d0
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- if(.not. (i == 1 .and. j == 1) .and. &
- ((vsext(i,j,ispec) >= TINYVAL .and. previous_vsext < TINYVAL) .or. &
- (vsext(i,j,ispec) < TINYVAL .and. previous_vsext >= TINYVAL))) &
- call exit_MPI('external velocity model cannot be both fluid and solid inside the same spectral element')
-
- if((c11ext(i,j,ispec) /= 0) .or. (c13ext(i,j,ispec) /= 0) .or. (c15ext(i,j,ispec) /= 0) .or. &
- (c33ext(i,j,ispec) /= 0) .or. (c35ext(i,j,ispec) /= 0) .or. (c55ext(i,j,ispec) /= 0)) then
- anisotropic(ispec) = .true.
- poroelastic(ispec) = .false.
- elastic(ispec) = .true.
- any_elastic = .true.
- Qp_attenuationext(i,j,ispec) = 10.d0
- Qs_attenuationext(i,j,ispec) = 10.d0
- elseif(vsext(i,j,ispec) < TINYVAL) then
- elastic(ispec) = .false.
- poroelastic(ispec) = .false.
- any_acoustic = .true.
- else
- poroelastic(ispec) = .false.
- elastic(ispec) = .true.
- any_elastic = .true.
- endif
-
- call attenuation_model(N_SLS,Qp_attenuationext(i,j,ispec),Qs_attenuationext(i,j,ispec), &
- f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
- inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent)
- inv_tau_sigma_nu1(i,j,ispec,:) = inv_tau_sigma_nu1_sent(:)
- phi_nu1(i,j,ispec,:) = phi_nu1_sent(:)
- inv_tau_sigma_nu2(i,j,ispec,:) = inv_tau_sigma_nu2_sent(:)
- phi_nu2(i,j,ispec,:) = phi_nu2_sent(:)
- Mu_nu1(i,j,ispec) = Mu_nu1_sent
- Mu_nu2(i,j,ispec) = Mu_nu2_sent
- previous_vsext = vsext(i,j,ispec)
- enddo
- enddo
- enddo
-
- end subroutine read_external_model
Deleted: seismo/2D/SPECFEM2D/trunk/read_interfaces_file.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/read_interfaces_file.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/read_interfaces_file.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,179 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-module interfaces_file
-
- ! note: we use this module definition only to be able to allocate
- ! arrays for receiverlines and materials in this subroutine rather than in the main
- ! routine in meshfem2D.F90
-
- ! note 2: the filename ending is .F90 to have pre-compilation with pragmas
- ! (like #ifndef USE_MPI) working properly
-
- implicit none
-
-contains
-
- subroutine read_interfaces_file(interfacesfile,max_npoints_interface, &
- number_of_interfaces,npoints_interface_bottom, &
- number_of_layers,nz_layer,nx,nz,nxread,nzread,ngnod, &
- nelmnts,elmnts)
- implicit none
- include "constants.h"
-
- character(len=100) :: interfacesfile
-
- integer :: max_npoints_interface,number_of_interfaces,npoints_interface_bottom
- integer :: number_of_layers,nx,nz,nxread,nzread,ngnod
- integer :: nelmnts
- integer, dimension(:), pointer :: nz_layer
- integer, dimension(:), pointer :: elmnts
-
- ! local parameters
- integer :: ios,interface_current,ipoint_current,ilayer,i,j,num_elmnt
- double precision :: xinterface_dummy,zinterface_dummy,xinterface_dummy_previous
-
- ! get interface data from external file to count the spectral elements along Z
- print *,'Reading interface data from file DATA/',interfacesfile(1:len_trim(interfacesfile)),' to count the spectral elements'
- open(unit=IIN_INTERFACES,file='DATA/'//interfacesfile,status='old',iostat=ios)
- if( ios /= 0 ) then
- print*,'error opening file: ',trim('DATA/'//interfacesfile)
- stop 'error read interface file in meshfem2D'
- endif
-
- max_npoints_interface = -1
-
- ! read number of interfaces
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,number_of_interfaces)
- if(number_of_interfaces < 2) stop 'not enough interfaces (minimum is 2)'
-
- ! loop on all the interfaces
- do interface_current = 1,number_of_interfaces
-
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_bottom)
- if(npoints_interface_bottom < 2) stop 'not enough interface points (minimum is 2)'
- max_npoints_interface = max(npoints_interface_bottom,max_npoints_interface)
- print *,'Reading ',npoints_interface_bottom,' points for interface ',interface_current
-
- ! loop on all the points describing this interface
- xinterface_dummy_previous = -HUGEVAL
- do ipoint_current = 1,npoints_interface_bottom
- call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK,xinterface_dummy,zinterface_dummy)
- if(ipoint_current > 1 .and. xinterface_dummy <= xinterface_dummy_previous) &
- stop 'interface points must be sorted in increasing X'
- xinterface_dummy_previous = xinterface_dummy
- enddo
- enddo
-
- ! define number of layers
- number_of_layers = number_of_interfaces - 1
-
- allocate(nz_layer(number_of_layers))
-
- ! loop on all the layers
- do ilayer = 1,number_of_layers
-
- ! read number of spectral elements in vertical direction in this layer
- call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,nz_layer(ilayer))
- if(nz_layer(ilayer) < 1) stop 'not enough spectral elements along Z in layer (minimum is 1)'
- print *,'There are ',nz_layer(ilayer),' spectral elements along Z in layer ',ilayer
-
- enddo
-
- close(IIN_INTERFACES)
-
- ! compute total number of spectral elements in vertical direction
- nz = sum(nz_layer)
-
- print *
- print *,'Total number of spectral elements along Z = ',nz
- print *
-
- nxread = nx
- nzread = nz
-
- ! multiply by 2 if elements have 9 nodes
- if(ngnod == 9) then
- nx = nx * 2
- nz = nz * 2
- nz_layer(:) = nz_layer(:) * 2
- endif
-
- nelmnts = nxread * nzread
- allocate(elmnts(0:ngnod*nelmnts-1))
-
- if ( ngnod == 4 ) then
- num_elmnt = 0
- do j = 1, nzread
- do i = 1, nxread
- elmnts(num_elmnt*ngnod) = (j-1)*(nxread+1) + (i-1)
- elmnts(num_elmnt*ngnod+1) = (j-1)*(nxread+1) + (i-1) + 1
- elmnts(num_elmnt*ngnod+2) = j*(nxread+1) + (i-1) + 1
- elmnts(num_elmnt*ngnod+3) = j*(nxread+1) + (i-1)
- num_elmnt = num_elmnt + 1
- enddo
- enddo
- else
- num_elmnt = 0
- do j = 1, nzread
- do i = 1, nxread
- elmnts(num_elmnt*ngnod) = (j-1)*(nxread+1) + (i-1)
- elmnts(num_elmnt*ngnod+1) = (j-1)*(nxread+1) + (i-1) + 1
- elmnts(num_elmnt*ngnod+2) = j*(nxread+1) + (i-1) + 1
- elmnts(num_elmnt*ngnod+3) = j*(nxread+1) + (i-1)
- elmnts(num_elmnt*ngnod+4) = (nxread+1)*(nzread+1) + (j-1)*nxread + (i-1)
- elmnts(num_elmnt*ngnod+5) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2 + 2
- elmnts(num_elmnt*ngnod+6) = (nxread+1)*(nzread+1) + j*nxread + (i-1)
- elmnts(num_elmnt*ngnod+7) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2
- elmnts(num_elmnt*ngnod+8) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2 + 1
- num_elmnt = num_elmnt + 1
- enddo
- enddo
-
- endif
-
-
- end subroutine read_interfaces_file
-
-end module interfaces_file
Deleted: seismo/2D/SPECFEM2D/trunk/read_materials.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/read_materials.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/read_materials.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,199 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine read_materials(nb_materials,icodemat,cp,cs, &
- aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
- Qp,Qs,rho_s,rho_f,phi,tortuosity, &
- permxx,permxz,permzz,kappa_s,kappa_f,kappa_fr, &
- eta_f,mu_fr)
-
-! reads in material definitions in DATA/Par_file
-
- implicit none
- include "constants.h"
-
- integer :: nb_materials
-
- integer, dimension(nb_materials) :: icodemat
-
- double precision, dimension(nb_materials) :: rho_s,cp,cs, &
- aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
- double precision, dimension(nb_materials) :: rho_f,phi,tortuosity,permxx,permxz,&
- permzz,kappa_s,kappa_f,kappa_fr,eta_f,mu_fr
-
- ! local parameters
- integer :: imaterial,i,icodematread
- double precision :: val0read,val1read,val2read,val3read,val4read, &
- val5read,val6read,val7read,val8read,val9read,val10read,val11read,val12read
-
- ! initializes material properties
- icodemat(:) = 0
- cp(:) = 0.d0
- cs(:) = 0.d0
- aniso3(:) = 0.d0
- aniso4(:) = 0.d0
- aniso5(:) = 0.d0
- aniso6(:) = 0.d0
- aniso7(:) = 0.d0
- aniso8(:) = 0.d0
- Qp(:) = 0.d0
- Qs(:) = 0.d0
- rho_s(:) = 0.d0
- rho_f(:) = 0.d0
- phi(:) = 0.d0
- tortuosity(:) = 0.d0
- permxx(:) = 0.d0
- permxz(:) = 0.d0
- permzz(:) = 0.d0
- kappa_s(:) = 0.d0
- kappa_f(:) = 0.d0
- kappa_fr(:) = 0.d0
- eta_f(:) = 0.d0
- mu_fr(:) = 0.d0
-
- ! reads in material parameters
- do imaterial=1,nb_materials
- call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread, &
- val0read,val1read,val2read,val3read, &
- val4read,val5read,val6read,val7read, &
- val8read,val9read,val10read,val11read,val12read)
-
- ! checks material id
- if(i < 1 .or. i > nb_materials) stop 'Wrong material number!'
- icodemat(i) = icodematread
-
-
- ! sets material properties
- if(icodemat(i) == ISOTROPIC_MATERIAL) then
-
- ! isotropic materials
-
- rho_s(i) = val0read
- cp(i) = val1read
- cs(i) = val2read
- Qp(i) = val5read
- Qs(i) = val6read
-
- if(rho_s(i) <= 0.d0 .or. cp(i) <= 0.d0 .or. cs(i) < 0.d0) stop 'negative value of velocity or density'
- if(Qp(i) <= 0.d0 .or. Qs(i) <= 0.d0) stop 'negative value of Qp or Qs'
-
- aniso3(i) = val3read
- aniso4(i) = val4read
- if(cs(i) /= 0.d0) then
- phi(i) = 0.d0 ! elastic
- else
- phi(i) = 1.d0 ! acoustic
- endif
- elseif (icodemat(i) == ANISOTROPIC_MATERIAL) then
-
- ! anisotropic materials
-
- rho_s(i) = val0read
- cp(i) = val1read
- cs(i) = val2read
- aniso3(i) = val3read
- aniso4(i) = val4read
- aniso5(i) = val5read
- aniso6(i) = val6read
- aniso7(i) = val7read
- aniso8(i) = val8read
- Qp(i) = val9read
- Qs(i) = val10read
- else
-
- ! poroelastic materials
-
- rho_s(i) = val0read
- rho_f(i) = val1read
- phi(i) = val2read
- tortuosity(i) = val3read
- permxx(i) = val4read
- permxz(i) = val5read
- permzz(i) = val6read
- kappa_s(i) = val7read
- kappa_f(i) = val8read
- kappa_fr(i) = val9read
- eta_f(i) = val10read
- mu_fr(i) = val11read
- Qs(i) = val12read
-
- if(rho_s(i) <= 0.d0 .or. rho_f(i) <= 0.d0) stop 'negative value of density'
- if(phi(i) <= 0.d0 .or. tortuosity(i) <= 0.d0) stop 'negative value of porosity or tortuosity'
- if(kappa_s(i) <= 0.d0 .or. kappa_f(i) <= 0.d0 .or. kappa_fr(i) <= 0.d0 .or. mu_fr(i) <= 0.d0) then
- stop 'negative value of modulus'
- end if
- if(Qs(i) <= 0.d0) stop 'negative value of Qs'
- endif
- enddo
-
- ! user output
- print *
- print *, 'Nb of solid, fluid or porous materials = ',nb_materials
- print *
- do i=1,nb_materials
- if(icodemat(i) /= ANISOTROPIC_MATERIAL .and. icodemat(i) /= POROELASTIC_MATERIAL) then
- print *,'Material #',i,' isotropic'
- print *,'rho,cp,cs = ',rho_s(i),cp(i),cs(i),Qp(i),Qs(i)
- if(cs(i) < TINYVAL) then
- print *,'Material is fluid'
- else
- print *,'Material is solid'
- endif
- elseif(icodemat(i) == POROELASTIC_MATERIAL) then
- print *,'Material #',i,' isotropic'
- print *,'rho_s, kappa_s= ',rho_s(i),kappa_s(i)
- print *,'rho_f, kappa_f, eta_f= ',rho_f(i),kappa_f(i),eta_f(i)
- print *,'phi, tortuosity, permxx, permxz, permzz= ',phi(i),tortuosity(i),permxx(i),permxz(i),permzz(i)
- print *,'kappa_fr, mu_fr, Qs= ',kappa_fr(i),mu_fr(i),Qs(i)
- print *,'Material is porous'
- else
- print *,'Material #',i,' anisotropic'
- print *,'rho,cp,cs = ',rho_s(i),cp(i),cs(i)
- print*,'c11,c13,c15,c33,c35,c55 = ',aniso3(i),aniso4(i),aniso5(i),aniso6(i),aniso7(i),aniso8(i)
- print *,'Qp,Qs = ',Qp(i),Qs(i)
- endif
- print *
- enddo
-
- end subroutine read_materials
Deleted: seismo/2D/SPECFEM2D/trunk/read_parameter_file.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/read_parameter_file.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/read_parameter_file.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,327 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-module parameter_file
-
- ! note: we use this module definition only to be able to allocate
- ! arrays for receiverlines and materials in this subroutine rather than in the main
- ! routine in meshfem2D.F90
-
- ! note 2: the filename ending is .F90 to have pre-compilation with pragmas
- ! (like #ifndef USE_MPI) working properly
-
- implicit none
- character(len=100) :: interfacesfile,title
-
- integer :: SIMULATION_TYPE
- logical :: SAVE_FORWARD,read_external_mesh
-
- character(len=256) :: mesh_file, nodes_coords_file, materials_file, &
- free_surface_file, absorbing_surface_file
- character(len=256) :: tangential_detection_curve_file
-
- ! variables used for partitioning
- integer :: nproc,partitioning_method
-
- double precision :: xmin,xmax
- integer :: nx,ngnod
-
- logical :: initialfield,add_Bielak_conditions,assign_external_model, &
- READ_EXTERNAL_SEP_FILE,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON
-
- double precision :: Q0,freq0
-
- logical :: p_sv
- logical :: any_abs,absbottom,absright,abstop,absleft
-
- integer :: nt
- double precision :: deltat
-
- integer :: NSOURCES
- logical :: force_normal_to_surface
-
- ! variables used for attenuation
- integer :: N_SLS
- double precision :: f0_attenuation
-
- integer :: seismotype
- logical :: generate_STATIONS
-
- integer :: nreceiverlines
- double precision :: anglerec
- logical :: rec_normal_to_surface
-
- integer, dimension(:), pointer :: nrec
- double precision, dimension(:), pointer :: xdeb,zdeb,xfin,zfin
- logical, dimension(:), pointer :: enreg_surf_same_vertical
-
- integer :: NTSTEP_BETWEEN_OUTPUT_INFO
- logical :: output_postscript_snapshot,output_color_image
- integer :: imagetype
- double precision :: cutsnaps
- logical :: meshvect,modelvect,boundvect,interpol
- integer :: pointsdisp,subsamp
- double precision :: sizemax_arrows
- logical :: gnuplot,outputgrid,OUTPUT_ENERGY
- logical :: plot_lowerleft_corner_only
-
- ! to store density and velocity model
- integer :: nb_materials
- integer, dimension(:),pointer :: icodemat
- double precision, dimension(:),pointer :: rho_s,cp,cs, &
- aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
- double precision, dimension(:),pointer :: rho_f,phi,tortuosity,permxx,permxz,&
- permzz,kappa_s,kappa_f,kappa_fr,eta_f,mu_fr
-
-contains
-
- subroutine read_parameter_file()
-
-! reads in DATA/Par_file
-
- implicit none
- include "constants.h"
-
- ! local parameters
- integer :: ios,ireceiverlines
-
- ! read file names and path for output
- call read_value_string(IIN,IGNORE_JUNK,title)
- call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
-
- write(*,*) 'Title of the simulation'
- write(*,*) title
- print *
-
- ! read type of simulation
- call read_value_integer(IIN,IGNORE_JUNK,SIMULATION_TYPE)
- call read_value_logical(IIN,IGNORE_JUNK,SAVE_FORWARD)
-
- ! read info about external mesh
- call read_value_logical(IIN,IGNORE_JUNK,read_external_mesh)
- call read_value_string(IIN,IGNORE_JUNK,mesh_file)
- call read_value_string(IIN,IGNORE_JUNK,nodes_coords_file)
- call read_value_string(IIN,IGNORE_JUNK,materials_file)
- call read_value_string(IIN,IGNORE_JUNK,free_surface_file)
- call read_value_string(IIN,IGNORE_JUNK,absorbing_surface_file)
- call read_value_string(IIN,IGNORE_JUNK,tangential_detection_curve_file)
-
- ! read info about partitioning
- call read_value_integer(IIN,IGNORE_JUNK,nproc)
- call read_value_integer(IIN,IGNORE_JUNK,partitioning_method)
-
- ! read grid parameters
- call read_value_double_precision(IIN,IGNORE_JUNK,xmin)
- call read_value_double_precision(IIN,IGNORE_JUNK,xmax)
- call read_value_integer(IIN,IGNORE_JUNK,nx)
- call read_value_integer(IIN,IGNORE_JUNK,ngnod)
- call read_value_logical(IIN,IGNORE_JUNK,initialfield)
- call read_value_logical(IIN,IGNORE_JUNK,add_Bielak_conditions)
- call read_value_logical(IIN,IGNORE_JUNK,assign_external_model)
- call read_value_logical(IIN,IGNORE_JUNK,READ_EXTERNAL_SEP_FILE)
- call read_value_logical(IIN,IGNORE_JUNK,TURN_ATTENUATION_ON)
- ! read viscous attenuation parameters (poroelastic media)
- call read_value_logical(IIN,IGNORE_JUNK,TURN_VISCATTENUATION_ON)
- call read_value_double_precision(IIN,IGNORE_JUNK,Q0)
- call read_value_double_precision(IIN,IGNORE_JUNK,freq0)
- ! determine if body or surface (membrane) waves calculation
- call read_value_logical(IIN,IGNORE_JUNK,p_sv)
-
- ! read absorbing boundaries parameters
- call read_value_logical(IIN,IGNORE_JUNK,any_abs)
- call read_value_logical(IIN,IGNORE_JUNK,absbottom)
- call read_value_logical(IIN,IGNORE_JUNK,absright)
- call read_value_logical(IIN,IGNORE_JUNK,abstop)
- call read_value_logical(IIN,IGNORE_JUNK,absleft)
-
- ! read time step parameters
- call read_value_integer(IIN,IGNORE_JUNK,nt)
- call read_value_double_precision(IIN,IGNORE_JUNK,deltat)
-
- ! read source infos
- call read_value_integer(IIN,IGNORE_JUNK,NSOURCES)
- call read_value_logical(IIN,IGNORE_JUNK,force_normal_to_surface)
-
- ! read constants for attenuation
- call read_value_integer(IIN,IGNORE_JUNK,N_SLS)
- call read_value_double_precision(IIN,IGNORE_JUNK,f0_attenuation)
-
- ! read receiver line parameters
- call read_value_integer(IIN,IGNORE_JUNK,seismotype)
- call read_value_logical(IIN,IGNORE_JUNK,generate_STATIONS)
- call read_value_integer(IIN,IGNORE_JUNK,nreceiverlines)
- call read_value_double_precision(IIN,IGNORE_JUNK,anglerec)
- call read_value_logical(IIN,IGNORE_JUNK,rec_normal_to_surface)
-
- if(nreceiverlines < 1) stop 'number of receiver lines must be greater than 1'
-
- ! allocate receiver line arrays
- allocate(nrec(nreceiverlines))
- allocate(xdeb(nreceiverlines))
- allocate(zdeb(nreceiverlines))
- allocate(xfin(nreceiverlines))
- allocate(zfin(nreceiverlines))
- allocate(enreg_surf_same_vertical(nreceiverlines),stat=ios)
- if( ios /= 0 ) stop 'error allocating receiver lines'
-
- ! loop on all the receiver lines
- do ireceiverlines = 1,nreceiverlines
- call read_value_integer(IIN,IGNORE_JUNK,nrec(ireceiverlines))
- call read_value_double_precision(IIN,IGNORE_JUNK,xdeb(ireceiverlines))
- call read_value_double_precision(IIN,IGNORE_JUNK,zdeb(ireceiverlines))
- call read_value_double_precision(IIN,IGNORE_JUNK,xfin(ireceiverlines))
- call read_value_double_precision(IIN,IGNORE_JUNK,zfin(ireceiverlines))
- call read_value_logical(IIN,IGNORE_JUNK,enreg_surf_same_vertical(ireceiverlines))
- if (read_external_mesh .and. enreg_surf_same_vertical(ireceiverlines)) then
- stop 'Cannot use enreg_surf_same_vertical with external meshes!'
- endif
- enddo
-
- ! read display parameters
- call read_value_integer(IIN,IGNORE_JUNK,NTSTEP_BETWEEN_OUTPUT_INFO)
- call read_value_logical(IIN,IGNORE_JUNK,output_postscript_snapshot)
- call read_value_logical(IIN,IGNORE_JUNK,output_color_image)
- call read_value_integer(IIN,IGNORE_JUNK,imagetype)
- call read_value_double_precision(IIN,IGNORE_JUNK,cutsnaps)
- call read_value_logical(IIN,IGNORE_JUNK,meshvect)
- call read_value_logical(IIN,IGNORE_JUNK,modelvect)
- call read_value_logical(IIN,IGNORE_JUNK,boundvect)
- call read_value_logical(IIN,IGNORE_JUNK,interpol)
- call read_value_integer(IIN,IGNORE_JUNK,pointsdisp)
- call read_value_integer(IIN,IGNORE_JUNK,subsamp)
- call read_value_double_precision(IIN,IGNORE_JUNK,sizemax_arrows)
- call read_value_logical(IIN,IGNORE_JUNK,gnuplot)
- call read_value_logical(IIN,IGNORE_JUNK,outputgrid)
- call read_value_logical(IIN,IGNORE_JUNK,OUTPUT_ENERGY)
-
-
- ! read the different material materials
- call read_value_integer(IIN,IGNORE_JUNK,nb_materials)
- if(nb_materials <= 0) stop 'Negative number of materials not allowed!'
-
- allocate(icodemat(nb_materials))
- allocate(cp(nb_materials))
- allocate(cs(nb_materials))
- allocate(aniso3(nb_materials))
- allocate(aniso4(nb_materials))
- allocate(aniso5(nb_materials))
- allocate(aniso6(nb_materials))
- allocate(aniso7(nb_materials))
- allocate(aniso8(nb_materials))
- allocate(Qp(nb_materials))
- allocate(Qs(nb_materials))
- allocate(rho_s(nb_materials))
- allocate(rho_f(nb_materials))
- allocate(phi(nb_materials))
- allocate(tortuosity(nb_materials))
- allocate(permxx(nb_materials))
- allocate(permxz(nb_materials))
- allocate(permzz(nb_materials))
- allocate(kappa_s(nb_materials))
- allocate(kappa_f(nb_materials))
- allocate(kappa_fr(nb_materials))
- allocate(eta_f(nb_materials))
- allocate(mu_fr(nb_materials))
-
- call read_materials(nb_materials,icodemat,cp,cs, &
- aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
- Qp,Qs,rho_s,rho_f,phi,tortuosity, &
- permxx,permxz,permzz,kappa_s,kappa_f,kappa_fr, &
- eta_f,mu_fr)
-
-
- ! checks input parameters
- call check_parameters()
-
- end subroutine read_parameter_file
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine check_parameters()
-
- implicit none
-
- ! checks partitioning
- if ( nproc <= 0 ) then
- print *, 'Number of processes (nproc) must be greater than or equal to one.'
- stop
- endif
-
-#ifndef USE_MPI
- if ( nproc > 1 ) then
- print *, 'Number of processes (nproc) must be equal to one when not using MPI.'
- print *, 'Please recompile with -DUSE_MPI in order to enable use of MPI.'
- stop
- endif
-#endif
-
- if(partitioning_method /= 1 .and. partitioning_method /= 3) then
- print *, 'Invalid partitioning method number.'
- print *, 'Partitioning method ',partitioning_method,' was requested, but is not available.'
- print *, 'Support for the METIS graph partitioner has been discontinued, please use SCOTCH (option 3) instead.'
- stop
- endif
-
- ! checks absorbing boundaries
- if ( .not. any_abs ) then
- absbottom = .false.
- absright = .false.
- abstop = .false.
- absleft = .false.
- endif
-
- ! can use only one point to display lower-left corner only for interpolated snapshot
- if(pointsdisp < 3) then
- pointsdisp = 3
- plot_lowerleft_corner_only = .true.
- else
- plot_lowerleft_corner_only = .false.
- endif
-
- end subroutine check_parameters
-
-end module parameter_file
-
Deleted: seismo/2D/SPECFEM2D/trunk/read_regions.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/read_regions.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/read_regions.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,145 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine read_regions(nbregion,nb_materials,icodemat,cp,cs, &
- rho_s,Qp,Qs,aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
- nelmnts,num_material,nxread,nzread)
-
-! reads in material definitions in DATA/Par_file
-
- implicit none
- include "constants.h"
-
- integer :: nbregion,nb_materials
- integer, dimension(nb_materials) :: icodemat
- double precision, dimension(nb_materials) :: rho_s,cp,cs, &
- aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
-
- integer :: nelmnts
- integer,dimension(nelmnts) :: num_material
- integer :: nxread,nzread
-
- ! local parameters
- integer :: iregion,ixdebregion,ixfinregion,izdebregion,izfinregion,imaterial_number
- integer :: i,j
- double precision :: vpregion,vsregion,poisson_ratio
-
- ! read the material numbers for each region
- call read_value_integer(IIN,IGNORE_JUNK,nbregion)
-
- if(nbregion <= 0) stop 'Negative number of regions not allowed!'
-
- print *
- print *, 'Nb of regions in the mesh = ',nbregion
- print *
-
- do iregion = 1,nbregion
-
- call read_region_coordinates(IIN,DONT_IGNORE_JUNK,ixdebregion,ixfinregion, &
- izdebregion,izfinregion,imaterial_number)
-
- if(imaterial_number < 1) stop 'Negative material number not allowed!'
- if(ixdebregion < 1) stop 'Left coordinate of region negative!'
- if(ixfinregion > nxread) stop 'Right coordinate of region too high!'
- if(izdebregion < 1) stop 'Bottom coordinate of region negative!'
- if(izfinregion > nzread) stop 'Top coordinate of region too high!'
-
- print *,'Region ',iregion
- print *,'IX from ',ixdebregion,' to ',ixfinregion
- print *,'IZ from ',izdebregion,' to ',izfinregion
-
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. icodemat(imaterial_number) /= POROELASTIC_MATERIAL) then
-
- ! isotropic material
- vpregion = cp(imaterial_number)
- vsregion = cs(imaterial_number)
- print *,'Material # ',imaterial_number,' isotropic'
- if(vsregion < TINYVAL) then
- print *,'Material is fluid'
- else
- print *,'Material is solid'
- endif
- print *,'vp = ',vpregion
- print *,'vs = ',vsregion
- print *,'rho = ',rho_s(imaterial_number)
- poisson_ratio = 0.5d0*(vpregion*vpregion-2.d0*vsregion*vsregion) / (vpregion*vpregion-vsregion*vsregion)
- print *,'Poisson''s ratio = ',poisson_ratio
- if(poisson_ratio <= -1.00001d0 .or. poisson_ratio >= 0.50001d0) stop 'incorrect value of Poisson''s ratio'
- print *,'Qp = ',Qp(imaterial_number)
- print *,'Qs = ',Qs(imaterial_number)
- elseif(icodemat(imaterial_number) == POROELASTIC_MATERIAL) then
-
- ! poroelastic material
- print *,'Material # ',imaterial_number,' isotropic'
- print *,'Material is poroelastic'
- else
-
- ! anisotropic material
- print *,'Material # ',imaterial_number,' anisotropic'
- print *,'cp = ',cp(imaterial_number)
- print *,'cs = ',cs(imaterial_number)
- print *,'c11 = ',aniso3(imaterial_number)
- print *,'c13 = ',aniso4(imaterial_number)
- print *,'c15 = ',aniso5(imaterial_number)
- print *,'c33 = ',aniso6(imaterial_number)
- print *,'c35 = ',aniso7(imaterial_number)
- print *,'c55 = ',aniso8(imaterial_number)
- print *,'rho = ',rho_s(imaterial_number)
- print *,'Qp = ',Qp(imaterial_number)
- print *,'Qs = ',Qs(imaterial_number)
- endif
- print *,' -----'
-
- ! store density and velocity model
- do i = ixdebregion,ixfinregion
- do j = izdebregion,izfinregion
- num_material((j-1)*nxread+i) = imaterial_number
- enddo
- enddo
-
- enddo
-
- if(minval(num_material) <= 0) stop 'Velocity model not entirely set...'
-
- end subroutine read_regions
Deleted: seismo/2D/SPECFEM2D/trunk/read_source_file.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/read_source_file.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/read_source_file.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,144 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-module source_file
-
- implicit none
-
- ! source parameters
- integer, dimension(:),pointer :: source_type,time_function_type
- double precision, dimension(:),pointer :: xs,zs,f0,tshift_src,angleforce, &
- Mxx,Mzz,Mxz,factor
- logical, dimension(:),pointer :: source_surf
-
-contains
-
- subroutine read_source_file(NSOURCES)
-
-! reads in source file DATA/SOURCE
-
- implicit none
- include "constants.h"
-
- integer :: NSOURCES
-
- ! local parameters
- integer :: ios,icounter,i_source,num_sources
- character(len=150) dummystring
- integer, parameter :: IIN_SOURCE = 22
-
- ! allocates memory arrays
- allocate(source_surf(NSOURCES))
- allocate(xs(NSOURCES))
- allocate(zs(NSOURCES))
- allocate(source_type(NSOURCES))
- allocate(time_function_type(NSOURCES))
- allocate(f0(NSOURCES))
- allocate(tshift_src(NSOURCES))
- allocate(angleforce(NSOURCES))
- allocate(Mxx(NSOURCES))
- allocate(Mxz(NSOURCES))
- allocate(Mzz(NSOURCES))
- allocate(factor(NSOURCES))
-
- ! counts lines
- open(unit=IIN_SOURCE,file='DATA/SOURCE',iostat=ios,status='old',action='read')
- if(ios /= 0) stop 'error opening DATA/SOURCE file'
-
- icounter = 0
- do while(ios == 0)
- read(IIN_SOURCE,"(a)",iostat=ios) dummystring
- if(ios == 0) icounter = icounter + 1
- enddo
- close(IIN_SOURCE)
-
- ! checks counter
- if(mod(icounter,NLINES_PER_SOURCE) /= 0) &
- stop 'total number of lines in SOURCE file should be a multiple of NLINES_PER_SOURCE'
-
- ! total number of sources
- num_sources = icounter / NLINES_PER_SOURCE
-
- if(num_sources < 1) stop 'need at least one source in SOURCE file'
- if(num_sources /= NSOURCES) &
- stop 'total number of sources read is different than declared in Par_file'
-
- ! reads in source parameters
- open(unit=IIN_SOURCE,file='DATA/SOURCE',status='old',action='read')
- do i_source=1,NSOURCES
- call read_value_logical(IIN_SOURCE,IGNORE_JUNK,source_surf(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,xs(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,zs(i_source))
- call read_value_integer(IIN_SOURCE,IGNORE_JUNK,source_type(i_source))
- call read_value_integer(IIN_SOURCE,IGNORE_JUNK,time_function_type(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,f0(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,tshift_src(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,angleforce(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mxx(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mzz(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mxz(i_source))
- call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,factor(i_source))
-
- ! note: we will further process source info in solver,
- ! here we just read in the given specifics and show them
-
- print *
- print *,'Source', i_source
- print *,'Position xs, zs = ',xs(i_source),zs(i_source)
- print *,'Frequency, delay = ',f0(i_source),tshift_src(i_source)
- print *,'Source type (1=force, 2=explosion): ',source_type(i_source)
- print *,'Time function type (1=Ricker, 2=First derivative, 3=Gaussian, 4=Dirac, 5=Heaviside): ',time_function_type(i_source)
- print *,'Angle of the source if force = ',angleforce(i_source)
- print *,'Mxx of the source if moment tensor = ',Mxx(i_source)
- print *,'Mzz of the source if moment tensor = ',Mzz(i_source)
- print *,'Mxz of the source if moment tensor = ',Mxz(i_source)
- print *,'Multiplying factor = ',factor(i_source)
- print *
- enddo ! do i_source=1,NSOURCES
- close(IIN_SOURCE)
-
- end subroutine read_source_file
-
-end module source_file
-
Deleted: seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,211 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! read values from parameter file, ignoring white lines and comments
-
- subroutine read_value_integer(iin,ignore_junk,value_to_read)
-
- implicit none
-
- integer iin
- logical ignore_junk
- integer value_to_read
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) value_to_read
-
- end subroutine read_value_integer
-
-!--------------------
-
- subroutine read_value_double_precision(iin,ignore_junk,value_to_read)
-
- implicit none
-
- integer iin
- logical ignore_junk
- double precision value_to_read
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) value_to_read
-
- end subroutine read_value_double_precision
-
-!--------------------
-
- subroutine read_value_logical(iin,ignore_junk,value_to_read)
-
- implicit none
-
- integer iin
- logical ignore_junk
- logical value_to_read
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) value_to_read
-
- end subroutine read_value_logical
-
-!--------------------
-
- subroutine read_value_string(iin,ignore_junk,value_to_read)
-
- implicit none
-
- integer iin
- logical ignore_junk
- character(len=*) value_to_read
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- value_to_read = string_read
-
- end subroutine read_value_string
-
-!--------------------
-
- subroutine read_two_interface_points(iin,ignore_junk,value_to_read_1,value_to_read_2)
-
- implicit none
-
- integer iin
- logical ignore_junk
- double precision value_to_read_1,value_to_read_2
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) value_to_read_1,value_to_read_2
-
- end subroutine read_two_interface_points
-
-!--------------------
-
- subroutine read_region_coordinates(iin,ignore_junk,value_to_read_1,value_to_read_2, &
- value_to_read_3,value_to_read_4,value_to_read_5)
-
- implicit none
-
- integer iin
- logical ignore_junk
- integer value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5
-
- end subroutine read_region_coordinates
-
-!--------------------
-
- subroutine read_material_parameters(iin,ignore_junk,i,icodematread,val0read,val1read,val2read,val3read, &
- val4read,val5read,val6read,val7read,val8read,val9read,val10read,val11read,val12read)
-
-
- implicit none
-
- integer iin
- logical ignore_junk
- integer i,icodematread
- double precision val0read,val1read,val2read,val3read,val4read,val5read,val6read,val7read,&
- val8read,val9read,val10read,val11read,val12read
-
- character(len=100) string_read
-
- call read_next_line(iin,ignore_junk,string_read)
- print*,string_read
- read(string_read,*) i,icodematread,val0read,val1read,val2read,val3read,val4read,val5read,&
- val6read,val7read,val8read,val9read,val10read,val11read,val12read
-
-
- end subroutine read_material_parameters
-
-!--------------------
-
- subroutine read_next_line(iin,ignore_junk,string_read)
-
- implicit none
-
- logical ignore_junk
- character(len=100) string_read
-
- integer ios,iin,index_equal_sign
-
- do
- read(unit=iin,fmt="(a100)",iostat=ios) string_read
- if(ios /= 0) stop 'error while reading input file'
-
-! suppress leading white spaces, if any
- string_read = adjustl(string_read)
-
-! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS)
- if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1)
-
-! exit loop when we find the first line that is not a comment or a white line
- if(len_trim(string_read) == 0) cycle
- if(string_read(1:1) /= '#') exit
-
- enddo
-
-! suppress trailing white spaces, if any
- string_read = string_read(1:len_trim(string_read))
-
-! suppress trailing comments, if any
- if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1)
-
-! suppress leading junk (up to the first equal sign, included) if needed
- if(ignore_junk) then
- index_equal_sign = index(string_read,'=')
- if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file'
- string_read = string_read(index_equal_sign + 1:len_trim(string_read))
- endif
-
-! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk
- string_read = adjustl(string_read)
- string_read = string_read(1:len_trim(string_read))
-
- end subroutine read_next_line
-
Deleted: seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,168 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! recompute 2D jacobian at a given point in a 4-node or 9-node element
-
- subroutine recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian,coorg,knods,ispec,ngnod,nspec,npgeo, &
- stop_if_negative_jacobian)
-
- implicit none
-
- include "constants.h"
-
- integer ispec,ngnod,nspec,npgeo
- double precision x,z,xix,xiz,gammax,gammaz
- double precision xi,gamma,jacobian
-
- integer knods(ngnod,nspec)
- double precision coorg(NDIM,npgeo)
-
-! 2D shape functions and their derivatives at receiver
- double precision shape2D(ngnod)
- double precision dershape2D(NDIM,ngnod)
-
- double precision xxi,zxi,xgamma,zgamma,xelm,zelm
-
- integer ia,nnum
-
- logical stop_if_negative_jacobian
-
-! only one problematic element is output to OpenDX for now in case of elements with a negative Jacobian
- integer, parameter :: ntotspecAVS_DX = 1
-
-! recompute jacobian for any (xi,gamma) point, not necessarily a GLL point
-
-! create the 2D shape functions and the Jacobian
- call define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)
-
-! compute coordinates and jacobian matrix
- x = ZERO
- z = ZERO
-
- xxi = ZERO
- zxi = ZERO
- xgamma = ZERO
- zgamma = ZERO
-
- do ia=1,ngnod
-
- nnum = knods(ia,ispec)
-
- xelm = coorg(1,nnum)
- zelm = coorg(2,nnum)
-
- x = x + shape2D(ia)*xelm
- z = z + shape2D(ia)*zelm
-
- xxi = xxi + dershape2D(1,ia)*xelm
- zxi = zxi + dershape2D(1,ia)*zelm
- xgamma = xgamma + dershape2D(2,ia)*xelm
- zgamma = zgamma + dershape2D(2,ia)*zelm
-
- enddo
-
- jacobian = xxi*zgamma - xgamma*zxi
-
-! the Jacobian is negative, so far this means that there is an error in the mesh
-! therefore print the coordinates of the mesh points of this element
-! and also create an OpenDX file to visualize it
- if(jacobian <= ZERO .and. stop_if_negative_jacobian) then
-
-! print the coordinates of the mesh points of this element
- print *, 'ispec = ', ispec
- print *, 'ngnod = ', ngnod
- do ia=1,ngnod
- nnum = knods(ia,ispec)
- xelm = coorg(1,nnum)
- zelm = coorg(2,nnum)
- print *,'node ', ia,' x,y = ',xelm,zelm
- enddo
-
-! create an OpenDX file to visualize this element
- open(unit=11,file='DX_first_element_with_negative_jacobian.dx',status='unknown')
-
-! output the points (the mesh is flat therefore the third coordinate is zero)
- write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ngnod,' data follows'
- do ia=1,ngnod
- nnum = knods(ia,ispec)
- xelm = coorg(1,nnum)
- zelm = coorg(2,nnum)
- write(11,*) xelm,zelm,' 0'
- enddo
-
-! output the element (use its four corners only for now)
- write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows'
-! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
- write(11,*) '0 3 1 2'
-
-! output element data
- write(11,*) 'attribute "element type" string "quads"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
-
-! output dummy data value
- write(11,*) '1'
-
-! define OpenDX field
- write(11,*) 'attribute "dep" string "connections"'
- write(11,*) 'object "irregular positions irregular connections" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
-
-! close OpenDX file
- close(11)
-
- call exit_MPI('negative 2D Jacobian, element saved in DX_first_element_with_negative_jacobian.dx')
- endif
-
-! invert the relation
- xix = zgamma / jacobian
- gammax = - zxi / jacobian
- xiz = - xgamma / jacobian
- gammaz = xxi / jacobian
-
- end subroutine recompute_jacobian
-
Deleted: seismo/2D/SPECFEM2D/trunk/save_databases.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/save_databases.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/save_databases.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,263 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine save_databases(nspec,num_material, &
- my_interfaces,my_nb_interfaces, &
- nnodes_tangential_curve,nodes_tangential_curve )
-
-
-! generates the databases for the solver
-
- use part_unstruct
- use parameter_file
- use source_file
- implicit none
- include "constants.h"
-
- integer :: nspec
- integer, dimension(nelmnts) :: num_material
-
- integer, dimension(0:ninterfaces-1) :: my_interfaces
- integer, dimension(0:ninterfaces-1) :: my_nb_interfaces
-
- integer :: nnodes_tangential_curve
- double precision, dimension(2,nnodes_tangential_curve) :: nodes_tangential_curve
-
- ! local parameters
- integer :: iproc,i_source,i,ios
- integer :: npgeo
- integer :: my_ninterface
- integer :: nedges_coupled_loc
- integer :: nedges_acporo_coupled_loc
- integer :: nedges_elporo_coupled_loc
-
- character(len=256) :: prname
-
-
- do iproc = 0, nproc-1
-
- ! opens Database file
- write(prname, "('./OUTPUT_FILES/Database',i5.5)") iproc
- open(unit=15,file=trim(prname),status='unknown',iostat=ios)
- if( ios /= 0 ) stop 'error saving databases'
-
- write(15,*) '#'
- write(15,*) '# Database for SPECFEM2D'
- write(15,*) '# Dimitri Komatitsch, (c) University of Pau, France'
- write(15,*) '#'
-
- write(15,*) 'Title of the simulation'
- write(15,"(a100)") title
-
- write(15,*) 'Type of simulation'
- write(15,*) SIMULATION_TYPE, SAVE_FORWARD
-
- call write_glob2loc_nodes_database(15, iproc, npgeo, 1)
-
-
- call write_partition_database(15, iproc, nspec, num_material, ngnod, 1)
-
-
- write(15,*) 'npgeo'
- write(15,*) npgeo
-
- write(15,*) 'gnuplot interpol'
- write(15,*) gnuplot,interpol
-
- write(15,*) 'NTSTEP_BETWEEN_OUTPUT_INFO'
- write(15,*) NTSTEP_BETWEEN_OUTPUT_INFO
-
- write(15,*) 'output_postscript_snapshot output_color_image colors numbers'
- write(15,*) output_postscript_snapshot,output_color_image,' 1 0'
-
- write(15,*) 'meshvect modelvect boundvect cutsnaps subsamp sizemax_arrows'
- write(15,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
-
- write(15,*) 'anglerec'
- write(15,*) anglerec
-
- write(15,*) 'initialfield add_Bielak_conditions'
- write(15,*) initialfield,add_Bielak_conditions
-
- write(15,*) 'seismotype imagetype'
- write(15,*) seismotype,imagetype
-
- write(15,*) 'assign_external_model READ_EXTERNAL_SEP_FILE'
- write(15,*) assign_external_model,READ_EXTERNAL_SEP_FILE
-
- write(15,*) 'outputgrid OUTPUT_ENERGY TURN_ATTENUATION_ON'
- write(15,*) outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON
-
- write(15,*) 'TURN_VISCATTENUATION_ON Q0 freq0'
- write(15,*) TURN_VISCATTENUATION_ON,Q0,freq0
-
- write(15,*) 'p_sv'
- write(15,*) p_sv
-
- write(15,*) 'nt deltat'
- write(15,*) nt,deltat
- write(15,*) 'NSOURCES'
- write(15,*) NSOURCES
-
- do i_source=1,NSOURCES
- write(15,*) 'source', i_source
- write(15,*) source_type(i_source),time_function_type(i_source), &
- xs(i_source),zs(i_source),f0(i_source),tshift_src(i_source), &
- factor(i_source),angleforce(i_source), &
- Mxx(i_source),Mzz(i_source),Mxz(i_source)
- enddo
-
- write(15,*) 'attenuation'
- write(15,*) N_SLS, f0_attenuation
-
- write(15,*) 'Coordinates of macrobloc mesh (coorg):'
-
- call write_glob2loc_nodes_database(15, iproc, npgeo, 2)
-
- write(15,*) 'numat ngnod nspec pointsdisp plot_lowerleft_corner_only'
- write(15,*) nb_materials,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
-
- if (any_abs) then
- call write_abs_merge_database(15, iproc, 1)
- else
- nelemabs_loc = 0
- endif
-
- call write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
- iproc, 1)
-
- call write_fluidsolid_edges_database(15,nedges_coupled, nedges_coupled_loc, &
- edges_coupled, iproc, 1)
- call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
- edges_acporo_coupled, iproc, 1)
- call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
- edges_elporo_coupled, iproc, 1)
-
- if (.not. ( force_normal_to_surface .or. rec_normal_to_surface ) ) then
- nnodes_tangential_curve = 0
- endif
-
- write(15,*) 'nelemabs nelem_acoustic_surface num_fluid_solid_edges num_fluid_poro_edges'
- write(15,*) 'num_solid_poro_edges nnodes_tangential_curve'
- write(15,*) nelemabs_loc,nelem_acoustic_surface_loc, &
- nedges_coupled_loc,nedges_acporo_coupled_loc,&
- nedges_elporo_coupled_loc,nnodes_tangential_curve
-
- write(15,*) 'Material sets (num 1 rho vp vs 0 0 Qp Qs 0 0 0 0 0 0) or '
- write(15,*) '(num 2 rho c11 c13 c33 c44 Qp Qs 0 0 0 0 0 0) or '
- write(15,*) '(num 3 rhos rhof phi c k_xx k_xz k_zz Ks Kf Kfr etaf mufr Qs)'
- do i=1,nb_materials
- if (icodemat(i) == ISOTROPIC_MATERIAL) then
- write(15,*) i,icodemat(i),rho_s(i),cp(i),cs(i),0,0,Qp(i),Qs(i),0,0,0,0,0,0
- elseif(icodemat(i) == POROELASTIC_MATERIAL) then
- write(15,*) i,icodemat(i),rho_s(i),rho_f(i),phi(i),tortuosity(i), &
- permxx(i),permxz(i),permzz(i),kappa_s(i),&
- kappa_f(i),kappa_fr(i),eta_f(i),mu_fr(i),Qs(i)
- else
- write(15,*) i,icodemat(i),rho_s(i),cp(i),cs(i), &
- aniso3(i),aniso4(i),aniso5(i),aniso6(i),&
- aniso7(i),aniso8(i),Qp(i),Qs(i),0,0
- endif
- enddo
-
- write(15,*) 'Arrays kmato and knods for each bloc:'
-
- call write_partition_database(15, iproc, nspec, num_material, ngnod, 2)
-
- if ( nproc /= 1 ) then
- call write_interfaces_database(15, nproc, iproc, &
- my_ninterface, my_interfaces, my_nb_interfaces, 1)
-
- write(15,*) 'Interfaces:'
- write(15,*) my_ninterface, maxval(my_nb_interfaces)
-
- call write_interfaces_database(15, nproc, iproc, &
- my_ninterface, my_interfaces, my_nb_interfaces, 2)
-
- else
- write(15,*) 'Interfaces:'
- write(15,*) 0, 0
- endif
-
-
- write(15,*) 'List of absorbing elements (bottom right top left):'
- if ( any_abs ) then
- call write_abs_merge_database(15, iproc, 2)
- endif
-
- write(15,*) 'List of acoustic free-surface elements:'
- call write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
- iproc, 2)
-
-
- write(15,*) 'List of acoustic elastic coupled edges:'
- call write_fluidsolid_edges_database(15, nedges_coupled, nedges_coupled_loc, &
- edges_coupled, iproc, 2)
-
- write(15,*) 'List of acoustic poroelastic coupled edges:'
- call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
- edges_acporo_coupled, iproc, 2)
-
- write(15,*) 'List of poroelastic elastic coupled edges:'
- call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
- edges_elporo_coupled, iproc, 2)
-
- write(15,*) 'List of tangential detection curve nodes:'
- !write(15,*) nnodes_tangential_curve
- write(15,*) force_normal_to_surface,rec_normal_to_surface
-
- if (force_normal_to_surface .or. rec_normal_to_surface) then
- do i = 1, nnodes_tangential_curve
- write(15,*) nodes_tangential_curve(1,i),nodes_tangential_curve(2,i)
- enddo
- endif
-
- ! closes Database file
- close(15)
-
- enddo
-
- end subroutine save_databases
-
Deleted: seismo/2D/SPECFEM2D/trunk/save_gnuplot_file.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/save_gnuplot_file.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/save_gnuplot_file.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,118 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine save_gnuplot_file(ngnod,nx,nz,x,z)
-
-! creates a Gnuplot file that displays the grid
-
- implicit none
-
- integer :: ngnod,nx,nz
- double precision, dimension(0:nx,0:nz) :: x,z
-
- ! local parameters
- integer :: ios,istepx,istepz,ili,icol
-
- print *
- print *,'Saving the grid in Gnuplot format...'
-
- open(unit=20,file='OUTPUT_FILES/gridfile.gnu',status='unknown',iostat=ios)
- if( ios /= 0 ) stop 'error saving gnuplot file'
-
- ! draw horizontal lines of the grid
- print *,'drawing horizontal lines of the grid'
- istepx = 1
- if(ngnod == 4) then
- istepz = 1
- else
- istepz = 2
- endif
- do ili=0,nz,istepz
- do icol=0,nx-istepx,istepx
- write(20,*) sngl(x(icol,ili)),sngl(z(icol,ili))
- write(20,*) sngl(x(icol+istepx,ili)),sngl(z(icol+istepx,ili))
- write(20,10)
- enddo
- enddo
-
- ! draw vertical lines of the grid
- print *,'drawing vertical lines of the grid'
- if(ngnod == 4) then
- istepx = 1
- else
- istepx = 2
- endif
- istepz = 1
- do icol=0,nx,istepx
- do ili=0,nz-istepz,istepz
- write(20,*) sngl(x(icol,ili)),sngl(z(icol,ili))
- write(20,*) sngl(x(icol,ili+istepz)),sngl(z(icol,ili+istepz))
- write(20,10)
- enddo
- enddo
-
-10 format('')
-
- close(20)
-
- ! create a Gnuplot script to display the grid
- open(unit=20,file='OUTPUT_FILES/plotgnu',status='unknown',iostat=ios)
- if( ios /= 0 ) stop 'error saving plotgnu file'
-
- write(20,*) '#set term X11'
- write(20,*) 'set term postscript landscape monochrome solid "Helvetica" 22'
- write(20,*) 'set output "grid.ps"'
- write(20,*) '#set xrange [',sngl(minval(x)),':',sngl(maxval(x)),']'
- write(20,*) '#set yrange [',sngl(minval(z)),':',sngl(maxval(z)),']'
- ! use same unit length on both X and Y axes
- write(20,*) 'set size ratio -1'
- write(20,*) 'plot "gridfile.gnu" title "Macrobloc mesh" w l'
- write(20,*) 'pause -1 "Hit any key..."'
- close(20)
-
- print *,'Grid saved in Gnuplot format...'
- print *
-
- end subroutine save_gnuplot_file
Deleted: seismo/2D/SPECFEM2D/trunk/save_openDX_jacobian.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/save_openDX_jacobian.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/save_openDX_jacobian.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,155 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine save_openDX_jacobian(nspec,npgeo,ngnod,knods,coorg,xigll,zigll)
-
- implicit none
- include "constants.h"
-
- integer :: nspec,npgeo,ngnod
- double precision, dimension(NDIM,npgeo) :: coorg
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLZ) :: zigll
-
- integer, dimension(ngnod,nspec) :: knods
-
- ! local parameters
- integer, dimension(:), allocatable :: ibool_OpenDX
- logical, dimension(:), allocatable :: mask_point
- double precision :: xelm,zelm
- double precision :: xi,gamma,x,z
- double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
-
- integer :: ia,nnum,ipoint_number,total_of_negative_elements
- integer :: ispec,i,j
- logical :: found_a_problem_in_this_element
-
- ! create an OpenDX file to visualize this element
- open(unit=11,file='DX_all_elements_with_negative_jacobian_in_red.dx',status='unknown')
-
- ! output all the points (i.e. all the control points of the mesh)
- ! the mesh is flat therefore the third coordinate is zero
- write(11,*) 'object 1 class array type float rank 1 shape 3 items ',npgeo,' data follows'
- ipoint_number = 0
- allocate(mask_point(npgeo))
- allocate(ibool_OpenDX(npgeo))
- mask_point(:) = .false.
- do ispec = 1,nspec
- do ia=1,ngnod
- nnum = knods(ia,ispec)
- xelm = coorg(1,nnum)
- zelm = coorg(2,nnum)
- if(.not. mask_point(knods(ia,ispec))) then
- mask_point(knods(ia,ispec)) = .true.
- ibool_OpenDX(knods(ia,ispec)) = ipoint_number
- write(11,*) xelm,zelm,' 0'
- ipoint_number = ipoint_number + 1
- endif
- enddo
- enddo
- deallocate(mask_point)
-
- ! output all the elements of the mesh (use their four corners only in OpenDX
- write(11,*) 'object 2 class array type int rank 1 shape 4 items ',nspec,' data follows'
- ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
- do ispec = 1,nspec
- write(11,*) ibool_OpenDX(knods(1,ispec)),ibool_OpenDX(knods(4,ispec)), &
- ibool_OpenDX(knods(2,ispec)),ibool_OpenDX(knods(3,ispec))
- enddo
- deallocate(ibool_OpenDX)
-
- ! output element data
- write(11,*) 'attribute "element type" string "quads"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items ',nspec,' data follows'
-
- ! output all the element data (value = 1 if positive Jacobian, = 2 if negative Jacobian)
- total_of_negative_elements = 0
- do ispec = 1,nspec
-
- ! check if this element has a negative Jacobian at any of its points
- found_a_problem_in_this_element = .false.
- do j = 1,NGLLZ
- do i = 1,NGLLX
- xi = xigll(i)
- gamma = zigll(j)
-
- call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
- jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
- .false.)
-
- if(jacobianl <= ZERO) found_a_problem_in_this_element = .true.
- enddo
- enddo
-
- ! output data value
- if(found_a_problem_in_this_element) then
- write(11,*) '2'
- print *,'element ',ispec,' has a negative Jacobian'
- total_of_negative_elements = total_of_negative_elements + 1
- else
- write(11,*) '1'
- endif
-
- enddo
-
- ! define OpenDX field
- write(11,*) 'attribute "dep" string "connections"'
- write(11,*) 'object "irregular positions irregular connections" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
-
- ! close OpenDX file
- close(11)
-
- print *
- print *,total_of_negative_elements,' elements have a negative Jacobian, out of ',nspec
- print *,'i.e., ',sngl(100.d0 * dble(total_of_negative_elements)/dble(nspec)),'%'
- print *
-
- end subroutine save_openDX_jacobian
\ No newline at end of file
Deleted: seismo/2D/SPECFEM2D/trunk/save_stations_file.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/save_stations_file.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/save_stations_file.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,122 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine save_stations_file(nreceiverlines,nrec,xdeb,zdeb,xfin,zfin,enreg_surf_same_vertical, &
- xinterface_top,zinterface_top,coefs_interface_top, &
- npoints_interface_top,max_npoints_interface)
-
- implicit none
-
- integer :: nreceiverlines
- integer, dimension(nreceiverlines) :: nrec
- double precision, dimension(nreceiverlines) :: xdeb,zdeb,xfin,zfin
- logical, dimension(nreceiverlines) :: enreg_surf_same_vertical
-
- integer :: max_npoints_interface
- double precision, dimension(max_npoints_interface) :: xinterface_top, &
- zinterface_top,coefs_interface_top
- integer :: npoints_interface_top
-
- !local parameters
- integer :: ireceiverlines,irec,irec_global_number,ios
- integer :: nrec_total
- double precision :: xrec,zrec
- double precision, external :: value_spline
-
- print *
- print *,'writing the DATA/STATIONS_target file'
- print *
-
- ! total number of receivers in all the receiver lines
- nrec_total = sum(nrec)
-
- print *
- print *,'There are ',nrec_total,' receivers'
-
- print *
- print *,'Position (x,z) of the ',nrec_total,' receivers'
- print *
-
- open(unit=15,file='DATA/STATIONS_target',status='unknown',iostat=ios)
- if( ios /= 0 ) stop 'error saving STATIONS file'
-
- irec_global_number = 0
-
- ! loop on all the receiver lines
- do ireceiverlines = 1,nreceiverlines
-
- ! loop on all the receivers of this receiver line
- do irec = 1,nrec(ireceiverlines)
-
- ! compute global receiver number
- irec_global_number = irec_global_number + 1
-
- ! compute coordinates of the receiver
- if(nrec(ireceiverlines) > 1) then
- xrec = xdeb(ireceiverlines) + dble(irec-1)*(xfin(ireceiverlines) &
- -xdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
- zrec = zdeb(ireceiverlines) + dble(irec-1)*(zfin(ireceiverlines) &
- -zdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
- else
- xrec = xdeb(ireceiverlines)
- zrec = zdeb(ireceiverlines)
- endif
-
- ! modify position of receiver if we must record exactly at the surface
- if(enreg_surf_same_vertical(ireceiverlines)) &
- zrec = value_spline(xrec,xinterface_top,zinterface_top, &
- coefs_interface_top,npoints_interface_top)
-
- ! display position of the receiver
- print *,'Receiver ',irec_global_number,' = ',xrec,zrec
-
- write(15,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") irec_global_number,xrec,zrec
-
- enddo
- enddo
-
- close(15)
-
- end subroutine save_stations_file
-
Deleted: seismo/2D/SPECFEM2D/trunk/scotchf.h
===================================================================
--- seismo/2D/SPECFEM2D/trunk/scotchf.h 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/scotchf.h 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,14 +0,0 @@
- INTEGER SCOTCH_ARCHDIM
- INTEGER SCOTCH_GEOMDIM
- INTEGER SCOTCH_GRAPHDIM
- INTEGER SCOTCH_MAPDIM
- INTEGER SCOTCH_MESHDIM
- INTEGER SCOTCH_ORDERDIM
- INTEGER SCOTCH_STRATDIM
- PARAMETER (SCOTCH_ARCHDIM = 4)
- PARAMETER (SCOTCH_GEOMDIM = 2)
- PARAMETER (SCOTCH_GRAPHDIM = 12)
- PARAMETER (SCOTCH_MAPDIM = 10)
- PARAMETER (SCOTCH_MESHDIM = 15)
- PARAMETER (SCOTCH_ORDERDIM = 11)
- PARAMETER (SCOTCH_STRATDIM = 1)
Deleted: seismo/2D/SPECFEM2D/trunk/set_sources.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/set_sources.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/set_sources.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,252 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
- subroutine set_sources(myrank,NSOURCES,source_type,time_function_type, &
- x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce,aval, &
- t0,initialfield,ipass,deltat)
-
-! gets source parameters
-
- implicit none
- include "constants.h"
-
- integer :: myrank
- integer :: NSOURCES
- integer, dimension(NSOURCES) :: source_type,time_function_type
- double precision, dimension(NSOURCES) :: x_source,z_source, &
- Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
- double precision, dimension(NSOURCES) :: aval
- double precision :: t0
- double precision :: deltat
- integer :: ipass
- logical :: initialfield
-
- ! local parameters
- integer :: i_source
- double precision, dimension(NSOURCES) :: t0_source,hdur
- double precision :: min_tshift_src_original
-
- ! checks the input
- do i_source=1,NSOURCES
-
- ! checks source type
- if(.not. initialfield) then
- if (source_type(i_source) == 1) then
- if ( myrank == 0 .and. ipass == 1 ) then
- ! user output
- write(IOUT,212) x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
- factor(i_source),angleforce(i_source)
- endif
- else if(source_type(i_source) == 2) then
- if ( myrank == 0 .and. ipass == 1 ) then
- ! user output
- write(IOUT,222) x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
- factor(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
- endif
- else
- call exit_MPI('Unknown source type number !')
- endif
- endif
-
- ! if Dirac source time function, use a very thin Gaussian instead
- ! if Heaviside source time function, use a very thin error function instead
- if(time_function_type(i_source) == 4 .or. time_function_type(i_source) == 5) &
- f0(i_source) = 1.d0 / (10.d0 * deltat)
-
- ! checks source frequency
- if( abs(f0(i_source)) < TINYVAL ) then
- call exit_MPI('Error source frequency is zero')
- endif
-
- ! half-duration of source
- hdur(i_source) = 1.d0 / f0(i_source)
-
- ! sets source start times, shifted by the given (non-zero) time-shift
- if(time_function_type(i_source)== 5) then
- t0_source(i_source) = 2.0d0 * hdur(i_source) + tshift_src(i_source)
- else
- t0_source(i_source) = 1.20d0 * hdur(i_source) + tshift_src(i_source)
- endif
-
- ! for the source time function
- aval(i_source) = PI*PI*f0(i_source)*f0(i_source)
-
- ! convert angle from degrees to radians
- angleforce(i_source) = angleforce(i_source) * PI / 180.d0
-
- enddo ! do i_source=1,NSOURCES
-
- ! initializes simulation start time
- if( NSOURCES == 1 ) then
- ! simulation start time
- t0 = t0_source(1)
- ! sets source time shift relative to simulation start time
- min_tshift_src_original = tshift_src(1)
- tshift_src(1) = 0.d0
- else
- ! starts with earliest start time
- t0 = minval( t0_source(:) )
- ! sets source time shifts relative to simulation start time
- min_tshift_src_original = minval( tshift_src(:) )
- tshift_src(:) = t0_source(:) - t0
- endif
-
- ! checks if user set USER_T0 to fix simulation start time
- ! note: USER_T0 has to be positive
- if( USER_T0 > 0.d0 ) then
- ! user cares about origin time and time shifts of the CMTSOLUTION
- ! and wants to fix simulation start time to a constant start time
- ! time 0 on time axis will correspond to given origin time
-
- ! notifies user
- if( myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) ' using USER_T0 . . . . . . . . . = ',USER_T0
- write(IOUT,*) ' original t0 . . . . . . . . . = ',t0
- write(IOUT,*) ' min_tshift_src_original . . . = ',min_tshift_src_original
- write(IOUT,*)
- endif
-
- ! checks if automatically set t0 is too small
- ! note: times in seismograms are shifted by t0(1)
- if( t0 <= USER_T0 + min_tshift_src_original ) then
-
- ! sets new simulation start time such that
- ! simulation starts at t = - t0 = - USER_T0
- t0 = USER_T0
-
- ! notifies user
- if( myrank == 0 .and. ipass == 1) then
- write(IOUT,*) ' fix new simulation start time . = ', - t0
- endif
-
- ! loops over all sources
- do i_source=1,NSOURCES
- ! sets the given, initial time shifts
- if( time_function_type(i_source) == 5 ) then
- tshift_src(i_source) = t0_source(i_source) - 2.0d0 * hdur(i_source)
- else
- tshift_src(i_source) = t0_source(i_source) - 1.20d0 * hdur(i_source)
- endif
- ! user output
- if( myrank == 0 .and. ipass == 1) then
- write(IOUT,*) ' source ',i_source,'uses tshift = ',tshift_src(i_source)
- endif
- enddo
- ! user output
- if( myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- endif
-
- else
- ! start time needs to be at least t0 for numerical stability
- ! notifies user
- if( myrank == 0 .and. ipass == 1) then
- write(IOUT,*) 'error: USER_T0 is too small'
- write(IOUT,*) ' must make one of three adjustements:'
- write(IOUT,*) ' - increase USER_T0 to be at least: ',t0
- write(IOUT,*) ' - decrease time shift tshift_src in SOURCE file'
- write(IOUT,*) ' - increase frequency f0 in SOURCE file'
- endif
- call exit_MPI('error USER_T0 is set but too small')
- endif
- else if( USER_T0 < 0.d0 ) then
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) 'error: USER_T0 is negative, must be set zero or positive!'
- endif
- call exit_MPI('error negative USER_T0 parameter in constants.h')
- endif
-
- ! checks onset times
- if(.not. initialfield) then
-
- ! loops over sources
- do i_source = 1,NSOURCES
-
- ! excludes Dirac and Heaviside sources
- if(time_function_type(i_source) /= 4 .and. time_function_type(i_source) /= 5) then
-
- ! user output
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) ' Onset time. . . . . . = ',t0+tshift_src(i_source)
- write(IOUT,*) ' Fundamental period. . = ',1.d0/f0(i_source)
- write(IOUT,*) ' Fundamental frequency = ',f0(i_source)
- endif
-
- ! checks source onset time
- if( t0+tshift_src(i_source) <= 1.d0/f0(i_source)) then
- call exit_MPI('Onset time too small')
- else
- if( myrank == 0 .and. ipass == 1 ) then
- write(IOUT,*) ' --> onset time ok'
- endif
- endif
- endif
- enddo
-
- endif
-
-
- ! output formats
-212 format(//,5x,'Source Type. . . . . . . . . . . . . . = Collocated Force',/5x, &
- 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
- 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
- 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
- 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
- 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x, &
- 'Angle from vertical direction (deg). . =',1pe20.10,/5x)
-
-222 format(//,5x,'Source Type. . . . . . . . . . . . . . = Moment-tensor',/5x, &
- 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
- 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
- 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
- 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
- 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x, &
- 'Mxx. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
- 'Mzz. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
- 'Mxz. . . . . . . . . . . . . . . . . . =',1pe20.10)
-
- end subroutine set_sources
Copied: seismo/2D/SPECFEM2D/trunk/setup/config.h.in (from rev 17978, seismo/2D/SPECFEM2D/trunk/config.h.in)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/setup/config.h.in (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/setup/config.h.in 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,44 @@
+/* config.h.in. Generated from configure.ac by autoheader. */
+
+/* Define to dummy `main' function (if any) required to link to the Fortran
+ libraries. */
+#undef FC_DUMMY_MAIN
+
+/* Define if F77 and FC dummy `main' functions are identical. */
+#undef FC_DUMMY_MAIN_EQ_F77
+
+/* Define to a macro mangling the given C identifier (in lower and upper
+ case), which must not contain underscores, for linking with Fortran. */
+#undef FC_FUNC
+
+/* As FC_FUNC, but for C identifiers containing underscores. */
+#undef FC_FUNC_
+
+/* Define to alternate name for `main' routine that is called from a `main' in
+ the Fortran libraries. */
+#undef FC_MAIN
+
+/* defined if Scotch is installed */
+#undef HAVE_SCOTCH
+
+/* Define to the address where bug reports for this package should be sent. */
+#undef PACKAGE_BUGREPORT
+
+/* Define to the full name of this package. */
+#undef PACKAGE_NAME
+
+/* Define to the full name and version of this package. */
+#undef PACKAGE_STRING
+
+/* Define to the one symbol short name of this package. */
+#undef PACKAGE_TARNAME
+
+/* Define to the home page for this package. */
+#undef PACKAGE_URL
+
+/* Define to the version of this package. */
+#undef PACKAGE_VERSION
+
+/* Define to 1 if `lex' declares `yytext' as a `char *' by default, not a
+ `char[]'. */
+#undef YYTEXT_POINTER
Copied: seismo/2D/SPECFEM2D/trunk/setup/constants.h.in (from rev 17978, seismo/2D/SPECFEM2D/trunk/constants.h.in)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/setup/constants.h.in (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/setup/constants.h.in 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,183 @@
+!=====================================================================
+!
+! S p e c f e m 2 D V e r s i o n 6 . 1
+!
+!=====================================================================
+
+! @configure_input@
+
+!
+! solver in single or double precision depending on the machine (4 or 8 bytes)
+!
+! ALSO CHANGE FILE precision_mpi.h ACCORDINGLY
+!
+ integer, parameter :: SIZE_REAL = 4
+ integer, parameter :: SIZE_DOUBLE = 8
+
+
+! set to SIZE_REAL to run in single precision
+! set to SIZE_DOUBLE to run in double precision (increases memory size by 2)
+!
+! DO CHANGE precision_mpi.h accordingly
+!
+ integer, parameter :: CUSTOM_REAL = @CUSTOM_REAL@
+
+!----------- parameters that can be changed by the user -----------
+
+! number of Gauss-Lobatto-Legendre (GLL) points (i.e., polynomial degree + 1)
+ integer, parameter :: NGLLX = 5
+! the code does NOT work if NGLLZ /= NGLLX because it then cannot handle a non-structured mesh
+! due to non matching polynomial degrees along common edges
+ integer, parameter :: NGLLZ = NGLLX
+
+! further reduce cache misses inner/outer in two passes in the case of an MPI simulation
+! this flag is ignored in the case of a serial simulation
+ logical, parameter :: FURTHER_REDUCE_CACHE_MISSES = .true.
+
+! for inverse Cuthill-McKee (1969) permutation
+ logical, parameter :: PERFORM_CUTHILL_MCKEE = .true.
+ logical, parameter :: INVERSE = .true.
+ logical, parameter :: FACE = .false.
+ integer, parameter :: NGNOD_QUADRANGLE = 4
+! perform classical or multi-level Cuthill-McKee ordering
+ logical, parameter :: CMcK_MULTI = .false.
+! maximum size if multi-level Cuthill-McKee ordering
+ integer, parameter :: LIMIT_MULTI_CUTHILL = 50
+
+! implement Cuthill-McKee or replace with identity permutation
+ logical, parameter :: ACTUALLY_IMPLEMENT_PERM_OUT = .false.
+ logical, parameter :: ACTUALLY_IMPLEMENT_PERM_INN = .false.
+ logical, parameter :: ACTUALLY_IMPLEMENT_PERM_WHOLE = .true.
+
+! add MPI barriers and suppress seismograms if we generate traces of the run for analysis with "ParaVer"
+ logical, parameter :: GENERATE_PARAVER_TRACES = .false.
+
+! option to display only part of the mesh and not the whole mesh,
+! for instance to analyze Cuthill-McKee mesh partitioning etc.
+! Possible values are:
+! 1: display all the elements (i.e., the whole mesh)
+! 2: display inner elements only
+! 3: display outer elements only
+! 4: display a fixed number of elements (in each partition) only
+ integer, parameter :: DISPLAY_SUBSET_OPTION = 1
+! number of spectral elements to display in each subset when a fixed subset size is used (option 4 above)
+ integer, parameter :: NSPEC_DISPLAY_SUBSET = 2300
+
+! use this t0 as earliest starting time rather than the automatically calculated one
+! (must be positive and bigger than the automatically one to be effective;
+! simulation will start at t = - t0)
+ double precision, parameter :: USER_T0 = 0.0d0
+
+!--- beginning of Nicolas Le Goff's constants for an unstructured CUBIT/METIS/SCOTCH mesh
+
+! maximum number of neighbors per element
+ integer, parameter :: MAX_NEIGHBORS = 40
+
+! maximum number of elements that can contain the same node
+ integer, parameter :: nsize = 40
+
+!--- end of Nicolas Le Goff's constants for an unstructured CUBIT/METIS/SCOTCH mesh
+
+! output file for energy
+ integer, parameter :: IOUT_ENERGY = 77
+
+! select fast (Paul Fischer) or slow (topology only) global numbering algorithm
+ logical, parameter :: FAST_NUMBERING = .true.
+
+! mesh tolerance for fast global numbering
+ double precision, parameter :: SMALLVALTOL = 0.00001d0
+
+! displacement threshold above which we consider the code became unstable
+ double precision, parameter :: STABILITY_THRESHOLD = 1.d+25
+
+! input and output files
+ integer, parameter :: IIN = 40
+ integer, parameter :: ISTANDARD_OUTPUT = 6
+! uncomment this to write to standard output
+ integer, parameter :: IOUT = ISTANDARD_OUTPUT
+! uncomment this to write to file instead
+! integer, parameter :: IOUT = 41
+
+! number of lines per source in SOURCE file
+ integer, parameter :: NLINES_PER_SOURCE = 13
+
+! flags for absorbing boundaries
+ integer, parameter :: IBOTTOM = 1
+ integer, parameter :: IRIGHT = 2
+ integer, parameter :: ITOP = 3
+ integer, parameter :: ILEFT = 4
+
+! number of edges and corners of each element
+ integer, parameter :: NEDGES = 4
+ integer, parameter :: NCORNERS = 4
+
+! a few useful constants
+ double precision, parameter :: ZERO = 0.d0,ONE = 1.d0
+ double precision, parameter :: HALF = 0.5d0,TWO = 2.d0,QUART = 0.25d0
+
+! pi
+ double precision, parameter :: PI = 3.141592653589793d0
+
+! 4/3
+ double precision, parameter :: FOUR_THIRDS = 4.d0/3.d0
+
+! 1/24
+ double precision, parameter :: ONE_OVER_24 = 1.d0 / 24.d0
+
+! parameters to define the Gauss-Lobatto-Legendre points
+ double precision, parameter :: GAUSSALPHA = ZERO,GAUSSBETA = ZERO
+
+! very large and very small values
+ double precision, parameter :: HUGEVAL = 1.d+30,TINYVAL = 1.d-9
+
+! number of spatial dimensions
+ integer, parameter :: NDIM = 2
+
+! maximum length of station and network name for receivers
+ integer, parameter :: MAX_LENGTH_STATION_NAME = 32
+ integer, parameter :: MAX_LENGTH_NETWORK_NAME = 8
+
+! number of iterations to solve the system for xi and eta
+ integer, parameter :: NUM_ITER = 4
+
+! we mimic a triangle of half duration equal to half_duration_triangle
+! using a Gaussian having a very close shape, as explained in Figure 4.2
+! of the manual. This source decay rate to mimic an equivalent triangle
+! was found by trial and error
+ double precision, parameter :: SOURCE_DECAY_MIMIC_TRIANGLE = 1.628d0
+
+! non linear display to enhance small amplitudes in color images
+ double precision, parameter :: POWER_DISPLAY_COLOR = 0.30d0
+
+! US letter paper or European A4
+ logical, parameter :: US_LETTER = .false.
+
+! X and Z axis origin of PostScript plot in centimeters
+ double precision, parameter :: ORIG_X = 2.4d0
+ double precision, parameter :: ORIG_Z = 2.9d0
+
+! dot to centimeter conversion for PostScript
+ double precision, parameter :: CENTIM = 28.5d0
+
+! parameters for arrows for PostScript snapshot
+ double precision, parameter :: ARROW_ANGLE = 20.d0
+ double precision, parameter :: ARROW_RATIO = 0.40d0
+
+! size of frame used for Postscript display in percentage of the size of the page
+ double precision, parameter :: RPERCENTX = 70.0d0,RPERCENTZ = 77.0d0
+
+! flag to indicate an isotropic elastic/acoustic material
+ integer, parameter :: ISOTROPIC_MATERIAL = 1
+
+! flag to indicate an anisotropic material
+ integer, parameter :: ANISOTROPIC_MATERIAL = 2
+
+! flag to indicate a poroelastic material
+ integer, parameter :: POROELASTIC_MATERIAL = 3
+
+! file number for interface file
+ integer, parameter :: IIN_INTERFACES = 15
+
+! ignore variable name field (junk) at the beginning of each input line
+ logical, parameter :: IGNORE_JUNK = .true.,DONT_IGNORE_JUNK = .false.
+
Copied: seismo/2D/SPECFEM2D/trunk/setup/precision_mpi.h.in (from rev 17978, seismo/2D/SPECFEM2D/trunk/precision_mpi.h.in)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/setup/precision_mpi.h.in (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/setup/precision_mpi.h.in 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,17 @@
+!=====================================================================
+!
+! S p e c f e m 2 D V e r s i o n 6 . 1
+!
+!=====================================================================
+
+! @configure_input@
+
+!
+! solver in single or double precision depending on the machine
+!
+! set to MPI_REAL to run in single precision
+! set to MPI_DOUBLE_PRECISION to run in double precision
+!
+! ALSO CHANGE FILE constants.h ACCORDINGLY
+!
+ integer, parameter :: CUSTOM_MPI_TYPE = @CUSTOM_MPI_TYPE@
Copied: seismo/2D/SPECFEM2D/trunk/setup/scotchf.h (from rev 17978, seismo/2D/SPECFEM2D/trunk/scotchf.h)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/setup/scotchf.h (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/setup/scotchf.h 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,14 @@
+ INTEGER SCOTCH_ARCHDIM
+ INTEGER SCOTCH_GEOMDIM
+ INTEGER SCOTCH_GRAPHDIM
+ INTEGER SCOTCH_MAPDIM
+ INTEGER SCOTCH_MESHDIM
+ INTEGER SCOTCH_ORDERDIM
+ INTEGER SCOTCH_STRATDIM
+ PARAMETER (SCOTCH_ARCHDIM = 4)
+ PARAMETER (SCOTCH_GEOMDIM = 2)
+ PARAMETER (SCOTCH_GRAPHDIM = 12)
+ PARAMETER (SCOTCH_MAPDIM = 10)
+ PARAMETER (SCOTCH_MESHDIM = 15)
+ PARAMETER (SCOTCH_ORDERDIM = 11)
+ PARAMETER (SCOTCH_STRATDIM = 1)
Deleted: seismo/2D/SPECFEM2D/trunk/setup_sources_receivers.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/setup_sources_receivers.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/setup_sources_receivers.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,170 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
- subroutine setup_sources_receivers(NSOURCES,initialfield,source_type,&
- coord,ibool,npoin,nspec,nelem_acoustic_surface,acoustic_surface,elastic,poroelastic, &
- x_source,z_source,ispec_selected_source,ispec_selected_rec, &
- is_proc_source,nb_proc_source,ipass,&
- sourcearray,Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,npgeo,&
- nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod, &
- nrec,nrecloc,recloc,which_proc_receiver,st_xval,st_zval, &
- xi_receiver,gamma_receiver,station_name,network_name,x_final_receiver,z_final_receiver,iglob_source)
-
- implicit none
-
- include "constants.h"
-
- logical :: initialfield
- integer :: NSOURCES
- integer :: npgeo,ngnod,myrank,ipass,nproc
- integer :: npoin,nspec,nelem_acoustic_surface
-
- ! Gauss-Lobatto-Legendre points
- double precision, dimension(NGLLX) :: xigll
- double precision, dimension(NGLLZ) :: zigll
-
- ! for receivers
- integer :: nrec,nrecloc
- integer, dimension(nrec) :: recloc, which_proc_receiver
- integer, dimension(nrec) :: ispec_selected_rec
- double precision, dimension(nrec) :: xi_receiver,gamma_receiver,st_xval,st_zval
- double precision, dimension(nrec) :: x_final_receiver, z_final_receiver
-
- ! timing information for the stations
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- ! for sources
- integer, dimension(NSOURCES) :: source_type
- integer, dimension(NSOURCES) :: ispec_selected_source,is_proc_source,nb_proc_source,iglob_source
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
- double precision, dimension(NSOURCES) :: x_source,z_source,xi_source,gamma_source,Mxx,Mzz,Mxz
-
- logical, dimension(nspec) :: elastic,poroelastic
- integer, dimension(ngnod,nspec) :: knods
- integer, dimension(5,nelem_acoustic_surface) :: acoustic_surface
- integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
- double precision, dimension(NDIM,npgeo) :: coorg
- double precision, dimension(NDIM,npoin) :: coord
-
- integer :: ixmin, ixmax, izmin, izmax
-
- ! Local variables
- integer i_source,ispec,ispec_acoustic_surface
-
- do i_source=1,NSOURCES
-
- if(source_type(i_source) == 1) then
-
- ! collocated force source
- call locate_source_force(ibool,coord,nspec,npoin,xigll,zigll,x_source(i_source),z_source(i_source), &
- ispec_selected_source(i_source),is_proc_source(i_source),nb_proc_source(i_source),&
- nproc,myrank,xi_source(i_source),gamma_source(i_source),coorg,knods,ngnod,npgeo,ipass,&
- iglob_source(i_source))
-
- ! check that acoustic source is not exactly on the free surface because pressure is zero there
- if(is_proc_source(i_source) == 1) then
- do ispec_acoustic_surface = 1,nelem_acoustic_surface
- ispec = acoustic_surface(1,ispec_acoustic_surface)
- ixmin = acoustic_surface(2,ispec_acoustic_surface)
- ixmax = acoustic_surface(3,ispec_acoustic_surface)
- izmin = acoustic_surface(4,ispec_acoustic_surface)
- izmax = acoustic_surface(5,ispec_acoustic_surface)
- if( .not. elastic(ispec) .and. .not. poroelastic(ispec) .and. &
- ispec == ispec_selected_source(i_source) ) then
- if ( (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==NGLLX .and. &
- gamma_source(i_source) < -0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==NGLLX .and. &
- gamma_source(i_source) > 0.99d0) .or.&
- (izmin==1 .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
- xi_source(i_source) < -0.99d0) .or.&
- (izmin==1 .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- xi_source(i_source) > 0.99d0) .or.&
- (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==1 .and. &
- gamma_source(i_source) < -0.99d0 .and. xi_source(i_source) < -0.99d0) .or.&
- (izmin==1 .and. izmax==1 .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- gamma_source(i_source) < -0.99d0 .and. xi_source(i_source) > 0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
- gamma_source(i_source) > 0.99d0 .and. xi_source(i_source) < -0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- gamma_source(i_source) > 0.99d0 .and. xi_source(i_source) > 0.99d0) ) then
- call exit_MPI('an acoustic source cannot be located exactly '// &
- 'on the free surface because pressure is zero there')
- endif
- endif
- enddo
- endif
-
- else if(source_type(i_source) == 2) then
- ! moment-tensor source
- call locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source(i_source),z_source(i_source), &
- ispec_selected_source(i_source),is_proc_source(i_source),nb_proc_source(i_source),&
- nproc,myrank,xi_source(i_source),gamma_source(i_source),coorg,knods,ngnod,npgeo,ipass)
-
- ! compute source array for moment-tensor source
- call compute_arrays_source(ispec_selected_source(i_source),xi_source(i_source),gamma_source(i_source),&
- sourcearray(i_source,:,:,:), &
- Mxx(i_source),Mzz(i_source),Mxz(i_source),xix,xiz,gammax,gammaz,xigll,zigll,nspec)
-
- else if(.not.initialfield) then
-
- call exit_MPI('incorrect source type')
-
- endif
-
- enddo ! do i_source=1,NSOURCES
-
- ! locate receivers in the mesh
- call locate_receivers(ibool,coord,nspec,npoin,xigll,zigll, &
- nrec,nrecloc,recloc,which_proc_receiver,nproc,myrank, &
- st_xval,st_zval,ispec_selected_rec, &
- xi_receiver,gamma_receiver,station_name,network_name, &
- x_source(1),z_source(1), &
- coorg,knods,ngnod,npgeo,ipass, &
- x_final_receiver,z_final_receiver)
-
- end subroutine setup_sources_receivers
-
Deleted: seismo/2D/SPECFEM2D/trunk/sort_array_coordinates.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/sort_array_coordinates.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/sort_array_coordinates.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,241 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-
-#ifdef USE_MPI
-
-! subroutines to sort MPI buffers to assemble between chunks
-
- subroutine sort_array_coordinates(npointot,x,z,ibool,iglob,loc,ifseg, &
- nglob,ind,ninseg,iwork,work)
-
-! this routine MUST be in double precision to avoid sensitivity
-! to roundoff errors in the coordinates of the points
-!
-! returns: sorted indexing array (ibool), reordering array (iglob) & number of global points (nglob)
-
- implicit none
-
- include "constants.h"
-
- integer,intent(in) :: npointot
- integer,intent(out) :: nglob
-
- integer,intent(inout) :: ibool(npointot)
-
- integer iglob(npointot),loc(npointot)
- integer ind(npointot),ninseg(npointot)
- logical ifseg(npointot)
- double precision,intent(in) :: x(npointot),z(npointot)
- integer iwork(npointot)
- double precision work(npointot)
-
- ! local parameters
- integer ipoin,i,j
- integer nseg,ioff,iseg,ig
- ! define a tolerance, normalized radius is 1., so let's use a small value
- double precision,parameter :: xtol = SMALLVALTOL
-
- ! establish initial pointers
- do ipoin=1,npointot
- loc(ipoin)=ipoin
- enddo
-
- ifseg(:)=.false.
-
- nseg=1
- ifseg(1)=.true.
- ninseg(1)=npointot
-
- do j=1,NDIM
-
- ! sort within each segment
- ioff=1
- do iseg=1,nseg
-
- if(j == 1) then
- call rank_buffers(x(ioff),ind,ninseg(iseg))
- else if(j == 2) then
- call rank_buffers(z(ioff),ind,ninseg(iseg))
- endif
-
- call swap_all_buffers(ibool(ioff),loc(ioff), &
- x(ioff),z(ioff),iwork,work,ind,ninseg(iseg))
-
- ioff=ioff+ninseg(iseg)
- enddo
-
- ! check for jumps in current coordinate
- if(j == 1) then
- do i=2,npointot
- if(dabs(x(i)-x(i-1)) > xtol) ifseg(i)=.true.
- enddo
- else if(j == 2) then
- do i=2,npointot
- if(dabs(z(i)-z(i-1)) > xtol) ifseg(i)=.true.
- enddo
- endif
-
- ! count up number of different segments
- nseg=0
- do i=1,npointot
- if(ifseg(i)) then
- nseg=nseg+1
- ninseg(nseg)=1
- else
- ninseg(nseg)=ninseg(nseg)+1
- endif
- enddo
- enddo
-
- ! assign global node numbers (now sorted lexicographically)
- ig=0
- do i=1,npointot
- if(ifseg(i)) ig=ig+1
- iglob(loc(i))=ig
- enddo
-
- nglob=ig
-
- end subroutine sort_array_coordinates
-
-! -------------------- library for sorting routine ------------------
-
-! sorting routines put here in same file to allow for inlining
-
- subroutine rank_buffers(A,IND,N)
-!
-! Use Heap Sort (Numerical Recipes)
-!
- implicit none
-
- integer n
- double precision A(n)
- integer IND(n)
-
- integer i,j,l,ir,indx
- double precision q
-
- do j=1,n
- IND(j)=j
- enddo
-
- if(n == 1) return
-
- L=n/2+1
- ir=n
- 100 CONTINUE
- IF(l>1) THEN
- l=l-1
- indx=ind(l)
- q=a(indx)
- ELSE
- indx=ind(ir)
- q=a(indx)
- ind(ir)=ind(1)
- ir=ir-1
- if (ir == 1) then
- ind(1)=indx
- return
- endif
- ENDIF
- i=l
- j=l+l
- 200 CONTINUE
- IF(J <= IR) THEN
- IF(J < IR) THEN
- IF(A(IND(j)) < A(IND(j+1))) j=j+1
- ENDIF
- IF (q < A(IND(j))) THEN
- IND(I)=IND(J)
- I=J
- J=J+J
- ELSE
- J=IR+1
- ENDIF
- goto 200
- ENDIF
- IND(I)=INDX
- goto 100
- end subroutine rank_buffers
-
-! -------------------------------------------------------------------
-
- subroutine swap_all_buffers(IA,IB,A,B,IW,W,ind,n)
-!
-! swap arrays IA, IB, A and B according to addressing in array IND
-!
- implicit none
-
- integer n
-
- integer IND(n)
- integer IA(n),IB(n),IW(n)
- double precision A(n),B(n),W(n)
-
- integer i
-
- do i=1,n
- W(i)=A(i)
- IW(i)=IA(i)
- enddo
-
- do i=1,n
- A(i)=W(ind(i))
- IA(i)=IW(ind(i))
- enddo
-
- do i=1,n
- W(i)=B(i)
- IW(i)=IB(i)
- enddo
-
- do i=1,n
- B(i)=W(ind(i))
- IB(i)=IW(ind(i))
- enddo
-
- end subroutine swap_all_buffers
-
-#endif
Deleted: seismo/2D/SPECFEM2D/trunk/specfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/specfem2D.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/specfem2D.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,6863 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-!====================================================================================
-!
-! An explicit 2D parallel MPI spectral element solver
-! for the anelastic anisotropic or poroelastic wave equation.
-!
-!====================================================================================
-
-! If you use this code for your own research, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{VaCaSaKoVi99,
-! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
-! D. Komatitsch and J. P. Vilotte},
-! title = {Elastic wave propagation in an irregularly layered medium},
-! journal = {Soil Dynamics and Earthquake Engineering},
-! year = {1999},
-! volume = {18},
-! pages = {11-18},
-! number = {1},
-! doi = {10.1016/S0267-7261(98)00027-X}}
-!
-! @ARTICLE{LeChKoHuTr09,
-! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
-! Shouh Huang and Jeroen Tromp},
-! title = {Effects of realistic surface topography on seismic ground motion
-! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
-! method and {LiDAR DTM}},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {681-693},
-! number = {2A},
-! doi = {10.1785/0120080264}}
-!
-! @ARTICLE{LeChLiKoHuTr08,
-! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
-! and Bor Shouh Huang and Jeroen Tromp},
-! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
-! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2008},
-! volume = {98},
-! pages = {253-264},
-! number = {1},
-! doi = {10.1785/0120070033}}
-!
-! @ARTICLE{LeKoHuTr09,
-! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
-! title = {Effects of topography on seismic wave propagation: An example from
-! northern {T}aiwan},
-! journal = {Bull. Seismol. Soc. Am.},
-! year = {2009},
-! volume = {99},
-! pages = {314-325},
-! number = {1},
-! doi = {10.1785/0120080020}}
-!
-! @ARTICLE{KoErGoMi10,
-! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
-! David Mich\'ea},
-! title = {High-order finite-element seismic wave propagation modeling with
-! {MPI} on a large {GPU} cluster},
-! journal = {J. Comput. Phys.},
-! year = {2010},
-! volume = {229},
-! pages = {7692-7714},
-! number = {20},
-! doi = {10.1016/j.jcp.2010.06.024}}
-!
-! @ARTICLE{KoGoErMi10,
-! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
-! David Mich\'ea},
-! title = {Modeling the propagation of elastic waves using spectral elements
-! on a cluster of 192 {GPU}s},
-! journal = {Computer Science Research and Development},
-! year = {2010},
-! volume = {25},
-! pages = {75-82},
-! number = {1-2},
-! doi = {10.1007/s00450-010-0109-1}}
-!
-! @ARTICLE{KoMiEr09,
-! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
-! title = {Porting a high-order finite-element earthquake modeling application
-! to {NVIDIA} graphics cards using {CUDA}},
-! journal = {Journal of Parallel and Distributed Computing},
-! year = {2009},
-! volume = {69},
-! pages = {451-460},
-! number = {5},
-! doi = {10.1016/j.jpdc.2009.01.006}}
-!
-! @ARTICLE{LiPoKoTr04,
-! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
-! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
-! journal={Bull. Seismol. Soc. Am.},
-! year = {2004},
-! volume = {94},
-! pages = {1748-1761},
-! number = {5},
-! doi = {10.1785/012004038}}
-!
-! @INCOLLECTION{ChKoViCaVaFe07,
-! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
-! Yann Capdeville and Bernard Valette and Gaetano Festa},
-! title = {Spectral Element Analysis in Seismology},
-! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
-! publisher = {Elsevier - Academic Press},
-! year = {2007},
-! editor = {Ru-Shan Wu and Val\'erie Maupin},
-! volume = {48},
-! series = {Advances in Geophysics},
-! pages = {365-419}}
-!
-! @ARTICLE{KoVi98,
-! author={D. Komatitsch and J. P. Vilotte},
-! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
-! journal={Bull. Seismol. Soc. Am.},
-! year=1998,
-! volume=88,
-! number=2,
-! pages={368-392}}
-!
-! @ARTICLE{KoTr99,
-! author={D. Komatitsch and J. Tromp},
-! year=1999,
-! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
-! journal={Geophys. J. Int.},
-! volume=139,
-! number=3,
-! pages={806-822},
-! doi={10.1046/j.1365-246x.1999.00967.x}}
-!
-! @ARTICLE{KoLiTrSuStSh04,
-! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
-! and Christiane Stidham and John H. Shaw},
-! year=2004,
-! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
-! based upon the Spectral-Element Method},
-! journal={Bull. Seism. Soc. Am.},
-! volume=94,
-! number=1,
-! pages={187-206}}
-!
-! @ARTICLE{MoTr08,
-! author={C. Morency and J. Tromp},
-! title={Spectral-element simulations of wave propagation in poroelastic media},
-! journal={Geophys. J. Int.},
-! year=2008,
-! volume=175,
-! pages={301-345}}
-!
-! and/or other articles from http://web.univ-pau.fr/~dkomati1/publications.html
-!
-! If you use the kernel capabilities of the code, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{LiTr06,
-! author={Qinya Liu and Jeroen Tromp},
-! title={Finite-frequency kernels based on adjoint methods},
-! journal={Bull. Seismol. Soc. Am.},
-! year=2006,
-! volume=96,
-! number=6,
-! pages={2383-2397},
-! doi={10.1785/0120060041}}
-!
-! @ARTICLE{MoLuTr09,
-! author={C. Morency and Y. Luo and J. Tromp},
-! title={Finite-frequency kernels for wave propagation in porous media based upon adjoint methods},
-! year=2009,
-! journal={Geophys. J. Int.},
-! doi={10.1111/j.1365-246X.2009.04332}}
-!
-! If you use the METIS / SCOTCH / CUBIT non-structured capabilities, please also cite:
-!
-! @ARTICLE{MaKoBlLe08,
-! author = {R. Martin and D. Komatitsch and C. Blitz and N. {Le Goff}},
-! title = {Simulation of seismic wave propagation in an asteroid based upon
-! an unstructured {MPI} spectral-element method: blocking and non-blocking
-! communication strategies},
-! journal = {Lecture Notes in Computer Science},
-! year = {2008},
-! volume = {5336},
-! pages = {350-363}}
-!
-! version 6.1, Christina Morency and Pieyre Le Loher, March 2010:
-! - added SH (membrane) waves calculation for elastic media
-! - added support for external fully anisotropic media
-! - fixed some bugs in acoustic kernels
-!
-! version 6.0, Christina Morency and Yang Luo, August 2009:
-! - support for poroelastic media
-! - adjoint method for acoustic/elastic/poroelastic
-!
-! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, February 2008:
-! - support for CUBIT and GiD meshes
-! - MPI implementation of the code based on domain decomposition
-! with METIS or SCOTCH
-! - general fluid/solid implementation with any number, shape and orientation of
-! matching edges
-! - fluid potential of density * displacement instead of displacement
-! - absorbing edges with any normal vector
-! - general numbering of absorbing and acoustic free surface edges
-! - cleaned implementation of attenuation as in Carcione (1993)
-! - merged loops in the solver for efficiency
-! - simplified input of external model
-! - added CPU time information
-! - translated many comments from French to English
-!
-! version 5.1, Dimitri Komatitsch, January 2005:
-! - more general mesher with any number of curved layers
-! - Dirac and Gaussian time sources and corresponding convolution routine
-! - option for acoustic medium instead of elastic
-! - receivers at any location, not only grid points
-! - moment-tensor source at any location, not only a grid point
-! - color snapshots
-! - more flexible DATA/Par_file with any number of comment lines
-! - Xsu scripts for seismograms
-! - subtract t0 from seismograms
-! - seismograms and snapshots in pressure in addition to vector field
-!
-! version 5.0, Dimitri Komatitsch, May 2004:
-! - got rid of useless routines, suppressed commons etc.
-! - weak formulation based explicitly on stress tensor
-! - implementation of full anisotropy
-! - implementation of attenuation based on memory variables
-!
-! based on SPECFEM2D version 4.2, June 1998
-! (c) by Dimitri Komatitsch, Harvard University, USA
-! and Jean-Pierre Vilotte, Institut de Physique du Globe de Paris, France
-!
-! itself based on SPECFEM2D version 1.0, 1995
-! (c) by Dimitri Komatitsch and Jean-Pierre Vilotte,
-! Institut de Physique du Globe de Paris, France
-!
-
-! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
-! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
-! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
-! This permits acoustic-elastic coupling based on a non-iterative time scheme.
-! Displacement is then: u = grad(Chi) / rho
-! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
-! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
-! The source in an acoustic element is a pressure source.
-! First-order acoustic-acoustic discontinuities are also handled automatically
-! because pressure is continuous at such an interface, therefore Chi_dot_dot
-! is continuous, therefore Chi is also continuous, which is consistent with
-! the spectral-element basis functions and with the assembling process.
-! This is the reason why a simple displacement potential u = grad(Chi) would
-! not work because it would be discontinuous at such an interface and would
-! therefore not be consistent with the basis functions.
-
- program specfem2D
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
-! character(len=80) datlin
-
- integer NSOURCES,i_source
- integer, dimension(:), allocatable :: source_type,time_function_type
- double precision, dimension(:), allocatable :: x_source,z_source,xi_source,gamma_source,&
- Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: sourcearray
- double precision :: t0
-
- double precision, dimension(:,:), allocatable :: coorg
-
-! for P-SV or SH (membrane) waves calculation
- logical :: p_sv
-
-! receiver information
- integer :: nrec,ios
- integer, dimension(:), allocatable :: ispec_selected_rec
- double precision, dimension(:), allocatable :: xi_receiver,gamma_receiver,st_xval,st_zval
- character(len=150) dummystring
-
-! for seismograms
- double precision, dimension(:,:), allocatable :: sisux,sisuz,siscurl
- integer :: seismo_offset, seismo_current
-
-! vector field in an element
- real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
-
-! pressure in an element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
-
-! curl in an element
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
-
- integer :: i,j,k,it,irec,id,n,ispec,npoin,npgeo,iglob
- integer :: npoin_acoustic
- integer :: npoin_elastic
- integer :: npoin_poroelastic
- logical :: anyabs
- double precision :: dxd,dyd,dzd,dcurld,valux,valuy,valuz,valcurl,hlagrange,rhol,xi,gamma,x,z
-
-! coefficients of the explicit Newmark time scheme
- integer NSTEP
- double precision :: deltatover2,deltatsquareover2,time
- double precision :: deltat
-
-! Gauss-Lobatto-Legendre points and weights
- double precision, dimension(NGLLX) :: xigll
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
- double precision, dimension(NGLLZ) :: zigll
- real(kind=CUSTOM_REAL), dimension(NGLLX) :: wzgll
-
-! derivatives of Lagrange polynomials
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-
-! Jacobian matrix and determinant
- double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the elastic medium
- double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal
-
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_elastic,veloc_elastic,displ_elastic
- double precision, dimension(:,:), allocatable :: &
- coord, flagrange,xinterp,zinterp,Uxinterp,Uzinterp,vector_field_display
-
-! material properties of the poroelastic medium (solid phase:s and fluid phase [defined as w=phi(u_f-u_s)]: w)
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- accels_poroelastic,velocs_poroelastic,displs_poroelastic
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- accelw_poroelastic,velocw_poroelastic,displw_poroelastic
- double precision, dimension(:), allocatable :: porosity,tortuosity
- double precision, dimension(:,:), allocatable :: density,permeability
-
-! poroelastic and elastic coefficients
- double precision, dimension(:,:,:), allocatable :: poroelastcoef
-
-! anisotropy parameters
- logical :: all_anisotropic
- double precision :: c11,c13,c15,c33,c35,c55
- logical, dimension(:), allocatable :: anisotropic
- double precision, dimension(:,:), allocatable :: anisotropy
-
-! for acoustic medium
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
- potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
-
-! inverse mass matrices
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_inverse_elastic
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_inverse_acoustic
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
- rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
-
-! to evaluate cpI, cpII, and cs, and rI (poroelastic medium)
- real(kind=CUSTOM_REAL) :: rhol_s,rhol_f,rhol_bar,phil,tortl
- real(kind=CUSTOM_REAL) :: mul_s,kappal_s
- real(kind=CUSTOM_REAL) :: kappal_f
- real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr
- real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,B_biot,cpIsquare,cpIIsquare,cssquare
- real(kind=CUSTOM_REAL) :: ratio,dd1
-
- double precision, dimension(:,:,:), allocatable :: vpext,vsext,rhoext
- double precision, dimension(:,:,:), allocatable :: Qp_attenuationext,Qs_attenuationext
- double precision, dimension(:,:,:), allocatable :: c11ext,c13ext,c15ext,c33ext,c35ext,c55ext
-
- double precision, dimension(:,:,:), allocatable :: shape2D,shape2D_display
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: xix,xiz,gammax,gammaz,jacobian
-
- double precision, dimension(:,:,:,:), allocatable :: dershape2D,dershape2D_display
-
- integer, dimension(:,:,:), allocatable :: ibool,ibool_outer,ibool_inner
- integer, dimension(:,:), allocatable :: knods
- integer, dimension(:), allocatable :: kmato,numabs, &
- ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
-
- integer, dimension(:), allocatable :: ispec_selected_source,iglob_source,&
- is_proc_source,nb_proc_source
- double precision, dimension(:), allocatable :: aval
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: source_time_function
- double precision, external :: netlib_specfun_erf
-
- double precision :: vpImin,vpImax,vpIImin,vpIImax
-
- integer :: colors,numbers,subsamp,imagetype, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NTSTEP_BETWEEN_OUTPUT_SEISMO,seismotype
- integer :: numat,ngnod,nspec,pointsdisp, &
- nelemabs,nelem_acoustic_surface,ispecabs,UPPER_LIMIT_DISPLAY
-
- logical interpol,meshvect,modelvect,boundvect,assign_external_model,initialfield, &
- outputgrid,gnuplot,TURN_ATTENUATION_ON,output_postscript_snapshot,output_color_image, &
- plot_lowerleft_corner_only,add_Bielak_conditions,OUTPUT_ENERGY,READ_EXTERNAL_SEP_FILE
-
- double precision :: cutsnaps,sizemax_arrows,anglerec,xirec,gammarec
-
-! for absorbing and acoustic free surface conditions
- integer :: ispec_acoustic_surface,inum
- real(kind=CUSTOM_REAL) :: nx,nz,weight,xxi,zgamma
-
- logical, dimension(:,:), allocatable :: codeabs
-
-! for attenuation
- integer :: N_SLS
- double precision, dimension(:), allocatable :: Qp_attenuation
- double precision, dimension(:), allocatable :: Qs_attenuation
- double precision :: f0_attenuation
- integer nspec_allocate
- double precision :: deltatsquare,deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: e1,e11,e13
- double precision, dimension(:,:,:,:), allocatable :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
- double precision, dimension(:), allocatable :: inv_tau_sigma_nu1_sent,phi_nu1_sent,inv_tau_sigma_nu2_sent,phi_nu2_sent
- double precision, dimension(:,:,:) , allocatable :: Mu_nu1,Mu_nu2
- double precision :: Mu_nu1_sent,Mu_nu2_sent
-
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
- dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
-
-! for viscous attenuation
- double precision, dimension(:,:,:), allocatable :: &
- rx_viscous,rz_viscous,viscox,viscoz
- double precision :: theta_e,theta_s
- double precision :: Q0,freq0
- double precision :: alphaval,betaval,gammaval,thetainv
- logical :: TURN_VISCATTENUATION_ON
- double precision, dimension(NGLLX,NGLLZ) :: viscox_loc,viscoz_loc
- double precision :: Sn,Snp1,etal_f
- double precision, dimension(3):: bl_relaxed
- double precision :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
-! adjoint
- double precision, dimension(:), allocatable :: b_viscodampx,b_viscodampz
- integer reclen
-
-! for fluid/solid coupling and edge detection
- logical, dimension(:), allocatable :: elastic
- integer, dimension(NEDGES) :: i_begin,j_begin,i_end,j_end
- integer, dimension(NGLLX,NEDGES) :: ivalue,jvalue,ivalue_inverse,jvalue_inverse
- integer, dimension(:), allocatable :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge, &
- fluid_solid_elastic_ispec,fluid_solid_elastic_iedge
- integer :: num_fluid_solid_edges,ispec_acoustic,ispec_elastic, &
- iedge_acoustic,iedge_elastic,ipoin1D,iglob2
- logical :: any_acoustic,any_acoustic_glob,any_elastic,any_elastic_glob,coupled_acoustic_elastic
- real(kind=CUSTOM_REAL) :: displ_x,displ_z,displ_n,displw_x,displw_z,zxi,xgamma,jacobian1D,pressure
- real(kind=CUSTOM_REAL) :: b_displ_x,b_displ_z,b_displw_x,b_displw_z,b_pressure
- logical :: any_fluid_solid_edges
-
-! for fluid/porous medium coupling and edge detection
- logical, dimension(:), allocatable :: poroelastic
- logical :: any_poroelastic,any_poroelastic_glob
- integer, dimension(:), allocatable :: fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge, &
- fluid_poro_poroelastic_ispec,fluid_poro_poroelastic_iedge
- integer :: num_fluid_poro_edges,iedge_poroelastic
- logical :: coupled_acoustic_poro
- double precision :: mul_G,lambdal_G,lambdalplus2mul_G
- double precision :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
- double precision :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
- double precision :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- double precision :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
- double precision :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
- double precision :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
- double precision :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
- double precision :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
- logical :: any_fluid_poro_edges
-
-! for solid/porous medium coupling and edge detection
- integer, dimension(:), allocatable :: solid_poro_elastic_ispec,solid_poro_elastic_iedge, &
- solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge
- integer :: num_solid_poro_edges,ispec_poroelastic,ii2,jj2
- logical :: coupled_elastic_poro
- integer, dimension(:), allocatable :: icount
- double precision :: sigma_xx,sigma_xz,sigma_zz,sigmap
- double precision :: b_sigma_xx,b_sigma_xz,b_sigma_zz,b_sigmap
- integer, dimension(:), allocatable :: ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,&
- iend_top_poro,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro
- logical :: any_solid_poro_edges
-
-! for adjoint method
- logical :: SAVE_FORWARD ! whether or not the last frame is saved to reconstruct the forward field
- integer :: SIMULATION_TYPE ! 1 = forward wavefield, 2 = backward and adjoint wavefields and kernels
- double precision :: b_deltatover2,b_deltatsquareover2,b_deltat ! coefficients of the explicit Newmark time scheme
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accels_poroelastic,b_velocs_poroelastic,b_displs_poroelastic
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accelw_poroelastic,b_velocw_poroelastic,b_displw_poroelastic
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accel_elastic,b_veloc_elastic,b_displ_elastic
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_potential_dot_dot_acoustic,b_potential_dot_acoustic,b_potential_acoustic
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_ac,b_displ_ac,b_accel_ac
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rho_kl, mu_kl, kappa_kl
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_global, mul_global, kappal_global
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: mu_k, kappa_k,rho_k
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhop_kl, beta_kl, alpha_kl
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rho_ac_kl, kappa_ac_kl
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_ac_global, kappal_ac_global
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhop_ac_kl, alpha_ac_kl
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhot_kl, rhof_kl, sm_kl, eta_kl, mufr_kl, B_kl, &
- C_kl, M_kl, rhob_kl, rhofb_kl, phi_kl, Bb_kl, Cb_kl, Mb_kl, mufrb_kl, &
- rhobb_kl, rhofbb_kl, phib_kl, cpI_kl, cpII_kl, cs_kl, ratio_kl
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhot_k, rhof_k, sm_k, eta_k, mufr_k, B_k, &
- C_k, M_k
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: phil_global,etal_f_global,rhol_s_global,rhol_f_global,rhol_bar_global, &
- tortl_global,mulfr_global
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: permlxx_global,permlxz_global,permlzz_global
- character(len=150) :: adj_source_file
- integer :: irec_local,nadj_rec_local
- double precision :: xx,zz,rholb,tempx1l,tempx2l,b_tempx1l,b_tempx2l,bb_tempx1l,bb_tempx2l
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: adj_sourcearray
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearrays
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_left,b_absorb_poro_s_left,b_absorb_poro_w_left
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_right,b_absorb_poro_s_right,b_absorb_poro_w_right
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_bottom,b_absorb_poro_s_bottom,b_absorb_poro_w_bottom
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_top,b_absorb_poro_s_top,b_absorb_poro_w_top
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_absorb_acoustic_left,b_absorb_acoustic_right,&
- b_absorb_acoustic_bottom, b_absorb_acoustic_top
- integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
- integer, dimension(:), allocatable :: ib_left,ib_right,ib_bottom,ib_top
-
-! for color images
- integer :: NX_IMAGE_color,NZ_IMAGE_color
- double precision :: xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image
- integer, dimension(:,:), allocatable :: iglob_image_color,copy_iglob_image_color
- double precision, dimension(:,:), allocatable :: image_color_data
- double precision, dimension(:,:), allocatable :: image_color_vp_display
- integer :: nb_pixel_loc
- integer, dimension(:), allocatable :: num_pixel_loc
-
-#ifdef USE_MPI
- integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
- integer, dimension(:), allocatable :: nb_pixel_per_proc
- integer, dimension(:,:), allocatable :: num_pixel_recv
- double precision, dimension(:), allocatable :: data_pixel_recv
- double precision, dimension(:), allocatable :: data_pixel_send
-#endif
-
-! timing information for the stations
- character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
-
-! title of the plot
- character(len=60) simulation_title
-
-! Lagrange interpolators at receivers
- double precision, dimension(:), allocatable :: hxir,hgammar,hpxir,hpgammar
- double precision, dimension(:,:), allocatable :: hxir_store,hgammar_store
-
-! Lagrange interpolators at sources
- double precision, dimension(:), allocatable :: hxis,hgammas,hpxis,hpgammas
- double precision, dimension(:,:), allocatable :: hxis_store,hgammas_store
-
-! for Lagrange interpolants
- double precision, external :: hgll
-
-! timer to count elapsed time
- double precision :: time_start
- integer :: year_start,month_start
-
- ! to determine date and time at which the run will finish
- character(len=8) datein
- character(len=10) timein
- character(len=5) :: zone
- integer, dimension(8) :: time_values
-
-! for MPI and partitioning
- integer :: ier
- integer :: nproc
- integer :: myrank
- character(len=150) :: outputname,outputname2
-
- integer :: ninterface
- integer :: max_interface_size
- integer, dimension(:), allocatable :: my_neighbours
- integer, dimension(:), allocatable :: my_nelmnts_neighbours
- integer, dimension(:,:,:), allocatable :: my_interfaces
- integer, dimension(:,:), allocatable :: ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
- integer, dimension(:), allocatable :: nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
-
- integer :: ninterface_acoustic, ninterface_elastic,ninterface_poroelastic
- integer, dimension(:), allocatable :: inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
-
-#ifdef USE_MPI
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_ac
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_ac
- integer, dimension(:), allocatable :: tab_requests_send_recv_acoustic
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_el
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_el
- integer, dimension(:), allocatable :: tab_requests_send_recv_elastic
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_pos,buffer_send_faces_vector_pow
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow
- integer, dimension(:), allocatable :: tab_requests_send_recv_poro
- integer :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, max_ibool_interfaces_size_po
- integer :: iproc
-#endif
-
-! for overlapping MPI communications with computation
- integer :: nspec_outer, nspec_inner, num_ispec_outer, num_ispec_inner
- integer, dimension(:), allocatable :: ispec_outer_to_glob, ispec_inner_to_glob
- logical, dimension(:), allocatable :: mask_ispec_inner_outer
-
- integer, dimension(:,:), allocatable :: acoustic_surface
- integer, dimension(:,:), allocatable :: acoustic_edges
- logical :: any_acoustic_edges
-
- integer :: ixmin, ixmax, izmin, izmax
-
- integer :: nrecloc, irecloc
- integer, dimension(:), allocatable :: recloc, which_proc_receiver
-
-! mask to sort ibool
- integer, dimension(:), allocatable :: mask_ibool
- integer, dimension(:,:,:), allocatable :: copy_ibool_ori
- integer :: inumber
-
-! to compute analytical initial plane wave field
- double precision :: angleforce_refl, c_inc, c_refl, cploc, csloc
- double precision, dimension(2) :: A_plane, B_plane, C_plane
- double precision :: z0_source, x0_source, time_offset
-
-! beyond critical angle
- integer , dimension(:), allocatable :: left_bound,right_bound,bot_bound
- double precision , dimension(:,:), allocatable :: v0x_left,v0z_left,v0x_right,v0z_right,v0x_bot,v0z_bot
- double precision , dimension(:,:), allocatable :: t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_paco,veloc_paco,displ_paco
- integer count_left,count_right,count_bottom
- logical :: over_critical_angle
-
-! further reduce cache misses inner/outer in two passes in the case of an MPI simulation
- integer :: ipass,ispec_inner,ispec_outer,NUMBER_OF_PASSES
- integer :: npoin_outer,npoin_inner
- integer, dimension(:), allocatable :: perm,antecedent_list,check_perm
-
-! arrays for plotpost
- integer :: d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
- d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
- d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
- d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model
- double precision, dimension(:,:), allocatable :: coorg_send_ps_velocity_model
- double precision, dimension(:,:), allocatable :: coorg_recv_ps_velocity_model
- double precision, dimension(:,:), allocatable :: RGB_send_ps_velocity_model
- double precision, dimension(:,:), allocatable :: RGB_recv_ps_velocity_model
- integer :: d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
- d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
- d1_color_send_ps_element_mesh, &
- d1_color_recv_ps_element_mesh
- double precision, dimension(:,:), allocatable :: coorg_send_ps_element_mesh
- double precision, dimension(:,:), allocatable :: coorg_recv_ps_element_mesh
- integer, dimension(:), allocatable :: color_send_ps_element_mesh
- integer, dimension(:), allocatable :: color_recv_ps_element_mesh
- integer :: d1_coorg_send_ps_abs, d2_coorg_send_ps_abs, &
- d1_coorg_recv_ps_abs, d2_coorg_recv_ps_abs
- double precision, dimension(:,:), allocatable :: coorg_send_ps_abs
- double precision, dimension(:,:), allocatable :: coorg_recv_ps_abs
- integer :: d1_coorg_send_ps_free_surface, d2_coorg_send_ps_free_surface, &
- d1_coorg_recv_ps_free_surface, d2_coorg_recv_ps_free_surface
- double precision, dimension(:,:), allocatable :: coorg_send_ps_free_surface
- double precision, dimension(:,:), allocatable :: coorg_recv_ps_free_surface
- integer :: d1_coorg_send_ps_vector_field, d2_coorg_send_ps_vector_field, &
- d1_coorg_recv_ps_vector_field, d2_coorg_recv_ps_vector_field
- double precision, dimension(:,:), allocatable :: coorg_send_ps_vector_field
- double precision, dimension(:,:), allocatable :: coorg_recv_ps_vector_field
-
-! tangential detection
- double precision, dimension(:), allocatable :: anglerec_irec
- double precision, dimension(:), allocatable :: cosrot_irec, sinrot_irec
- double precision, dimension(:), allocatable :: x_final_receiver, z_final_receiver
- logical :: force_normal_to_surface,rec_normal_to_surface
-
- integer, dimension(:), allocatable :: source_courbe_eros
-
- integer :: nnodes_tangential_curve
- double precision, dimension(:,:), allocatable :: nodes_tangential_curve
- logical :: any_tangential_curve
-
- integer :: n1_tangential_detection_curve
- integer, dimension(4) :: n_tangential_detection_curve
- integer, dimension(:), allocatable :: rec_tangential_detection_curve
- double precision :: distmin, dist_current, angleforce_recv
- double precision, dimension(:), allocatable :: dist_tangential_detection_curve
- double precision :: x_final_receiver_dummy, z_final_receiver_dummy
-!!!!!!!!!!
- double precision, dimension(:,:,:),allocatable:: rho_local,vp_local,vs_local
-!!!! hessian
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhorho_el_hessian_final1, rhorho_el_hessian_final2
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhorho_el_hessian_temp1, rhorho_el_hessian_temp2
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhorho_ac_hessian_final1, rhorho_ac_hessian_final2
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: weight_line_x, weight_line_z, weight_surface,weight_jacobian
- integer, dimension(:), allocatable :: weight_gll
- real(kind=CUSTOM_REAL) :: zmin_yang, zmax_yang, xmin_yang, xmax_yang
-
-! to help locate elements with a negative Jacobian using OpenDX
- logical :: found_a_negative_jacobian
-
-!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
- logical, parameter :: ADD_PERIODIC_CONDITIONS = .false.
-
-!! DK DK the periodic conditions below are currently specific to a Gmsh model designed by Paul Cristini
-
-!! DK DK the horizontal periodicity distance is:
- double precision, parameter :: PERIODIC_horiz_dist = 0.3597d0
-
-!! DK DK the length of an edge is about 1d-003, thus use e.g. 1/300 of that
- double precision, parameter :: PERIODIC_DETECT_TOL = 1d-003 / 300.d0
-
- integer, parameter :: NSPEC_PERIO = 670 / 2 ! 414 / 2
-
- integer, dimension(NSPEC_PERIO) :: numperio_left
- integer, dimension(NSPEC_PERIO) :: numperio_right
-
- logical, dimension(4,NSPEC_PERIO) :: codeabs_perio_left
- logical, dimension(4,NSPEC_PERIO) :: codeabs_perio_right
-
- integer :: idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
- integer :: ispecperio, ispecperio2, ispec2, i2, j2
- integer :: iglob_target_to_replace, ispec3, i3, j3
-
-!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
-
-!***********************************************************************
-!
-! i n i t i a l i z a t i o n p h a s e
-!
-!***********************************************************************
- call initialize_simulation(nproc,myrank,NUMBER_OF_PASSES, &
- ninterface_acoustic,ninterface_elastic,ninterface_poroelastic)
-
-
- ! reduction of cache misses inner/outer in two passes
- do ipass = 1,NUMBER_OF_PASSES
-
- ! starts reading in Database file
- call read_databases_init(myrank,ipass, &
- simulation_title,SIMULATION_TYPE,SAVE_FORWARD,npgeo, &
- gnuplot,interpol,NTSTEP_BETWEEN_OUTPUT_INFO, &
- output_postscript_snapshot,output_color_image,colors,numbers, &
- meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows, &
- anglerec,initialfield,add_Bielak_conditions, &
- seismotype,imagetype,assign_external_model,READ_EXTERNAL_SEP_FILE, &
- outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON, &
- TURN_VISCATTENUATION_ON,Q0,freq0,p_sv, &
- NSTEP,deltat,NTSTEP_BETWEEN_OUTPUT_SEISMO,NSOURCES)
-
- !
- !--- source information
- !
- if(ipass == 1) then
- allocate( source_type(NSOURCES) )
- allocate( time_function_type(NSOURCES) )
- allocate( x_source(NSOURCES) )
- allocate( z_source(NSOURCES) )
- allocate( f0(NSOURCES) )
- allocate( tshift_src(NSOURCES) )
- allocate( factor(NSOURCES) )
- allocate( angleforce(NSOURCES) )
- allocate( Mxx(NSOURCES) )
- allocate( Mxz(NSOURCES) )
- allocate( Mzz(NSOURCES) )
- allocate( aval(NSOURCES) )
- allocate( ispec_selected_source(NSOURCES) )
- allocate( iglob_source(NSOURCES) )
- allocate( source_courbe_eros(NSOURCES) )
- allocate( xi_source(NSOURCES) )
- allocate( gamma_source(NSOURCES) )
- allocate( is_proc_source(NSOURCES) )
- allocate( nb_proc_source(NSOURCES) )
- allocate( sourcearray(NSOURCES,NDIM,NGLLX,NGLLZ) )
- endif
-
- ! reads in source infos
- call read_databases_sources(NSOURCES,source_type,time_function_type, &
- x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce)
-
- ! sets source parameters
- call set_sources(myrank,NSOURCES,source_type,time_function_type, &
- x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce,aval, &
- t0,initialfield,ipass,deltat)
-
- !
- !---- read attenuation information
- !
- call read_databases_atten(N_SLS,f0_attenuation)
-
- ! if source is not a Dirac or Heavyside then f0_attenuation is f0 of the first source
- if(.not. (time_function_type(1) == 4 .or. time_function_type(1) == 5)) then
- f0_attenuation = f0(1)
- endif
-
-
- !
- !---- read the spectral macrobloc nodal coordinates
- !
- if(ipass == 1) allocate(coorg(NDIM,npgeo))
-
- ! reads the spectral macrobloc nodal coordinates
- ! and basic properties of the spectral elements
- call read_databases_coorg_elem(myrank,ipass,npgeo,coorg,numat,ngnod,nspec, &
- pointsdisp,plot_lowerleft_corner_only, &
- nelemabs,nelem_acoustic_surface, &
- num_fluid_solid_edges,num_fluid_poro_edges, &
- num_solid_poro_edges,nnodes_tangential_curve)
-
-
- !
- !---- allocate arrays
- !
- if(ipass == 1) then
- allocate(shape2D(ngnod,NGLLX,NGLLZ))
- allocate(dershape2D(NDIM,ngnod,NGLLX,NGLLZ))
- allocate(shape2D_display(ngnod,pointsdisp,pointsdisp))
- allocate(dershape2D_display(NDIM,ngnod,pointsdisp,pointsdisp))
- allocate(xix(NGLLX,NGLLZ,nspec))
- allocate(xiz(NGLLX,NGLLZ,nspec))
- allocate(gammax(NGLLX,NGLLZ,nspec))
- allocate(gammaz(NGLLX,NGLLZ,nspec))
- allocate(jacobian(NGLLX,NGLLZ,nspec))
- allocate(flagrange(NGLLX,pointsdisp))
- allocate(xinterp(pointsdisp,pointsdisp))
- allocate(zinterp(pointsdisp,pointsdisp))
- allocate(Uxinterp(pointsdisp,pointsdisp))
- allocate(Uzinterp(pointsdisp,pointsdisp))
- allocate(density(2,numat))
- allocate(anisotropy(6,numat))
- allocate(porosity(numat))
- allocate(tortuosity(numat))
- allocate(permeability(3,numat))
- allocate(poroelastcoef(4,3,numat))
- allocate(Qp_attenuation(numat))
- allocate(Qs_attenuation(numat))
- allocate(kmato(nspec))
- allocate(knods(ngnod,nspec))
- allocate(ibool(NGLLX,NGLLZ,nspec))
- allocate(elastic(nspec))
- allocate(poroelastic(nspec))
- allocate(anisotropic(nspec))
- allocate(inv_tau_sigma_nu1(NGLLX,NGLLZ,nspec,N_SLS))
- allocate(inv_tau_sigma_nu2(NGLLX,NGLLZ,nspec,N_SLS))
- allocate(phi_nu1(NGLLX,NGLLZ,nspec,N_SLS))
- allocate(phi_nu2(NGLLX,NGLLZ,nspec,N_SLS))
- allocate(inv_tau_sigma_nu1_sent(N_SLS))
- allocate(inv_tau_sigma_nu2_sent(N_SLS))
- allocate(phi_nu1_sent(N_SLS))
- allocate(phi_nu2_sent(N_SLS))
- endif
-
- !
- !---- read the material properties
- !
- call gmat01(density,porosity,tortuosity,anisotropy,permeability,poroelastcoef,numat,&
- myrank,ipass,Qp_attenuation,Qs_attenuation,freq0,Q0,f0(1),TURN_VISCATTENUATION_ON)
- !
- !---- read spectral macrobloc data
- !
- if(ipass == 1) then
- allocate(antecedent_list(nspec))
- allocate(perm(nspec))
- endif
- call read_databases_mato(ipass,nspec,ngnod,kmato,knods, &
- perm,antecedent_list)
-
-
-!-------------------------------------------------------------------------------
-!---- determine if each spectral element is elastic, poroelastic, or acoustic
-!-------------------------------------------------------------------------------
- ! initializes
- any_acoustic = .false.
- any_elastic = .false.
- any_poroelastic = .false.
-
- anisotropic(:) = .false.
- elastic(:) = .false.
- poroelastic(:) = .false.
-
- ! loops over all elements
- do ispec = 1,nspec
-
- if( nint(porosity(kmato(ispec))) == 1 ) then
- ! acoustic domain
- elastic(ispec) = .false.
- poroelastic(ispec) = .false.
- any_acoustic = .true.
- elseif( porosity(kmato(ispec)) < TINYVAL) then
- ! elastic domain
- elastic(ispec) = .true.
- poroelastic(ispec) = .false.
- any_elastic = .true.
- if(any(anisotropy(:,kmato(ispec)) /= 0)) then
- anisotropic(ispec) = .true.
- end if
- else
- ! poroelastic domain
- elastic(ispec) = .false.
- poroelastic(ispec) = .true.
- any_poroelastic = .true.
- endif
-
- enddo !do ispec = 1,nspec
-
-
- if(.not. p_sv .and. .not. any_elastic) then
- print*, '*************** WARNING ***************'
- print*, 'Surface (membrane) waves calculation needs an elastic medium'
- print*, '*************** WARNING ***************'
- stop
- endif
- if(.not. p_sv .and. (TURN_ATTENUATION_ON)) then
- print*, '*************** WARNING ***************'
- print*, 'Attenuation and anisotropy are not implemented for surface (membrane) waves calculation'
- print*, '*************** WARNING ***************'
- stop
- endif
-
-
- if(TURN_ATTENUATION_ON) then
- nspec_allocate = nspec
- else
- nspec_allocate = 1
- endif
-
-! allocate memory variables for attenuation
- if(ipass == 1) then
- allocate(e1(NGLLX,NGLLZ,nspec_allocate,N_SLS))
- allocate(e11(NGLLX,NGLLZ,nspec_allocate,N_SLS))
- allocate(e13(NGLLX,NGLLZ,nspec_allocate,N_SLS))
- e1(:,:,:,:) = 0._CUSTOM_REAL
- e11(:,:,:,:) = 0._CUSTOM_REAL
- e13(:,:,:,:) = 0._CUSTOM_REAL
-
- allocate(dux_dxl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(duz_dzl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(duz_dxl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(dux_dzl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(dux_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
- allocate(duz_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
- allocate(duz_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
- allocate(dux_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
- allocate(Mu_nu1(NGLLX,NGLLZ,nspec))
- allocate(Mu_nu2(NGLLX,NGLLZ,nspec))
- endif
-
-! define the attenuation quality factors.
-! they can be different for each element.
-!! DK DK if needed in the future, here the quality factor could be different for each point
- do ispec = 1,nspec
- call attenuation_model(N_SLS,Qp_attenuation(kmato(ispec)),Qs_attenuation(kmato(ispec)), &
- f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
- inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent)
- do j = 1,NGLLZ
- do i = 1,NGLLX
- inv_tau_sigma_nu1(i,j,ispec,:) = inv_tau_sigma_nu1_sent(:)
- phi_nu1(i,j,ispec,:) = phi_nu1_sent(:)
- inv_tau_sigma_nu2(i,j,ispec,:) = inv_tau_sigma_nu2_sent(:)
- phi_nu2(i,j,ispec,:) = phi_nu2_sent(:)
- Mu_nu1(i,j,ispec) = Mu_nu1_sent
- Mu_nu2(i,j,ispec) = Mu_nu2_sent
- enddo
- enddo
- enddo
-
-! allocate memory variables for viscous attenuation (poroelastic media)
- if(ipass == 1) then
- if(TURN_VISCATTENUATION_ON) then
- allocate(rx_viscous(NGLLX,NGLLZ,nspec))
- allocate(rz_viscous(NGLLX,NGLLZ,nspec))
- allocate(viscox(NGLLX,NGLLZ,nspec))
- allocate(viscoz(NGLLX,NGLLZ,nspec))
- else
- allocate(rx_viscous(NGLLX,NGLLZ,1))
- allocate(rz_viscous(NGLLX,NGLLZ,1))
- allocate(viscox(NGLLX,NGLLZ,1))
- allocate(viscoz(NGLLX,NGLLZ,1))
- endif
- endif
-
- !
- !---- read interfaces data
- !
- call read_databases_ninterface(ninterface,max_interface_size)
- if ( ninterface > 0 ) then
- if(ipass == 1) then
- allocate(my_neighbours(ninterface))
- allocate(my_nelmnts_neighbours(ninterface))
- allocate(my_interfaces(4,max_interface_size,ninterface))
- allocate(ibool_interfaces_acoustic(NGLLX*max_interface_size,ninterface))
- allocate(ibool_interfaces_elastic(NGLLX*max_interface_size,ninterface))
- allocate(ibool_interfaces_poroelastic(NGLLX*max_interface_size,ninterface))
- allocate(nibool_interfaces_acoustic(ninterface))
- allocate(nibool_interfaces_elastic(ninterface))
- allocate(nibool_interfaces_poroelastic(ninterface))
- allocate(inum_interfaces_acoustic(ninterface))
- allocate(inum_interfaces_elastic(ninterface))
- allocate(inum_interfaces_poroelastic(ninterface))
- endif
- call read_databases_interfaces(ipass,ninterface,nspec,max_interface_size, &
- my_neighbours,my_nelmnts_neighbours,my_interfaces, &
- perm,antecedent_list)
-
- endif
-
-
-! --- allocate arrays for absorbing boundary conditions
-
- if(nelemabs <= 0) then
- nelemabs = 1
- anyabs = .false.
- else
- anyabs = .true.
- endif
-
- if(ipass == 1) then
- allocate(numabs(nelemabs))
- allocate(codeabs(4,nelemabs))
-
- allocate(ibegin_bottom(nelemabs))
- allocate(iend_bottom(nelemabs))
- allocate(ibegin_top(nelemabs))
- allocate(iend_top(nelemabs))
-
- allocate(jbegin_left(nelemabs))
- allocate(jend_left(nelemabs))
- allocate(jbegin_right(nelemabs))
- allocate(jend_right(nelemabs))
-
- allocate(ibegin_bottom_poro(nelemabs))
- allocate(iend_bottom_poro(nelemabs))
- allocate(ibegin_top_poro(nelemabs))
- allocate(iend_top_poro(nelemabs))
-
- allocate(jbegin_left_poro(nelemabs))
- allocate(jend_left_poro(nelemabs))
- allocate(jbegin_right_poro(nelemabs))
- allocate(jend_right_poro(nelemabs))
-
- allocate(ib_left(nelemabs))
- allocate(ib_right(nelemabs))
- allocate(ib_bottom(nelemabs))
- allocate(ib_top(nelemabs))
-
- endif
-
- !
- !---- read absorbing boundary data
- !
- call read_databases_absorbing(myrank,ipass,nelemabs,nspec,anyabs, &
- ibegin_bottom,iend_bottom,jbegin_right,jend_right, &
- ibegin_top,iend_top,jbegin_left,jend_left, &
- numabs,codeabs,perm,antecedent_list, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- ib_right,ib_left,ib_bottom,ib_top)
-
-
- if( anyabs ) then
- ! Files to save absorbed waves needed to reconstruct backward wavefield for adjoint method
- if(ipass == 1) then
- if(any_elastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 2)) then
- allocate(b_absorb_elastic_left(3,NGLLZ,nspec_xmin,NSTEP))
- allocate(b_absorb_elastic_right(3,NGLLZ,nspec_xmax,NSTEP))
- allocate(b_absorb_elastic_bottom(3,NGLLX,nspec_zmin,NSTEP))
- allocate(b_absorb_elastic_top(3,NGLLX,nspec_zmax,NSTEP))
- else
- allocate(b_absorb_elastic_left(1,1,1,1))
- allocate(b_absorb_elastic_right(1,1,1,1))
- allocate(b_absorb_elastic_bottom(1,1,1,1))
- allocate(b_absorb_elastic_top(1,1,1,1))
- endif
- if(any_poroelastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 2)) then
- allocate(b_absorb_poro_s_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
- allocate(b_absorb_poro_s_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
- allocate(b_absorb_poro_s_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
- allocate(b_absorb_poro_s_top(NDIM,NGLLX,nspec_zmax,NSTEP))
- allocate(b_absorb_poro_w_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
- allocate(b_absorb_poro_w_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
- allocate(b_absorb_poro_w_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
- allocate(b_absorb_poro_w_top(NDIM,NGLLX,nspec_zmax,NSTEP))
- else
- allocate(b_absorb_poro_s_left(1,1,1,1))
- allocate(b_absorb_poro_s_right(1,1,1,1))
- allocate(b_absorb_poro_s_bottom(1,1,1,1))
- allocate(b_absorb_poro_s_top(1,1,1,1))
- allocate(b_absorb_poro_w_left(1,1,1,1))
- allocate(b_absorb_poro_w_right(1,1,1,1))
- allocate(b_absorb_poro_w_bottom(1,1,1,1))
- allocate(b_absorb_poro_w_top(1,1,1,1))
- endif
- if(any_acoustic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 2)) then
- allocate(b_absorb_acoustic_left(NGLLZ,nspec_xmin,NSTEP))
- allocate(b_absorb_acoustic_right(NGLLZ,nspec_xmax,NSTEP))
- allocate(b_absorb_acoustic_bottom(NGLLX,nspec_zmin,NSTEP))
- allocate(b_absorb_acoustic_top(NGLLX,nspec_zmax,NSTEP))
- else
- allocate(b_absorb_acoustic_left(1,1,1))
- allocate(b_absorb_acoustic_right(1,1,1))
- allocate(b_absorb_acoustic_bottom(1,1,1))
- allocate(b_absorb_acoustic_top(1,1,1))
- endif
- endif
-
- else
-
- if(.not. allocated(b_absorb_elastic_left)) then
- allocate(b_absorb_elastic_left(1,1,1,1))
- allocate(b_absorb_elastic_right(1,1,1,1))
- allocate(b_absorb_elastic_bottom(1,1,1,1))
- allocate(b_absorb_elastic_top(1,1,1,1))
- endif
-
- if(.not. allocated(b_absorb_poro_s_left)) then
- allocate(b_absorb_poro_s_left(1,1,1,1))
- allocate(b_absorb_poro_s_right(1,1,1,1))
- allocate(b_absorb_poro_s_bottom(1,1,1,1))
- allocate(b_absorb_poro_s_top(1,1,1,1))
- allocate(b_absorb_poro_w_left(1,1,1,1))
- allocate(b_absorb_poro_w_right(1,1,1,1))
- allocate(b_absorb_poro_w_bottom(1,1,1,1))
- allocate(b_absorb_poro_w_top(1,1,1,1))
- endif
-
- if(.not. allocated(b_absorb_acoustic_left)) then
- allocate(b_absorb_acoustic_left(1,1,1))
- allocate(b_absorb_acoustic_right(1,1,1))
- allocate(b_absorb_acoustic_bottom(1,1,1))
- allocate(b_absorb_acoustic_top(1,1,1))
- endif
-
- endif
-
-!
-!---- read acoustic free surface data
-!
- if(nelem_acoustic_surface > 0) then
- any_acoustic_edges = .true.
- else
- any_acoustic_edges = .false.
- nelem_acoustic_surface = 1
- endif
- if( ipass == 1 ) then
- allocate(acoustic_edges(4,nelem_acoustic_surface))
- allocate(acoustic_surface(5,nelem_acoustic_surface))
- endif
- call read_databases_free_surf(ipass,nelem_acoustic_surface,nspec, &
- acoustic_edges,perm,antecedent_list,any_acoustic_edges)
- ! resets nelem_acoustic_surface
- if( any_acoustic_edges .eqv. .false. ) nelem_acoustic_surface = 0
-
- ! constructs acoustic surface
- if(nelem_acoustic_surface > 0) then
- call construct_acoustic_surface ( nspec, ngnod, knods, nelem_acoustic_surface, &
- acoustic_edges, acoustic_surface)
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
- endif
- endif
-
-
- !
- !---- read coupled edges
- !
- if( num_fluid_solid_edges > 0 ) then
- any_fluid_solid_edges = .true.
- else
- any_fluid_solid_edges = .false.
- num_fluid_solid_edges = 1
- endif
- if(ipass == 1) then
- allocate(fluid_solid_acoustic_ispec(num_fluid_solid_edges))
- allocate(fluid_solid_acoustic_iedge(num_fluid_solid_edges))
- allocate(fluid_solid_elastic_ispec(num_fluid_solid_edges))
- allocate(fluid_solid_elastic_iedge(num_fluid_solid_edges))
- endif
- if( num_fluid_poro_edges > 0 ) then
- any_fluid_poro_edges = .true.
- else
- any_fluid_poro_edges = .false.
- num_fluid_poro_edges = 1
- endif
- if(ipass == 1) then
- allocate(fluid_poro_acoustic_ispec(num_fluid_poro_edges))
- allocate(fluid_poro_acoustic_iedge(num_fluid_poro_edges))
- allocate(fluid_poro_poroelastic_ispec(num_fluid_poro_edges))
- allocate(fluid_poro_poroelastic_iedge(num_fluid_poro_edges))
- endif
- if ( num_solid_poro_edges > 0 ) then
- any_solid_poro_edges = .true.
- else
- any_solid_poro_edges = .false.
- num_solid_poro_edges = 1
- endif
- if(ipass == 1) then
- allocate(solid_poro_elastic_ispec(num_solid_poro_edges))
- allocate(solid_poro_elastic_iedge(num_solid_poro_edges))
- allocate(solid_poro_poroelastic_ispec(num_solid_poro_edges))
- allocate(solid_poro_poroelastic_iedge(num_solid_poro_edges))
- endif
-
- call read_databases_coupled(ipass,nspec,num_fluid_solid_edges,any_fluid_solid_edges, &
- fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec, &
- num_fluid_poro_edges,any_fluid_poro_edges, &
- fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec, &
- num_solid_poro_edges,any_solid_poro_edges, &
- solid_poro_elastic_ispec,solid_poro_poroelastic_ispec, &
- perm,antecedent_list)
-
- ! resets counters
- if( any_fluid_solid_edges .eqv. .false. ) num_fluid_solid_edges = 0
- if( any_fluid_poro_edges .eqv. .false. ) num_fluid_poro_edges = 0
- if( any_solid_poro_edges .eqv. .false. ) num_solid_poro_edges = 0
-
-
- !
- !---- read tangential detection curve
- ! and close Database file
- !
- if (nnodes_tangential_curve > 0) then
- any_tangential_curve = .true.
- else
- any_tangential_curve = .false.
- nnodes_tangential_curve = 1
- endif
- if (ipass == 1) then
- allocate(nodes_tangential_curve(2,nnodes_tangential_curve))
- allocate(dist_tangential_detection_curve(nnodes_tangential_curve))
- endif
- call read_databases_final(nnodes_tangential_curve,nodes_tangential_curve, &
- force_normal_to_surface,rec_normal_to_surface, &
- any_tangential_curve)
- ! resets nnode_tangential_curve
- if( any_tangential_curve .eqv. .false. ) nnodes_tangential_curve = 0
-
-!
-!---- compute shape functions and their derivatives for SEM grid
-!
-
-! set up Gauss-Lobatto-Legendre derivation matrices
- call define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
- call define_shape_functions(shape2D(:,i,j),dershape2D(:,:,i,j),xigll(i),zigll(j),ngnod)
- enddo
- enddo
-
-!
-!---- generate the global numbering
-!
-
-! "slow and clean" or "quick and dirty" version
- if(FAST_NUMBERING) then
- call createnum_fast(knods,ibool,shape2D,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
- else
- call createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
- endif
-
-! create a new indirect addressing array to reduce cache misses in memory access in the solver
- if(ipass == 2) then
-
- deallocate(perm)
-
- allocate(copy_ibool_ori(NGLLX,NGLLZ,nspec))
- allocate(mask_ibool(npoin))
-
- print *
- print *,'Xmin,Xmax of the whole mesh = ',minval(coord(1,:)),maxval(coord(1,:))
- print *,'Zmin,Zmax of the whole mesh = ',minval(coord(2,:)),maxval(coord(2,:))
- print *
-
-!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
-
- if(ADD_PERIODIC_CONDITIONS) then
-
-#ifdef USE_MPI
- stop 'periodic conditions currently implemented for a serial simulation only (due e.g. to mass matrix rebuilding)'
-#endif
-
- if(any_poroelastic .or. any_acoustic) stop 'periodic conditions currently implemented for purely elastic models only'
-
- if(ACTUALLY_IMPLEMENT_PERM_OUT .or. ACTUALLY_IMPLEMENT_PERM_INN .or. ACTUALLY_IMPLEMENT_PERM_WHOLE) &
- stop 'currently, all permutations should be off for periodic conditions'
-
-print *
-open(unit=123,file='Database00000_left_edge_only',status='old')
-do ispecperio = 1,NSPEC_PERIO
- read(123,*) numperio_left(ispecperio), &
- codeabs_perio_left(IBOTTOM,ispecperio), &
- codeabs_perio_left(IRIGHT,ispecperio), &
- codeabs_perio_left(ITOP,ispecperio), &
- codeabs_perio_left(ILEFT,ispecperio), &
- idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
-enddo
-close(123)
-print *,'read ',NSPEC_PERIO,' elements for left periodic edge'
-
-open(unit=123,file='Database00000_right_edge_only',status='old')
-do ispecperio = 1,NSPEC_PERIO
- read(123,*) numperio_right(ispecperio), &
- codeabs_perio_right(IBOTTOM,ispecperio), &
- codeabs_perio_right(IRIGHT,ispecperio), &
- codeabs_perio_right(ITOP,ispecperio), &
- codeabs_perio_right(ILEFT,ispecperio), &
- idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
-enddo
-close(123)
-print *,'read ',NSPEC_PERIO,' elements for right periodic edge'
-print *
-
-print *,'because of periodic conditions, values computed by checkgrid() are not reliable'
-print *
-
-!---------------------------------------------------------------------------
-
- do ispecperio = 1,NSPEC_PERIO
-
- ispec = numperio_left(ispecperio)
-
-! print *,'dist of edge is ',sqrt((coord(2,ibool(1,1,ispec)) - coord(2,ibool(1,NGLLZ,ispec))) ** 2 + &
-! (coord(1,ibool(1,1,ispec)) - coord(1,ibool(1,NGLLZ,ispec))) ** 2)
-
- if(codeabs_perio_left(ILEFT,ispecperio)) then
- i = 1
- do j = 1,NGLLZ
- iglob = ibool(i,j,ispec)
-!----------------------------------------------------------------------
- include "include_for_periodic_conditions.f90"
-!----------------------------------------------------------------------
- enddo
- endif
-
- if(codeabs_perio_left(IRIGHT,ispecperio)) then
- i = NGLLX
- do j = 1,NGLLZ
- iglob = ibool(i,j,ispec)
-!----------------------------------------------------------------------
- include "include_for_periodic_conditions.f90"
-!----------------------------------------------------------------------
- enddo
- endif
-
- if(codeabs_perio_left(IBOTTOM,ispecperio)) then
- j = 1
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
-!----------------------------------------------------------------------
- include "include_for_periodic_conditions.f90"
-!----------------------------------------------------------------------
- enddo
- endif
-
- if(codeabs_perio_left(ITOP,ispecperio)) then
- j = NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
-!----------------------------------------------------------------------
- include "include_for_periodic_conditions.f90"
-!----------------------------------------------------------------------
- enddo
- endif
-
- enddo
-
-! rebuild the mass matrix based on this new numbering
-!
-!---- build the global mass matrix and invert it once and for all
-!
- rmass_inverse_elastic(:) = 0._CUSTOM_REAL
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
-
- ! if external density model (elastic or acoustic)
- if(assign_external_model) then
- rhol = rhoext(i,j,ispec)
- kappal = rhol * vpext(i,j,ispec)**2
- else
- rhol = density(1,kmato(ispec))
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec))
- kappal = lambdal_relaxed + 2.d0/3.d0*mul_relaxed
- endif
-
- rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) &
- + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
-
- enddo
- enddo
- enddo ! do ispec = 1,nspec
-
-! invert the mass matrix once and for all
-! set entries that are equal to zero to something else, e.g. 1, to avoid division by zero
-! these degrees of freedom correspond to points that have been replaced with their periodic counterpart
-! and thus are not used any more
- where(rmass_inverse_elastic == 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
- rmass_inverse_elastic(:) = 1._CUSTOM_REAL / rmass_inverse_elastic(:)
-
- endif ! of if(ADD_PERIODIC_CONDITIONS)
-
-!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
-
- mask_ibool(:) = -1
- copy_ibool_ori(:,:,:) = ibool(:,:,:)
-
- inumber = 0
-
- if(.not. ACTUALLY_IMPLEMENT_PERM_WHOLE) then
-
-! first reduce cache misses in outer elements, since they are taken first
-! loop over spectral elements
- do ispec = 1,nspec_outer
- do j=1,NGLLZ
- do i=1,NGLLX
- if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
- ! create a new point
- inumber = inumber + 1
- ibool(i,j,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
- else
- ! use an existing point created previously
- ibool(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
- endif
- enddo
- enddo
- enddo
-
-! then reduce cache misses in inner elements, since they are taken second
-! loop over spectral elements
- do ispec = nspec_outer+1,nspec
- do j=1,NGLLZ
- do i=1,NGLLX
- if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
- ! create a new point
- inumber = inumber + 1
- ibool(i,j,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
- else
- ! use an existing point created previously
- ibool(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
- endif
- enddo
- enddo
- enddo
-
- else ! if ACTUALLY_IMPLEMENT_PERM_WHOLE
-
-! reduce cache misses in all the elements
-! loop over spectral elements
- do ispec = 1,nspec
- do j=1,NGLLZ
- do i=1,NGLLX
- if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
- ! create a new point
- inumber = inumber + 1
- ibool(i,j,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
- else
- ! use an existing point created previously
- ibool(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
- endif
- enddo
- enddo
- enddo
-
- endif
-
- deallocate(copy_ibool_ori)
- deallocate(mask_ibool)
-
- else if(ipass /= 1) then
-
- stop 'incorrect pass number for reduction of cache misses'
-
- endif ! ipass
-
-!---- compute shape functions and their derivatives for regular interpolated display grid
- do j = 1,pointsdisp
- do i = 1,pointsdisp
- xirec = 2.d0*dble(i-1)/dble(pointsdisp-1) - 1.d0
- gammarec = 2.d0*dble(j-1)/dble(pointsdisp-1) - 1.d0
- call define_shape_functions(shape2D_display(:,i,j),dershape2D_display(:,:,i,j),xirec,gammarec,ngnod)
- enddo
- enddo
-
-!---- compute Lagrange interpolants on a regular interpolated grid in (xi,gamma)
-!---- for display (assumes NGLLX = NGLLZ)
- do j=1,NGLLX
- do i=1,pointsdisp
- xirec = 2.d0*dble(i-1)/dble(pointsdisp-1) - 1.d0
- flagrange(j,i) = hgll(j-1,xirec,xigll,NGLLX)
- enddo
- enddo
-
-! get number of stations from receiver file
- open(unit=IIN,file='DATA/STATIONS_target',iostat=ios,status='old',action='read')
- nrec = 0
- do while(ios == 0)
- read(IIN,"(a)",iostat=ios) dummystring
- if(ios == 0) nrec = nrec + 1
- enddo
- close(IIN)
-
- if (myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Total number of receivers = ',nrec
- write(IOUT,*)
- endif
-
- if(nrec < 1) call exit_MPI('need at least one receiver')
-
-! receiver information
- if(ipass == 1) then
-
- allocate(ispec_selected_rec(nrec))
- allocate(st_xval(nrec))
- allocate(st_zval(nrec))
- allocate(xi_receiver(nrec))
- allocate(gamma_receiver(nrec))
- allocate(station_name(nrec))
- allocate(network_name(nrec))
- allocate(recloc(nrec))
- allocate(which_proc_receiver(nrec))
- allocate(x_final_receiver(nrec))
- allocate(z_final_receiver(nrec))
-
-! allocate 1-D Lagrange interpolators and derivatives
- allocate(hxir(NGLLX))
- allocate(hxis(NGLLX))
- allocate(hpxir(NGLLX))
- allocate(hpxis(NGLLX))
- allocate(hgammar(NGLLZ))
- allocate(hgammas(NGLLZ))
- allocate(hpgammar(NGLLZ))
- allocate(hpgammas(NGLLZ))
-
-! allocate Lagrange interpolators for receivers
- allocate(hxir_store(nrec,NGLLX))
- allocate(hgammar_store(nrec,NGLLZ))
-
-! allocate Lagrange interpolators for sources
- allocate(hxis_store(NSOURCES,NGLLX))
- allocate(hgammas_store(NSOURCES,NGLLZ))
-
-! allocate other global arrays
- allocate(coord(NDIM,npoin))
-
-! to display acoustic elements
- allocate(vector_field_display(3,npoin))
-
-! if(assign_external_model) then
-
-! note: so far, full external array needed/defined in subroutine calls
- allocate(vpext(NGLLX,NGLLZ,nspec))
- allocate(vsext(NGLLX,NGLLZ,nspec))
- allocate(rhoext(NGLLX,NGLLZ,nspec))
- allocate(Qp_attenuationext(NGLLX,NGLLZ,nspec))
- allocate(Qs_attenuationext(NGLLX,NGLLZ,nspec))
- allocate(c11ext(NGLLX,NGLLZ,nspec))
- allocate(c13ext(NGLLX,NGLLZ,nspec))
- allocate(c15ext(NGLLX,NGLLZ,nspec))
- allocate(c33ext(NGLLX,NGLLZ,nspec))
- allocate(c35ext(NGLLX,NGLLZ,nspec))
- allocate(c55ext(NGLLX,NGLLZ,nspec))
-! else
-! allocate(vpext(1,1,1))
-! allocate(vsext(1,1,1))
-! allocate(rhoext(1,1,1))
-! allocate(c11ext(1,1,1))
-! allocate(c13ext(1,1,1))
-! allocate(c15ext(1,1,1))
-! allocate(c33ext(1,1,1))
-! allocate(c35ext(1,1,1))
-! allocate(c55ext(1,1,1))
-! endif
-
- endif
-
-!
-!---- set the coordinates of the points of the global grid
-!
- found_a_negative_jacobian = .false.
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- xi = xigll(i)
- gamma = zigll(j)
-
- call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
- jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
- .false.)
-
- if(jacobianl <= ZERO) found_a_negative_jacobian = .true.
-
- coord(1,ibool(i,j,ispec)) = x
- coord(2,ibool(i,j,ispec)) = z
-
- xix(i,j,ispec) = xixl
- xiz(i,j,ispec) = xizl
- gammax(i,j,ispec) = gammaxl
- gammaz(i,j,ispec) = gammazl
- jacobian(i,j,ispec) = jacobianl
-
- enddo
- enddo
- enddo
-
-! create an OpenDX file containing all the negative elements displayed in red, if any
-! this allows users to locate problems in a mesh based on the OpenDX file created at the second iteration
-! do not create OpenDX files if no negative Jacobian has been found, or if we are running in parallel
-! (because writing OpenDX routines is much easier in serial)
- if(found_a_negative_jacobian .and. nproc == 1) then
- call save_openDX_jacobian(nspec,npgeo,ngnod,knods,coorg,xigll,zigll)
- endif
-
-! stop the code at the first negative element found, because such a mesh cannot be computed
- if(found_a_negative_jacobian) then
-
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- xi = xigll(i)
- gamma = zigll(j)
-
- call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
- jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
- .true.)
-
- enddo
- enddo
- enddo
-
- endif
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! yang output weights for line, surface integrals !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!define_derivation_matrices(xigll(NGLLX),zigll(NGLLZ),wxgll(NGLLX),wzgll(NGLLZ),hprime_xx(NGLLX,NGLLX),hprime_zz(NGLLZ,NGLLZ),&
-! hprimewgll_xx(NGLLX,NGLLX),hprimewgll_zz(NGLLZ,NGLLZ))
-!xix(NGLLX,NGLLZ,nspec),xiz,gammax,gammaz,jacobian
-!recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl,jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
-! .true.)
- allocate(weight_line_x(npoin))
- allocate(weight_line_z(npoin))
- allocate(weight_surface(npoin))
- allocate(weight_jacobian(npoin))
- allocate(weight_gll(npoin))
- weight_line_x=0.0
- weight_line_z=0.0
- weight_surface=0.0
- zmin_yang=minval(coord(2,:))
- xmin_yang=minval(coord(1,:))
- zmax_yang=maxval(coord(2,:))
- xmax_yang=maxval(coord(1,:))
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob=ibool(i,j,ispec)
- z=coord(2,ibool(i,j,ispec))
- xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
- zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
- if ((j==1 .OR. j==NGLLZ) .AND. ( (abs(z-zmin_yang).GE.1) .AND. (abs(z-zmax_yang)).GE.1) ) xxi=xxi/2.0
- if ((i==1 .OR. i==NGLLZ) .AND. ( (abs(x-xmin_yang).GE.1) .AND. (abs(x-xmax_yang)).GE.1) ) zgamma=zgamma/2.0
- weight_line_x(iglob) = weight_line_x(iglob) + xxi * wxgll(i)
- weight_line_z(iglob) = weight_line_z(iglob) + zgamma * wzgll(j)
- weight_surface(iglob) = weight_surface(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)
- weight_jacobian(iglob) = jacobian(i,j,ispec)
- weight_gll(iglob) = 10*j+i
- enddo
- enddo
- enddo
- open(unit=55,file='OUTPUT_FILES/x_z_weightLineX_weightLineZ_weightSurface',status='unknown')
- do n = 1,npoin
- write(55,*) coord(1,n), coord(2,n), weight_line_x(n), weight_line_z(n), weight_surface(n),weight_jacobian(n),weight_gll(n)
- enddo
- close(55)
- deallocate(weight_line_x)
- deallocate(weight_line_z)
- deallocate(weight_surface)
- deallocate(weight_jacobian)
- deallocate(weight_gll)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!--- save the grid of points in a file
-!
- if(outputgrid .and. myrank == 0 .and. ipass == 1) then
- write(IOUT,*)
- write(IOUT,*) 'Saving the grid in a text file...'
- write(IOUT,*)
- open(unit=55,file='OUTPUT_FILES/grid_points_and_model.txt',status='unknown')
- write(55,*) npoin
- do n = 1,npoin
- write(55,*) (coord(i,n), i=1,NDIM)
- enddo
- close(55)
- endif
-
-!
-!----- plot the GLL mesh in a Gnuplot file
-!
- if(gnuplot .and. myrank == 0 .and. ipass == 1) &
- call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
-
- if(myrank == 0 .and. ipass == 1) &
- write(IOUT,*) 'assign_external_model = ', assign_external_model
-
-!if ( assign_external_model .and. ipass == 1) then
- if ( assign_external_model) then
- call read_external_model(any_acoustic,any_elastic,any_poroelastic, &
- elastic,poroelastic,anisotropic,nspec,npoin,N_SLS,ibool, &
- f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
- inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent, &
- inv_tau_sigma_nu1,inv_tau_sigma_nu2,phi_nu1,phi_nu2,Mu_nu1,Mu_nu2,&
- coord,kmato,myrank,rhoext,vpext,vsext, &
- Qp_attenuationext,Qs_attenuationext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,READ_EXTERNAL_SEP_FILE)
- end if
-
-!
-!---- perform basic checks on parameters read
-!
- all_anisotropic = .false.
- if(count(anisotropic(:) .eqv. .true.) == nspec) all_anisotropic = .true.
-
- if(all_anisotropic .and. anyabs) &
- call exit_MPI('Cannot put absorbing boundaries if anisotropic materials along edges')
-
- if(TURN_ATTENUATION_ON .and. all_anisotropic) then
- call exit_MPI('Cannot turn attenuation on in anisotropic materials')
- end if
-
- ! global domain flags
- any_elastic_glob = any_elastic
-#ifdef USE_MPI
- call MPI_ALLREDUCE(any_elastic, any_elastic_glob, 1, MPI_LOGICAL, &
- MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- any_poroelastic_glob = any_poroelastic
-#ifdef USE_MPI
- call MPI_ALLREDUCE(any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, &
- MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- any_acoustic_glob = any_acoustic
-#ifdef USE_MPI
- call MPI_ALLREDUCE(any_acoustic, any_acoustic_glob, 1, MPI_LOGICAL, &
- MPI_LOR, MPI_COMM_WORLD, ier)
-#endif
-
- ! for acoustic
- if(TURN_ATTENUATION_ON .and. .not. any_elastic_glob) &
- call exit_MPI('currently cannot have attenuation if acoustic/poroelastic simulation only')
-
-!
-!---- define coefficients of the Newmark time scheme
-!
- deltatover2 = HALF*deltat
- deltatsquareover2 = HALF*deltat*deltat
-
- if(SIMULATION_TYPE == 2) then
-! define coefficients of the Newmark time scheme for the backward wavefield
- b_deltat = - deltat
- b_deltatover2 = HALF*b_deltat
- b_deltatsquareover2 = HALF*b_deltat*b_deltat
- endif
-
-!---- define actual location of source and receivers
-
- call setup_sources_receivers(NSOURCES,initialfield,source_type,&
- coord,ibool,npoin,nspec,nelem_acoustic_surface,acoustic_surface,elastic,poroelastic, &
- x_source,z_source,ispec_selected_source,ispec_selected_rec, &
- is_proc_source,nb_proc_source,ipass,&
- sourcearray,Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,npgeo,&
- nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod, &
- nrec,nrecloc,recloc,which_proc_receiver,st_xval,st_zval, &
- xi_receiver,gamma_receiver,station_name,network_name,x_final_receiver,z_final_receiver,iglob_source)
-
-! compute source array for adjoint source
- if(SIMULATION_TYPE == 2) then ! adjoint calculation
- nadj_rec_local = 0
- do irec = 1,nrec
- if(myrank == which_proc_receiver(irec))then
-! check that the source proc number is okay
- if(which_proc_receiver(irec) < 0 .or. which_proc_receiver(irec) > NPROC-1) &
- call exit_MPI('something is wrong with the source proc number in adjoint simulation')
- nadj_rec_local = nadj_rec_local + 1
- endif
- enddo
- if(ipass == 1) allocate(adj_sourcearray(NSTEP,3,NGLLX,NGLLZ))
- if (nadj_rec_local > 0 .and. ipass == 1) then
- allocate(adj_sourcearrays(nadj_rec_local,NSTEP,3,NGLLX,NGLLZ))
- else if (ipass == 1) then
- allocate(adj_sourcearrays(1,1,1,1,1))
- endif
-
- irec_local = 0
- do irec = 1, nrec
-! compute only adjoint source arrays in the local proc
- if(myrank == which_proc_receiver(irec))then
- irec_local = irec_local + 1
- adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
- call compute_arrays_adj_source(adj_source_file, &
- xi_receiver(irec), gamma_receiver(irec), &
- adj_sourcearray, xigll,zigll,NSTEP)
- adj_sourcearrays(irec_local,:,:,:,:) = adj_sourcearray(:,:,:,:)
- endif
- enddo
- else if (ipass == 1) then
- allocate(adj_sourcearrays(1,1,1,1,1))
- endif
-
- if (ipass == 1) then
- if (nrecloc > 0) then
- allocate(anglerec_irec(nrecloc))
- allocate(cosrot_irec(nrecloc))
- allocate(sinrot_irec(nrecloc))
- allocate(rec_tangential_detection_curve(nrecloc))
- else
- allocate(anglerec_irec(1))
- allocate(cosrot_irec(1))
- allocate(sinrot_irec(1))
- allocate(rec_tangential_detection_curve(1))
- endif
-
- if (rec_normal_to_surface .and. abs(anglerec) > 1.d-6) &
- stop 'anglerec should be zero when receivers are normal to the topography'
-
- anglerec_irec(:) = anglerec * pi / 180.d0
- cosrot_irec(:) = cos(anglerec_irec(:))
- sinrot_irec(:) = sin(anglerec_irec(:))
- endif
-
-!
-!--- tangential computation
-!
- if (ipass == NUMBER_OF_PASSES) then
-
-! for receivers
- if (rec_normal_to_surface) then
- irecloc = 0
- do irec = 1, nrec
- if (which_proc_receiver(irec) == myrank) then
- irecloc = irecloc + 1
- distmin = HUGEVAL
- do i = 1, nnodes_tangential_curve
- dist_current = sqrt((x_final_receiver(irec)-nodes_tangential_curve(1,i))**2 + &
- (z_final_receiver(irec)-nodes_tangential_curve(2,i))**2)
- if ( dist_current < distmin ) then
- n1_tangential_detection_curve = i
- distmin = dist_current
- endif
- enddo
-
- rec_tangential_detection_curve(irecloc) = n1_tangential_detection_curve
- call tri_quad(n_tangential_detection_curve, n1_tangential_detection_curve, &
- nnodes_tangential_curve)
-
- call compute_normal_vector( anglerec_irec(irecloc), &
- nodes_tangential_curve(1,n_tangential_detection_curve(1)), &
- nodes_tangential_curve(1,n_tangential_detection_curve(2)), &
- nodes_tangential_curve(1,n_tangential_detection_curve(3)), &
- nodes_tangential_curve(1,n_tangential_detection_curve(4)), &
- nodes_tangential_curve(2,n_tangential_detection_curve(1)), &
- nodes_tangential_curve(2,n_tangential_detection_curve(2)), &
- nodes_tangential_curve(2,n_tangential_detection_curve(3)), &
- nodes_tangential_curve(2,n_tangential_detection_curve(4)) )
- endif
-
- enddo
- cosrot_irec(:) = cos(anglerec_irec(:))
- sinrot_irec(:) = sin(anglerec_irec(:))
- endif
-
-! for the source
- if (force_normal_to_surface) then
-
- do i_source=1,NSOURCES
- if (is_proc_source(i_source) == 1) then
- distmin = HUGEVAL
- do i = 1, nnodes_tangential_curve
- dist_current = sqrt((coord(1,iglob_source(i_source))-nodes_tangential_curve(1,i))**2 + &
- (coord(2,iglob_source(i_source))-nodes_tangential_curve(2,i))**2)
- if ( dist_current < distmin ) then
- n1_tangential_detection_curve = i
- distmin = dist_current
-
- endif
- enddo
-
- call tri_quad(n_tangential_detection_curve, n1_tangential_detection_curve, &
- nnodes_tangential_curve)
-
- ! in the case of a source force vector
- ! users can give an angle with respect to the normal to the topography surface,
- ! in which case we must compute the normal to the topography
- ! and add it the existing rotation angle
- call compute_normal_vector( angleforce(i_source), &
- nodes_tangential_curve(1,n_tangential_detection_curve(1)), &
- nodes_tangential_curve(1,n_tangential_detection_curve(2)), &
- nodes_tangential_curve(1,n_tangential_detection_curve(3)), &
- nodes_tangential_curve(1,n_tangential_detection_curve(4)), &
- nodes_tangential_curve(2,n_tangential_detection_curve(1)), &
- nodes_tangential_curve(2,n_tangential_detection_curve(2)), &
- nodes_tangential_curve(2,n_tangential_detection_curve(3)), &
- nodes_tangential_curve(2,n_tangential_detection_curve(4)) )
-
- source_courbe_eros(i_source) = n1_tangential_detection_curve
- if ( myrank == 0 .and. is_proc_source(i_source) == 1 .and. nb_proc_source(i_source) == 1 ) then
- source_courbe_eros(i_source) = n1_tangential_detection_curve
- angleforce_recv = angleforce(i_source)
-#ifdef USE_MPI
- else if ( myrank == 0 ) then
- do i = 1, nb_proc_source(i_source) - is_proc_source(i_source)
- call MPI_recv(source_courbe_eros(i_source),1,MPI_INTEGER, &
- MPI_ANY_SOURCE,42,MPI_COMM_WORLD,request_mpi_status,ier)
- call MPI_recv(angleforce_recv,1,MPI_DOUBLE_PRECISION, &
- MPI_ANY_SOURCE,43,MPI_COMM_WORLD,request_mpi_status,ier)
- enddo
- else if ( is_proc_source(i_source) == 1 ) then
- call MPI_send(n1_tangential_detection_curve,1,MPI_INTEGER,0,42,MPI_COMM_WORLD,ier)
- call MPI_send(angleforce(i_source),1,MPI_DOUBLE_PRECISION,0,43,MPI_COMM_WORLD,ier)
-#endif
- endif
-
-#ifdef USE_MPI
- call MPI_bcast(angleforce_recv,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- angleforce(i_source) = angleforce_recv
-#endif
- endif ! if (is_proc_source(i_source) == 1)
- enddo ! do i_source=1,NSOURCES
- endif ! if (force_normal_to_surface)
-
-! CHRIS --- how to deal with multiple source. Use first source now. ---
-! compute distance from source to receivers following the curve
- if (force_normal_to_surface .and. rec_normal_to_surface) then
- dist_tangential_detection_curve(source_courbe_eros(1)) = 0
- do i = source_courbe_eros(1)+1, nnodes_tangential_curve
- dist_tangential_detection_curve(i) = dist_tangential_detection_curve(i-1) + &
- sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i-1))**2 + &
- (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i-1))**2)
- enddo
- dist_tangential_detection_curve(1) = dist_tangential_detection_curve(nnodes_tangential_curve) + &
- sqrt((nodes_tangential_curve(1,1)-nodes_tangential_curve(1,nnodes_tangential_curve))**2 + &
- (nodes_tangential_curve(2,1)-nodes_tangential_curve(2,nnodes_tangential_curve))**2)
- do i = 2, source_courbe_eros(1)-1
- dist_tangential_detection_curve(i) = dist_tangential_detection_curve(i-1) + &
- sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i-1))**2 + &
- (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i-1))**2)
- enddo
- do i = source_courbe_eros(1)-1, 1, -1
- dist_current = dist_tangential_detection_curve(i+1) + &
- sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i+1))**2 + &
- (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i+1))**2)
- if ( dist_current < dist_tangential_detection_curve(i) ) then
- dist_tangential_detection_curve(i) = dist_current
- endif
- enddo
- dist_current = dist_tangential_detection_curve(1) + &
- sqrt((nodes_tangential_curve(1,1)-nodes_tangential_curve(1,nnodes_tangential_curve))**2 + &
- (nodes_tangential_curve(2,1)-nodes_tangential_curve(2,nnodes_tangential_curve))**2)
- if ( dist_current < dist_tangential_detection_curve(nnodes_tangential_curve) ) then
- dist_tangential_detection_curve(nnodes_tangential_curve) = dist_current
- endif
- do i = nnodes_tangential_curve-1, source_courbe_eros(1)+1, -1
- dist_current = dist_tangential_detection_curve(i+1) + &
- sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i+1))**2 + &
- (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i+1))**2)
- if ( dist_current < dist_tangential_detection_curve(i) ) then
- dist_tangential_detection_curve(i) = dist_current
- endif
- enddo
-
- if ( myrank == 0 ) then
- open(unit=11,file='OUTPUT_FILES/dist_rec_tangential_detection_curve', &
- form='formatted', status='unknown')
- endif
- irecloc = 0
- do irec = 1,nrec
-
- if ( myrank == 0 ) then
- if ( which_proc_receiver(irec) == myrank ) then
- irecloc = irecloc + 1
- n1_tangential_detection_curve = rec_tangential_detection_curve(irecloc)
- x_final_receiver_dummy = x_final_receiver(irec)
- z_final_receiver_dummy = z_final_receiver(irec)
-#ifdef USE_MPI
- else
-
- call MPI_RECV(n1_tangential_detection_curve,1,MPI_INTEGER,&
- which_proc_receiver(irec),irec,MPI_COMM_WORLD,request_mpi_status,ier)
- call MPI_RECV(x_final_receiver_dummy,1,MPI_DOUBLE_PRECISION,&
- which_proc_receiver(irec),irec,MPI_COMM_WORLD,request_mpi_status,ier)
- call MPI_RECV(z_final_receiver_dummy,1,MPI_DOUBLE_PRECISION,&
- which_proc_receiver(irec),irec,MPI_COMM_WORLD,request_mpi_status,ier)
-
-#endif
- endif
-
-#ifdef USE_MPI
- else
- if ( which_proc_receiver(irec) == myrank ) then
- irecloc = irecloc + 1
- call MPI_SEND(rec_tangential_detection_curve(irecloc),1,MPI_INTEGER,0,irec,MPI_COMM_WORLD,ier)
- call MPI_SEND(x_final_receiver(irec),1,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ier)
- call MPI_SEND(z_final_receiver(irec),1,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ier)
- endif
-#endif
-
- endif
- if ( myrank == 0 ) then
- write(11,*) dist_tangential_detection_curve(n1_tangential_detection_curve)
- write(12,*) x_final_receiver_dummy
- write(13,*) z_final_receiver_dummy
- endif
- enddo
-
- if ( myrank == 0 ) then
- close(11)
- close(12)
- close(13)
- endif
-
- endif ! force_normal_to_surface
-
- endif ! ipass
-
-!
-!---
-!
-
-! allocate seismogram arrays
- if(ipass == 1) then
- allocate(sisux(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
- allocate(sisuz(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
- allocate(siscurl(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
- endif
-
-! check if acoustic receiver is exactly on the free surface because pressure is zero there
- do ispec_acoustic_surface = 1,nelem_acoustic_surface
- ispec = acoustic_surface(1,ispec_acoustic_surface)
- ixmin = acoustic_surface(2,ispec_acoustic_surface)
- ixmax = acoustic_surface(3,ispec_acoustic_surface)
- izmin = acoustic_surface(4,ispec_acoustic_surface)
- izmax = acoustic_surface(5,ispec_acoustic_surface)
- do irecloc = 1,nrecloc
- irec = recloc(irecloc)
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
- if ( (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==NGLLX .and. &
- gamma_receiver(irec) < -0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==NGLLX .and. &
- gamma_receiver(irec) > 0.99d0) .or.&
- (izmin==1 .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
- xi_receiver(irec) < -0.99d0) .or.&
- (izmin==1 .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- xi_receiver(irec) > 0.99d0) .or.&
- (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==1 .and. &
- gamma_receiver(irec) < -0.99d0 .and. xi_receiver(irec) < -0.99d0) .or.&
- (izmin==1 .and. izmax==1 .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- gamma_receiver(irec) < -0.99d0 .and. xi_receiver(irec) > 0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
- gamma_receiver(irec) > 0.99d0 .and. xi_receiver(irec) < -0.99d0) .or.&
- (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
- gamma_receiver(irec) > 0.99d0 .and. xi_receiver(irec) > 0.99d0) ) then
- if(seismotype == 4) then
- call exit_MPI('an acoustic pressure receiver cannot be located exactly '// &
- 'on the free surface because pressure is zero there')
- else
- print *, '**********************************************************************'
- print *, '*** Warning: acoustic receiver located exactly on the free surface ***'
- print *, '*** Warning: tangential component will be zero there ***'
- print *, '**********************************************************************'
- print *
- endif
- endif
- endif
- enddo
- enddo
-
-! define and store Lagrange interpolators at all the receivers
- do irec = 1,nrec
- call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
- call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
- hxir_store(irec,:) = hxir(:)
- hgammar_store(irec,:) = hgammar(:)
- enddo
-
-! define and store Lagrange interpolators at all the sources
- do i = 1,NSOURCES
- call lagrange_any(xi_source(i),NGLLX,xigll,hxis,hpxis)
- call lagrange_any(gamma_source(i),NGLLZ,zigll,hgammas,hpgammas)
- hxis_store(i,:) = hxis(:)
- hgammas_store(i,:) = hgammas(:)
- enddo
-
-! displacement, velocity, acceleration and inverse of the mass matrix for elastic elements
- if(ipass == 1) then
-
- if(any_elastic) then
- npoin_elastic = npoin
- else
- ! allocate unused arrays with fictitious size
- npoin_elastic = 1
- endif
- allocate(displ_elastic(3,npoin_elastic))
- allocate(veloc_elastic(3,npoin_elastic))
- allocate(accel_elastic(3,npoin_elastic))
- allocate(rmass_inverse_elastic(npoin_elastic))
-
- ! extra array if adjoint and kernels calculation
- if(SIMULATION_TYPE == 2 .and. any_elastic) then
- allocate(b_displ_elastic(3,npoin))
- allocate(b_veloc_elastic(3,npoin))
- allocate(b_accel_elastic(3,npoin))
- allocate(rho_kl(NGLLX,NGLLZ,nspec))
- allocate(rho_k(npoin))
- allocate(rhol_global(npoin))
- allocate(mu_kl(NGLLX,NGLLZ,nspec))
- allocate(mu_k(npoin))
- allocate(mul_global(npoin))
- allocate(kappa_kl(NGLLX,NGLLZ,nspec))
- allocate(kappa_k(npoin))
- allocate(kappal_global(npoin))
- allocate(rhop_kl(NGLLX,NGLLZ,nspec))
- allocate(alpha_kl(NGLLX,NGLLZ,nspec))
- allocate(beta_kl(NGLLX,NGLLZ,nspec))
- allocate(rhorho_el_hessian_final2(NGLLX,NGLLZ,nspec))
- allocate(rhorho_el_hessian_temp2(npoin))
- allocate(rhorho_el_hessian_final1(NGLLX,NGLLZ,nspec))
- allocate(rhorho_el_hessian_temp1(npoin))
- else
- allocate(b_displ_elastic(1,1))
- allocate(b_veloc_elastic(1,1))
- allocate(b_accel_elastic(1,1))
- allocate(rho_kl(1,1,1))
- allocate(rho_k(1))
- allocate(rhol_global(1))
- allocate(mu_kl(1,1,1))
- allocate(mu_k(1))
- allocate(mul_global(1))
- allocate(kappa_kl(1,1,1))
- allocate(kappa_k(1))
- allocate(kappal_global(1))
- allocate(rhop_kl(1,1,1))
- allocate(alpha_kl(1,1,1))
- allocate(beta_kl(1,1,1))
- allocate(rhorho_el_hessian_final2(1,1,1))
- allocate(rhorho_el_hessian_temp2(1))
- allocate(rhorho_el_hessian_final1(1,1,1))
- allocate(rhorho_el_hessian_temp1(1))
- endif
-
- if(any_poroelastic) then
- npoin_poroelastic = npoin
- else
- ! allocate unused arrays with fictitious size
- npoin_poroelastic = 1
- endif
- allocate(displs_poroelastic(NDIM,npoin_poroelastic))
- allocate(velocs_poroelastic(NDIM,npoin_poroelastic))
- allocate(accels_poroelastic(NDIM,npoin_poroelastic))
- allocate(rmass_s_inverse_poroelastic(npoin_poroelastic))
- allocate(displw_poroelastic(NDIM,npoin_poroelastic))
- allocate(velocw_poroelastic(NDIM,npoin_poroelastic))
- allocate(accelw_poroelastic(NDIM,npoin_poroelastic))
- allocate(rmass_w_inverse_poroelastic(npoin_poroelastic))
-
- ! extra array if adjoint and kernels calculation
- if(SIMULATION_TYPE == 2 .and. any_poroelastic) then
- allocate(b_displs_poroelastic(NDIM,npoin))
- allocate(b_velocs_poroelastic(NDIM,npoin))
- allocate(b_accels_poroelastic(NDIM,npoin))
- allocate(b_displw_poroelastic(NDIM,npoin))
- allocate(b_velocw_poroelastic(NDIM,npoin))
- allocate(b_accelw_poroelastic(NDIM,npoin))
- allocate(rhot_kl(NGLLX,NGLLZ,nspec))
- allocate(rhot_k(npoin))
- allocate(rhof_kl(NGLLX,NGLLZ,nspec))
- allocate(rhof_k(npoin))
- allocate(sm_kl(NGLLX,NGLLZ,nspec))
- allocate(sm_k(npoin))
- allocate(eta_kl(NGLLX,NGLLZ,nspec))
- allocate(eta_k(npoin))
- allocate(mufr_kl(NGLLX,NGLLZ,nspec))
- allocate(mufr_k(npoin))
- allocate(B_kl(NGLLX,NGLLZ,nspec))
- allocate(B_k(npoin))
- allocate(C_kl(NGLLX,NGLLZ,nspec))
- allocate(C_k(npoin))
- allocate(M_kl(NGLLX,NGLLZ,nspec))
- allocate(M_k(npoin))
- allocate(rhob_kl(NGLLX,NGLLZ,nspec))
- allocate(rhofb_kl(NGLLX,NGLLZ,nspec))
- allocate(phi_kl(NGLLX,NGLLZ,nspec))
- allocate(Bb_kl(NGLLX,NGLLZ,nspec))
- allocate(Cb_kl(NGLLX,NGLLZ,nspec))
- allocate(Mb_kl(NGLLX,NGLLZ,nspec))
- allocate(mufrb_kl(NGLLX,NGLLZ,nspec))
- allocate(rhobb_kl(NGLLX,NGLLZ,nspec))
- allocate(rhofbb_kl(NGLLX,NGLLZ,nspec))
- allocate(phib_kl(NGLLX,NGLLZ,nspec))
- allocate(cpI_kl(NGLLX,NGLLZ,nspec))
- allocate(cpII_kl(NGLLX,NGLLZ,nspec))
- allocate(cs_kl(NGLLX,NGLLZ,nspec))
- allocate(ratio_kl(NGLLX,NGLLZ,nspec))
- allocate(phil_global(npoin))
- allocate(mulfr_global(npoin))
- allocate(etal_f_global(npoin))
- allocate(rhol_s_global(npoin))
- allocate(rhol_f_global(npoin))
- allocate(rhol_bar_global(npoin))
- allocate(tortl_global(npoin))
- allocate(permlxx_global(npoin))
- allocate(permlxz_global(npoin))
- allocate(permlzz_global(npoin))
- else
- allocate(b_displs_poroelastic(1,1))
- allocate(b_velocs_poroelastic(1,1))
- allocate(b_accels_poroelastic(1,1))
- allocate(b_displw_poroelastic(1,1))
- allocate(b_velocw_poroelastic(1,1))
- allocate(b_accelw_poroelastic(1,1))
- allocate(rhot_kl(1,1,1))
- allocate(rhot_k(1))
- allocate(rhof_kl(1,1,1))
- allocate(rhof_k(1))
- allocate(sm_kl(1,1,1))
- allocate(sm_k(1))
- allocate(eta_kl(1,1,1))
- allocate(eta_k(1))
- allocate(mufr_kl(1,1,1))
- allocate(mufr_k(1))
- allocate(B_kl(1,1,1))
- allocate(B_k(1))
- allocate(C_kl(1,1,1))
- allocate(C_k(1))
- allocate(M_kl(1,1,1))
- allocate(M_k(1))
- allocate(rhob_kl(1,1,1))
- allocate(rhofb_kl(1,1,1))
- allocate(phi_kl(1,1,1))
- allocate(Bb_kl(1,1,1))
- allocate(Cb_kl(1,1,1))
- allocate(Mb_kl(1,1,1))
- allocate(mufrb_kl(1,1,1))
- allocate(rhobb_kl(1,1,1))
- allocate(rhofbb_kl(1,1,1))
- allocate(phib_kl(1,1,1))
- allocate(cpI_kl(1,1,1))
- allocate(cpII_kl(1,1,1))
- allocate(cs_kl(1,1,1))
- allocate(ratio_kl(1,1,1))
- allocate(phil_global(1))
- allocate(mulfr_global(1))
- allocate(etal_f_global(1))
- allocate(rhol_s_global(1))
- allocate(rhol_f_global(1))
- allocate(rhol_bar_global(1))
- allocate(tortl_global(1))
- allocate(permlxx_global(1))
- allocate(permlxz_global(1))
- allocate(permlzz_global(1))
- endif
-
- if(any_poroelastic .and. any_elastic) then
- allocate(icount(npoin))
- else
- allocate(icount(1))
- endif
-
- ! potential, its first and second derivative, and inverse of the mass matrix for acoustic elements
- if(any_acoustic) then
- npoin_acoustic = npoin
- else
- ! allocate unused arrays with fictitious size
- npoin_acoustic = 1
- endif
- allocate(potential_acoustic(npoin_acoustic))
- allocate(potential_dot_acoustic(npoin_acoustic))
- allocate(potential_dot_dot_acoustic(npoin_acoustic))
- allocate(rmass_inverse_acoustic(npoin_acoustic))
-
- if(SIMULATION_TYPE == 2 .and. any_acoustic) then
- allocate(b_potential_acoustic(npoin))
- allocate(b_potential_dot_acoustic(npoin))
- allocate(b_potential_dot_dot_acoustic(npoin))
- allocate(b_displ_ac(2,npoin))
- allocate(b_accel_ac(2,npoin))
- allocate(accel_ac(2,npoin))
- allocate(rho_ac_kl(NGLLX,NGLLZ,nspec))
- allocate(rhol_ac_global(npoin))
- allocate(kappa_ac_kl(NGLLX,NGLLZ,nspec))
- allocate(kappal_ac_global(npoin))
- allocate(rhop_ac_kl(NGLLX,NGLLZ,nspec))
- allocate(alpha_ac_kl(NGLLX,NGLLZ,nspec))
- allocate(rhorho_ac_hessian_final2(NGLLX,NGLLZ,nspec))
- allocate(rhorho_ac_hessian_final1(NGLLX,NGLLZ,nspec))
- else
- ! allocate unused arrays with fictitious size
- allocate(b_potential_acoustic(1))
- allocate(b_potential_dot_acoustic(1))
- allocate(b_potential_dot_dot_acoustic(1))
- allocate(b_displ_ac(1,1))
- allocate(b_accel_ac(1,1))
- allocate(accel_ac(1,1))
- allocate(rho_ac_kl(1,1,1))
- allocate(rhol_ac_global(1))
- allocate(kappa_ac_kl(1,1,1))
- allocate(kappal_ac_global(1))
- allocate(rhop_ac_kl(1,1,1))
- allocate(alpha_ac_kl(1,1,1))
- allocate(rhorho_ac_hessian_final2(1,1,1))
- allocate(rhorho_ac_hessian_final1(1,1,1))
- endif
-
- endif ! ipass == 1
-
- !
- !---- build the global mass matrix
- !
- call invert_mass_matrix_init(any_elastic,any_acoustic,any_poroelastic, &
- rmass_inverse_elastic,npoin_elastic, &
- rmass_inverse_acoustic,npoin_acoustic, &
- rmass_s_inverse_poroelastic, &
- rmass_w_inverse_poroelastic,npoin_poroelastic, &
- nspec,ibool,kmato,wxgll,wzgll,jacobian, &
- elastic,poroelastic, &
- assign_external_model,numat, &
- density,poroelastcoef,porosity,tortuosity, &
- vpext,rhoext)
-
-
-
-#ifdef USE_MPI
- if ( nproc > 1 ) then
-
- ! preparing for MPI communications
- if(ipass == 1) allocate(mask_ispec_inner_outer(nspec))
- mask_ispec_inner_outer(:) = .false.
-
- call get_MPI(nspec,ibool,knods,ngnod,npoin,elastic,poroelastic, &
- ninterface, max_interface_size, &
- my_nelmnts_neighbours,my_interfaces,my_neighbours, &
- ibool_interfaces_acoustic, ibool_interfaces_elastic, &
- ibool_interfaces_poroelastic, &
- nibool_interfaces_acoustic, nibool_interfaces_elastic, &
- nibool_interfaces_poroelastic, &
- inum_interfaces_acoustic, inum_interfaces_elastic, &
- inum_interfaces_poroelastic, &
- ninterface_acoustic, ninterface_elastic, ninterface_poroelastic, &
- mask_ispec_inner_outer, &
- myrank,ipass,coord)
-
-
- nspec_outer = count(mask_ispec_inner_outer)
- nspec_inner = nspec - nspec_outer
-
- if(ipass == 1) then
- allocate(ispec_outer_to_glob(nspec_outer))
- allocate(ispec_inner_to_glob(nspec_inner))
- endif
-
- ! building of corresponding arrays between inner/outer elements and their global number
- if(ipass == 1) then
- num_ispec_outer = 0
- num_ispec_inner = 0
- do ispec = 1, nspec
- if ( mask_ispec_inner_outer(ispec) ) then
- num_ispec_outer = num_ispec_outer + 1
- ispec_outer_to_glob(num_ispec_outer) = ispec
- else
- num_ispec_inner = num_ispec_inner + 1
- ispec_inner_to_glob(num_ispec_inner) = ispec
- endif
- enddo
- endif
-
- ! buffers for MPI communications
- max_ibool_interfaces_size_ac = maxval(nibool_interfaces_acoustic(:))
- max_ibool_interfaces_size_el = 3*maxval(nibool_interfaces_elastic(:))
- max_ibool_interfaces_size_po = NDIM*maxval(nibool_interfaces_poroelastic(:))
- if(ipass == 1) then
- allocate(tab_requests_send_recv_acoustic(ninterface_acoustic*2))
- allocate(buffer_send_faces_vector_ac(max_ibool_interfaces_size_ac,ninterface_acoustic))
- allocate(buffer_recv_faces_vector_ac(max_ibool_interfaces_size_ac,ninterface_acoustic))
- allocate(tab_requests_send_recv_elastic(ninterface_elastic*2))
- allocate(buffer_send_faces_vector_el(max_ibool_interfaces_size_el,ninterface_elastic))
- allocate(buffer_recv_faces_vector_el(max_ibool_interfaces_size_el,ninterface_elastic))
- allocate(tab_requests_send_recv_poro(ninterface_poroelastic*4))
- allocate(buffer_send_faces_vector_pos(max_ibool_interfaces_size_po,ninterface_poroelastic))
- allocate(buffer_recv_faces_vector_pos(max_ibool_interfaces_size_po,ninterface_poroelastic))
- allocate(buffer_send_faces_vector_pow(max_ibool_interfaces_size_po,ninterface_poroelastic))
- allocate(buffer_recv_faces_vector_pow(max_ibool_interfaces_size_po,ninterface_poroelastic))
- endif
-
-! assembling the mass matrix
- call assemble_MPI_scalar(rmass_inverse_acoustic,npoin_acoustic, &
- rmass_inverse_elastic,npoin_elastic, &
- rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic,npoin_poroelastic, &
- ninterface, max_interface_size, max_ibool_interfaces_size_ac, &
- max_ibool_interfaces_size_el, &
- max_ibool_interfaces_size_po, &
- ibool_interfaces_acoustic,ibool_interfaces_elastic, &
- ibool_interfaces_poroelastic, &
- nibool_interfaces_acoustic,nibool_interfaces_elastic, &
- nibool_interfaces_poroelastic,my_neighbours)
-
- else
- ninterface_acoustic = 0
- ninterface_elastic = 0
- ninterface_poroelastic = 0
-
- num_ispec_outer = 0
- num_ispec_inner = 0
- if(ipass == 1) allocate(mask_ispec_inner_outer(1))
-
- nspec_outer = 0
- nspec_inner = nspec
-
- if(ipass == 1) allocate(ispec_inner_to_glob(nspec_inner))
- do ispec = 1, nspec
- ispec_inner_to_glob(ispec) = ispec
- enddo
-
- endif ! end of test on wether there is more than one process (nproc > 1)
-
-#else
- num_ispec_outer = 0
- num_ispec_inner = 0
- if(ipass == 1) allocate(mask_ispec_inner_outer(1))
-
- nspec_outer = 0
- nspec_inner = nspec
-
- if(ipass == 1) then
- allocate(ispec_outer_to_glob(1))
- allocate(ispec_inner_to_glob(nspec_inner))
- endif
- do ispec = 1, nspec
- ispec_inner_to_glob(ispec) = ispec
- enddo
-
-#endif
-
- if(ipass == 1) then
-
- ! allocate(antecedent_list(nspec))
-
- ! loop over spectral elements
- do ispec_outer = 1,nspec_outer
- ! get global numbering for inner or outer elements
- ispec = ispec_outer_to_glob(ispec_outer)
- antecedent_list(ispec) = ispec_outer
- enddo
-
- ! loop over spectral elements
- do ispec_inner = 1,nspec_inner
- ! get global numbering for inner or outer elements
- ispec = ispec_inner_to_glob(ispec_inner)
- antecedent_list(ispec) = nspec_outer + ispec_inner
- enddo
-
- allocate(ibool_outer(NGLLX,NGLLZ,nspec_outer))
- allocate(ibool_inner(NGLLX,NGLLZ,nspec_inner))
-
- ! loop over spectral elements
- do ispec_outer = 1,nspec_outer
- ! get global numbering for inner or outer elements
- ispec = ispec_outer_to_glob(ispec_outer)
- ibool_outer(:,:,ispec_outer) = ibool(:,:,ispec)
- enddo
-
- ! loop over spectral elements
- do ispec_inner = 1,nspec_inner
- ! get global numbering for inner or outer elements
- ispec = ispec_inner_to_glob(ispec_inner)
- ibool_inner(:,:,ispec_inner) = ibool(:,:,ispec)
- enddo
-
- allocate(copy_ibool_ori(NGLLX,NGLLZ,nspec_outer))
- allocate(mask_ibool(npoin))
-
- mask_ibool(:) = -1
- copy_ibool_ori(:,:,:) = ibool_outer(:,:,:)
-
- inumber = 0
-
- do ispec = 1,nspec_outer
- do j=1,NGLLZ
- do i=1,NGLLX
- if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
- ! create a new point
- inumber = inumber + 1
- ibool_outer(i,j,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
- else
- ! use an existing point created previously
- ibool_outer(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
- endif
- enddo
- enddo
- enddo
-
- deallocate(copy_ibool_ori)
- deallocate(mask_ibool)
-
- ! the total number of points without multiples in this region is now known
- npoin_outer = maxval(ibool_outer)
-
- allocate(copy_ibool_ori(NGLLX,NGLLZ,nspec_inner))
- allocate(mask_ibool(npoin))
-
- mask_ibool(:) = -1
- copy_ibool_ori(:,:,:) = ibool_inner(:,:,:)
-
- inumber = 0
-
- do ispec = 1,nspec_inner
- do j=1,NGLLZ
- do i=1,NGLLX
- if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
- ! create a new point
- inumber = inumber + 1
- ibool_inner(i,j,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
- else
- ! use an existing point created previously
- ibool_inner(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
- endif
- enddo
- enddo
- enddo
-
- deallocate(copy_ibool_ori)
- deallocate(mask_ibool)
-
- ! the total number of points without multiples in this region is now known
- npoin_inner = maxval(ibool_inner)
-
- !allocate(perm(nspec))
-
- ! use identity permutation by default
- do ispec = 1,nspec
- perm(ispec) = ispec
- enddo
-
- if(ACTUALLY_IMPLEMENT_PERM_WHOLE) then
-
- allocate(check_perm(nspec))
- call get_perm(ibool,perm,LIMIT_MULTI_CUTHILL,nspec,npoin)
- ! check that the permutation obtained is bijective
- check_perm(:) = -1
- do ispec = 1,nspec
- check_perm(perm(ispec)) = ispec
- enddo
- if(minval(check_perm) /= 1) stop 'minval check_perm is incorrect for whole'
- if(maxval(check_perm) /= nspec) stop 'maxval check_perm is incorrect for whole'
- deallocate(check_perm)
- else
-
- if(ACTUALLY_IMPLEMENT_PERM_OUT) then
- allocate(check_perm(nspec_outer))
- call get_perm(ibool_outer,perm(1:nspec_outer),LIMIT_MULTI_CUTHILL,nspec_outer,npoin_outer)
- ! check that the permutation obtained is bijective
- check_perm(:) = -1
- do ispec = 1,nspec_outer
- check_perm(perm(ispec)) = ispec
- enddo
- if(minval(check_perm) /= 1) stop 'minval check_perm is incorrect for outer'
- if(maxval(check_perm) /= nspec_outer) stop 'maxval check_perm is incorrect for outer'
- deallocate(check_perm)
- deallocate(ibool_outer)
- endif
-
- if(ACTUALLY_IMPLEMENT_PERM_INN) then
- allocate(check_perm(nspec_inner))
- call get_perm(ibool_inner,perm(nspec_outer+1:nspec),LIMIT_MULTI_CUTHILL,nspec_inner,npoin_inner)
- ! check that the permutation obtained is bijective
- check_perm(:) = -1
- do ispec = 1,nspec_inner
- check_perm(perm(nspec_outer+ispec)) = ispec
- enddo
- if(minval(check_perm) /= 1) stop 'minval check_perm is incorrect for inner'
- if(maxval(check_perm) /= nspec_inner) stop 'maxval check_perm is incorrect for inner'
- deallocate(check_perm)
- ! add the right offset
- perm(nspec_outer+1:nspec) = perm(nspec_outer+1:nspec) + nspec_outer
- deallocate(ibool_inner)
- endif
-
- endif
-
- endif
-
- enddo ! end of further reduction of cache misses inner/outer in two passes
-
-!============================================
-!
-! end inner/outer passes
-!
-!============================================
-
-!---
-!--- end of section performed in two passes
-!---
-
- call invert_mass_matrix(any_elastic,any_acoustic,any_poroelastic,&
- rmass_inverse_elastic,npoin_elastic, &
- rmass_inverse_acoustic,npoin_acoustic, &
- rmass_s_inverse_poroelastic, &
- rmass_w_inverse_poroelastic,npoin_poroelastic)
-
-! check the mesh, stability and number of points per wavelength
- if(DISPLAY_SUBSET_OPTION == 1) then
- UPPER_LIMIT_DISPLAY = nspec
- else if(DISPLAY_SUBSET_OPTION == 2) then
- UPPER_LIMIT_DISPLAY = nspec_inner
- else if(DISPLAY_SUBSET_OPTION == 3) then
- UPPER_LIMIT_DISPLAY = nspec_outer
- else if(DISPLAY_SUBSET_OPTION == 4) then
- UPPER_LIMIT_DISPLAY = NSPEC_DISPLAY_SUBSET
- else
- stop 'incorrect value of DISPLAY_SUBSET_OPTION'
- endif
- call checkgrid(vpext,vsext,rhoext,density,poroelastcoef, &
- porosity,tortuosity,permeability,ibool,kmato, &
- coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
- assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat, &
- f0,initialfield,time_function_type, &
- coorg,xinterp,zinterp,shape2D_display,knods,simulation_title, &
- npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,all_anisotropic, &
- myrank,nproc,NSOURCES,poroelastic, &
- freq0,Q0,TURN_VISCATTENUATION_ON)
-
-! convert receiver angle to radians
- anglerec = anglerec * pi / 180.d0
-
-!
-!---- for color images
-!
-
- if(output_color_image) then
- ! prepares dimension of image
- call prepare_color_image_init(NX_IMAGE_color,NZ_IMAGE_color, &
- xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image, &
- coord,npoin,npgeo)
-
- ! allocate an array for image data
- allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color))
- allocate(image_color_vp_display(NX_IMAGE_color,NZ_IMAGE_color))
-
- ! allocate an array for the grid point that corresponds to a given image data point
- allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
- allocate(copy_iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
-
- ! creates pixels indexing
- call prepare_color_image_pixels(myrank,NX_IMAGE_color,NZ_IMAGE_color, &
- xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image, &
- coord,npoin,coorg,npgeo,nspec,ngnod,knods,ibool, &
- nb_pixel_loc,iglob_image_color)
-
-
- ! creating and filling array num_pixel_loc with the positions of each colored
- ! pixel owned by the local process (useful for parallel jobs)
- allocate(num_pixel_loc(nb_pixel_loc))
-
- nb_pixel_loc = 0
- do i = 1, NX_IMAGE_color
- do j = 1, NZ_IMAGE_color
- if ( iglob_image_color(i,j) /= -1 ) then
- nb_pixel_loc = nb_pixel_loc + 1
- num_pixel_loc(nb_pixel_loc) = (j-1)*NX_IMAGE_color + i
- endif
- enddo
- enddo
-
-! filling array iglob_image_color, containing info on which process owns which pixels.
-#ifdef USE_MPI
- allocate(nb_pixel_per_proc(nproc))
-
- call MPI_GATHER( nb_pixel_loc, 1, MPI_INTEGER, nb_pixel_per_proc(1), &
- 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ier)
-
- if ( myrank == 0 ) then
- allocate(num_pixel_recv(maxval(nb_pixel_per_proc(:)),nproc))
- allocate(data_pixel_recv(maxval(nb_pixel_per_proc(:))))
- endif
-
- allocate(data_pixel_send(nb_pixel_loc))
- if (nproc > 1) then
- if (myrank == 0) then
-
- do iproc = 1, nproc-1
-
- call MPI_RECV(num_pixel_recv(1,iproc+1),nb_pixel_per_proc(iproc+1), MPI_INTEGER, &
- iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- do k = 1, nb_pixel_per_proc(iproc+1)
- j = ceiling(real(num_pixel_recv(k,iproc+1)) / real(NX_IMAGE_color))
- i = num_pixel_recv(k,iproc+1) - (j-1)*NX_IMAGE_color
- iglob_image_color(i,j) = iproc
-
- enddo
- enddo
-
- else
- call MPI_SEND(num_pixel_loc(1),nb_pixel_loc,MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- endif
- endif
-#endif
-
- if (myrank == 0) write(IOUT,*) 'done locating all the pixels of color images'
-
- endif ! color_image
-
-!
-!---- initialize seismograms
-!
- sisux = ZERO ! double precision zero
- sisuz = ZERO
-
-! initialize arrays to zero
- displ_elastic = 0._CUSTOM_REAL
- veloc_elastic = 0._CUSTOM_REAL
- accel_elastic = 0._CUSTOM_REAL
-
- displs_poroelastic = 0._CUSTOM_REAL
- velocs_poroelastic = 0._CUSTOM_REAL
- accels_poroelastic = 0._CUSTOM_REAL
- displw_poroelastic = 0._CUSTOM_REAL
- velocw_poroelastic = 0._CUSTOM_REAL
- accelw_poroelastic = 0._CUSTOM_REAL
-
- potential_acoustic = 0._CUSTOM_REAL
- potential_dot_acoustic = 0._CUSTOM_REAL
- potential_dot_dot_acoustic = 0._CUSTOM_REAL
-
-!
-!----- Files where viscous damping are saved during forward wavefield calculation
-!
- if(any_poroelastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE .eq. 2)) then
- allocate(b_viscodampx(npoin))
- allocate(b_viscodampz(npoin))
- write(outputname,'(a,i6.6,a)') 'viscodampingx',myrank,'.bin'
- write(outputname2,'(a,i6.6,a)') 'viscodampingz',myrank,'.bin'
- if(SIMULATION_TYPE == 2) then
- reclen = CUSTOM_REAL * npoin
- open(unit=23,file='OUTPUT_FILES/'//outputname,status='old',&
- action='read',form='unformatted',access='direct',&
- recl=reclen)
- open(unit=24,file='OUTPUT_FILES/'//outputname2,status='old',&
- action='read',form='unformatted',access='direct',&
- recl=reclen)
- else
- reclen = CUSTOM_REAL * npoin
- open(unit=23,file='OUTPUT_FILES/'//outputname,status='unknown',&
- form='unformatted',access='direct',&
- recl=reclen)
- open(unit=24,file='OUTPUT_FILES/'//outputname2,status='unknown',&
- form='unformatted',access='direct',&
- recl=reclen)
- endif
- else
- allocate(b_viscodampx(1))
- allocate(b_viscodampz(1))
- endif
-
-!
-!----- Files where absorbing signal are saved during forward wavefield calculation
-!
-
- if( ((SAVE_FORWARD .and. SIMULATION_TYPE ==1) .or. SIMULATION_TYPE == 2) .and. anyabs ) then
- ! opens files for absorbing boundary data
- call prepare_absorb_files(myrank,any_elastic,any_poroelastic,any_acoustic, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,SIMULATION_TYPE)
- endif
-
- if(anyabs .and. SIMULATION_TYPE == 2) then
-
- ! reads in absorbing bounday data
- if(any_elastic) then
- call prepare_absorb_elastic(NSTEP,p_sv, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_elastic_left,b_absorb_elastic_right, &
- b_absorb_elastic_bottom,b_absorb_elastic_top)
-
- endif
- if(any_poroelastic) then
- call prepare_absorb_poroelastic(NSTEP, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_poro_s_left,b_absorb_poro_w_left, &
- b_absorb_poro_s_right,b_absorb_poro_w_right, &
- b_absorb_poro_s_bottom,b_absorb_poro_w_bottom, &
- b_absorb_poro_s_top,b_absorb_poro_w_top)
-
- endif
- if(any_acoustic) then
- call prepare_absorb_acoustic(NSTEP, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
- b_absorb_acoustic_left,b_absorb_acoustic_right, &
- b_absorb_acoustic_bottom,b_absorb_acoustic_top)
- endif
-
- endif ! if(anyabs .and. SIMULATION_TYPE == 2)
-
-
-
-!
-!----- Read last frame for backward wavefield calculation
-!
-
- if(SIMULATION_TYPE == 2) then
-
- if(any_elastic) then
- write(outputname,'(a,i6.6,a)') 'snapshot_rho_kappa_mu_',myrank
- open(unit = 97, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_rhop_alpha_beta_',myrank
- open(unit = 98, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
-
- rho_kl(:,:,:) = 0._CUSTOM_REAL
- mu_kl(:,:,:) = 0._CUSTOM_REAL
- kappa_kl(:,:,:) = 0._CUSTOM_REAL
-
- rhop_kl(:,:,:) = 0._CUSTOM_REAL
- beta_kl(:,:,:) = 0._CUSTOM_REAL
- alpha_kl(:,:,:) = 0._CUSTOM_REAL
- rhorho_el_hessian_final2(:,:,:) = 0._CUSTOM_REAL
- rhorho_el_hessian_temp2(:) = 0._CUSTOM_REAL
- rhorho_el_hessian_final1(:,:,:) = 0._CUSTOM_REAL
- rhorho_el_hessian_temp1(:) = 0._CUSTOM_REAL
- endif
-
- if(any_poroelastic) then
-
- ! Primary kernels
- write(outputname,'(a,i6.6,a)') 'snapshot_mu_B_C_',myrank
- open(unit = 144, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_M_rho_rhof_',myrank
- open(unit = 155, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_m_eta_',myrank
- open(unit = 16, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- ! Wavespeed kernels
- write(outputname,'(a,i6.6,a)') 'snapshot_cpI_cpII_cs_',myrank
- open(unit = 20, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_rhobb_rhofbb_ratio_',myrank
- open(unit = 21, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_phib_eta_',myrank
- open(unit = 22, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- ! Density normalized kernels
- write(outputname,'(a,i6.6,a)') 'snapshot_mub_Bb_Cb_',myrank
- open(unit = 17, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_Mb_rhob_rhofb_',myrank
- open(unit = 18, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_mb_etab_',myrank
- open(unit = 19, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
-
- rhot_kl(:,:,:) = 0._CUSTOM_REAL
- rhof_kl(:,:,:) = 0._CUSTOM_REAL
- eta_kl(:,:,:) = 0._CUSTOM_REAL
- sm_kl(:,:,:) = 0._CUSTOM_REAL
- mufr_kl(:,:,:) = 0._CUSTOM_REAL
- B_kl(:,:,:) = 0._CUSTOM_REAL
- C_kl(:,:,:) = 0._CUSTOM_REAL
- M_kl(:,:,:) = 0._CUSTOM_REAL
-
- rhob_kl(:,:,:) = 0._CUSTOM_REAL
- rhofb_kl(:,:,:) = 0._CUSTOM_REAL
- phi_kl(:,:,:) = 0._CUSTOM_REAL
- mufrb_kl(:,:,:) = 0._CUSTOM_REAL
- Bb_kl(:,:,:) = 0._CUSTOM_REAL
- Cb_kl(:,:,:) = 0._CUSTOM_REAL
- Mb_kl(:,:,:) = 0._CUSTOM_REAL
-
- rhobb_kl(:,:,:) = 0._CUSTOM_REAL
- rhofbb_kl(:,:,:) = 0._CUSTOM_REAL
- phib_kl(:,:,:) = 0._CUSTOM_REAL
- cs_kl(:,:,:) = 0._CUSTOM_REAL
- cpI_kl(:,:,:) = 0._CUSTOM_REAL
- cpII_kl(:,:,:) = 0._CUSTOM_REAL
- ratio_kl(:,:,:) = 0._CUSTOM_REAL
- endif
-
- if(any_acoustic) then
- write(outputname,'(a,i6.6,a)') 'snapshot_rho_kappa_',myrank
- open(unit = 95, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
- write(outputname,'(a,i6.6,a)') 'snapshot_rhop_c_',myrank
- open(unit = 96, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
- if (ios /= 0) stop 'Error writing snapshot to disk'
-
- rho_ac_kl(:,:,:) = 0._CUSTOM_REAL
- kappa_ac_kl(:,:,:) = 0._CUSTOM_REAL
-
- rhop_ac_kl(:,:,:) = 0._CUSTOM_REAL
- alpha_ac_kl(:,:,:) = 0._CUSTOM_REAL
- rhorho_ac_hessian_final2(:,:,:) = 0._CUSTOM_REAL
- rhorho_ac_hessian_final1(:,:,:) = 0._CUSTOM_REAL
- endif
-
- endif ! if(SIMULATION_TYPE == 2)
-
-!
-!---- read initial fields from external file if needed
-!
-
-! if we are looking a plane wave beyond critical angle we use other method
- over_critical_angle = .false.
-
- if(initialfield) then
-
- ! Calculation of the initial field for a plane wave
- if( any_elastic ) then
- call prepare_initialfield(myrank,any_acoustic,any_poroelastic,over_critical_angle, &
- NSOURCES,source_type,angleforce,x_source,z_source,f0, &
- npoin,numat,poroelastcoef,density,coord, &
- angleforce_refl,c_inc,c_refl,cploc,csloc,time_offset, &
- A_plane, B_plane, C_plane, &
- accel_elastic,veloc_elastic,displ_elastic)
- endif
-
- if( over_critical_angle ) then
-
- allocate(left_bound(nelemabs*NGLLX))
- allocate(right_bound(nelemabs*NGLLX))
- allocate(bot_bound(nelemabs*NGLLZ))
-
- call prepare_initialfield_paco(myrank,nelemabs,left_bound,right_bound,bot_bound, &
- numabs,codeabs,ibool,nspec, &
- source_type,NSOURCES,c_inc,c_refl, &
- count_bottom,count_left,count_right)
-
- allocate(v0x_left(count_left,NSTEP))
- allocate(v0z_left(count_left,NSTEP))
- allocate(t0x_left(count_left,NSTEP))
- allocate(t0z_left(count_left,NSTEP))
-
- allocate(v0x_right(count_right,NSTEP))
- allocate(v0z_right(count_right,NSTEP))
- allocate(t0x_right(count_right,NSTEP))
- allocate(t0z_right(count_right,NSTEP))
-
- allocate(v0x_bot(count_bottom,NSTEP))
- allocate(v0z_bot(count_bottom,NSTEP))
- allocate(t0x_bot(count_bottom,NSTEP))
- allocate(t0z_bot(count_bottom,NSTEP))
-
- allocate(displ_paco(NDIM,npoin))
- allocate(veloc_paco(NDIM,npoin))
- allocate(accel_paco(NDIM,npoin))
-
- ! call Paco's routine to compute in frequency and convert to time by Fourier transform
- call paco_beyond_critical(coord,npoin,deltat,NSTEP,angleforce(1),&
- f0(1),cploc,csloc,TURN_ATTENUATION_ON,Qp_attenuation,source_type(1),v0x_left,v0z_left,&
- v0x_right,v0z_right,v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,&
- t0x_bot,t0z_bot,left_bound(1:count_left),right_bound(1:count_right),bot_bound(1:count_bottom)&
- ,count_left,count_right,count_bottom,displ_paco,veloc_paco,accel_paco)
-
- displ_elastic(1,:) = displ_paco(1,:)
- displ_elastic(3,:) = displ_paco(2,:)
- veloc_elastic(1,:) = veloc_paco(1,:)
- veloc_elastic(3,:) = veloc_paco(2,:)
- accel_elastic(1,:) = accel_paco(1,:)
- accel_elastic(3,:) = accel_paco(2,:)
-
- deallocate(left_bound)
- deallocate(right_bound)
- deallocate(bot_bound)
-
- deallocate(displ_paco)
- deallocate(veloc_paco)
- deallocate(accel_paco)
-
- if (myrank == 0) then
- write(IOUT,*) '***********'
- write(IOUT,*) 'done calculating the initial wave field'
- write(IOUT,*) '***********'
- endif
-
- endif ! beyond critical angle
-
- write(IOUT,*) 'Max norm of initial elastic displacement = ', &
- maxval(sqrt(displ_elastic(1,:)**2 + displ_elastic(3,:)**2))
-
- endif ! initialfield
-
- deltatsquare = deltat * deltat
- deltatcube = deltatsquare * deltat
- deltatfourth = deltatsquare * deltatsquare
-
- twelvedeltat = 12.d0 * deltat
- fourdeltatsquare = 4.d0 * deltatsquare
-
-! compute the source time function and store it in a text file
- if(.not. initialfield) then
-
- allocate(source_time_function(NSOURCES,NSTEP))
- source_time_function(:,:) = 0._CUSTOM_REAL
-
- ! computes source time function array
- call prepare_source_time_function(myrank,NSTEP,NSOURCES,source_time_function, &
- time_function_type,f0,tshift_src,factor,aval, &
- t0,nb_proc_source,deltat)
- else
- ! uses an initialfield
- ! dummy allocation
- allocate(source_time_function(1,1))
- endif
-
-! determine if coupled fluid-solid simulation
- coupled_acoustic_elastic = any_acoustic .and. any_elastic
- coupled_acoustic_poro = any_acoustic .and. any_poroelastic
-
-! fluid/solid (elastic) edge detection
-! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
-! the common nodes forming the edge are computed here
- if(coupled_acoustic_elastic) then
-
- if (myrank == 0) then
- print *
- print *,'Mixed acoustic/elastic simulation'
- print *
- print *,'Beginning of fluid/solid edge detection'
- endif
-
-! define the edges of a given element
- i_begin(IBOTTOM) = 1
- j_begin(IBOTTOM) = 1
- i_end(IBOTTOM) = NGLLX
- j_end(IBOTTOM) = 1
-
- i_begin(IRIGHT) = NGLLX
- j_begin(IRIGHT) = 1
- i_end(IRIGHT) = NGLLX
- j_end(IRIGHT) = NGLLZ
-
- i_begin(ITOP) = NGLLX
- j_begin(ITOP) = NGLLZ
- i_end(ITOP) = 1
- j_end(ITOP) = NGLLZ
-
- i_begin(ILEFT) = 1
- j_begin(ILEFT) = NGLLZ
- i_end(ILEFT) = 1
- j_end(ILEFT) = 1
-
-! define i and j points for each edge
- do ipoin1D = 1,NGLLX
-
- ivalue(ipoin1D,IBOTTOM) = ipoin1D
- ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
- jvalue(ipoin1D,IBOTTOM) = 1
- jvalue_inverse(ipoin1D,IBOTTOM) = 1
-
- ivalue(ipoin1D,IRIGHT) = NGLLX
- ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
- jvalue(ipoin1D,IRIGHT) = ipoin1D
- jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
-
- ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
- ivalue_inverse(ipoin1D,ITOP) = ipoin1D
- jvalue(ipoin1D,ITOP) = NGLLZ
- jvalue_inverse(ipoin1D,ITOP) = NGLLZ
-
- ivalue(ipoin1D,ILEFT) = 1
- ivalue_inverse(ipoin1D,ILEFT) = 1
- jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
- jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
-
- enddo
-
- do inum = 1, num_fluid_solid_edges
- ispec_acoustic = fluid_solid_acoustic_ispec(inum)
- ispec_elastic = fluid_solid_elastic_ispec(inum)
-
-! one element must be acoustic and the other must be elastic
- if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. &
- .not. poroelastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
-
-! loop on the four edges of the two elements
- do iedge_acoustic = 1,NEDGES
- do iedge_elastic = 1,NEDGES
-
-! store the matching topology if the two edges match in inverse order
- if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
- ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
- ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
- ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
- fluid_solid_acoustic_iedge(inum) = iedge_acoustic
- fluid_solid_elastic_iedge(inum) = iedge_elastic
-! print *,'edge ',iedge_acoustic,' of acoustic element ',ispec_acoustic, &
-! ' is in contact with edge ',iedge_elastic,' of elastic element ',ispec_elastic
- endif
-
- enddo
- enddo
-
- endif
-
- enddo
-
-! make sure fluid/solid (elastic) matching has been perfectly detected: check that the grid points
-! have the same physical coordinates
-! loop on all the coupling edges
-
- if(myrank == 0) print *,'Checking fluid/solid edge topology...'
-
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_solid_acoustic_ispec(inum)
- iedge_acoustic = fluid_solid_acoustic_iedge(inum)
-
-! get the corresponding edge of the elastic element
- ispec_elastic = fluid_solid_elastic_ispec(inum)
- iedge_elastic = fluid_solid_elastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the elastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_elastic)
- j = jvalue_inverse(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
-! get point values for the acoustic side
- i = ivalue(ipoin1D,iedge_acoustic)
- j = jvalue(ipoin1D,iedge_acoustic)
- iglob2 = ibool(i,j,ispec_acoustic)
-
-! if distance between the two points is not negligible, there is an error, since it should be zero
- if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
- call exit_MPI( 'error in fluid/solid coupling buffer')
-
- enddo
-
- enddo
-
- if (myrank == 0) then
- print *,'End of fluid/solid edge detection'
- print *
- endif
-
- endif
-
-! fluid/solid (poroelastic) edge detection
-! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
-! the common nodes forming the edge are computed here
- if(coupled_acoustic_poro) then
- if ( myrank == 0 ) then
- print *
- print *,'Mixed acoustic/poroelastic simulation'
- print *
- print *,'Beginning of fluid/solid (poroelastic) edge detection'
- endif
-
-! define the edges of a given element
- i_begin(IBOTTOM) = 1
- j_begin(IBOTTOM) = 1
- i_end(IBOTTOM) = NGLLX
- j_end(IBOTTOM) = 1
-
- i_begin(IRIGHT) = NGLLX
- j_begin(IRIGHT) = 1
- i_end(IRIGHT) = NGLLX
- j_end(IRIGHT) = NGLLZ
-
- i_begin(ITOP) = NGLLX
- j_begin(ITOP) = NGLLZ
- i_end(ITOP) = 1
- j_end(ITOP) = NGLLZ
-
- i_begin(ILEFT) = 1
- j_begin(ILEFT) = NGLLZ
- i_end(ILEFT) = 1
- j_end(ILEFT) = 1
-
-! define i and j points for each edge
- do ipoin1D = 1,NGLLX
-
- ivalue(ipoin1D,IBOTTOM) = ipoin1D
- ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
- jvalue(ipoin1D,IBOTTOM) = 1
- jvalue_inverse(ipoin1D,IBOTTOM) = 1
-
- ivalue(ipoin1D,IRIGHT) = NGLLX
- ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
- jvalue(ipoin1D,IRIGHT) = ipoin1D
- jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
-
- ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
- ivalue_inverse(ipoin1D,ITOP) = ipoin1D
- jvalue(ipoin1D,ITOP) = NGLLZ
- jvalue_inverse(ipoin1D,ITOP) = NGLLZ
-
- ivalue(ipoin1D,ILEFT) = 1
- ivalue_inverse(ipoin1D,ILEFT) = 1
- jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
- jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
-
- enddo
-
- do inum = 1, num_fluid_poro_edges
- ispec_acoustic = fluid_poro_acoustic_ispec(inum)
- ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
-
-! one element must be acoustic and the other must be poroelastic
- if(ispec_acoustic /= ispec_poroelastic .and. .not. poroelastic(ispec_acoustic) .and. &
- .not. elastic(ispec_acoustic) .and. poroelastic(ispec_poroelastic)) then
-
-! loop on the four edges of the two elements
- do iedge_acoustic = 1,NEDGES
- do iedge_poroelastic = 1,NEDGES
-
-! store the matching topology if the two edges match in inverse order
- if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
- ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) .and. &
- ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
- ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic)) then
- fluid_poro_acoustic_iedge(inum) = iedge_acoustic
- fluid_poro_poroelastic_iedge(inum) = iedge_poroelastic
- endif
-
- enddo
- enddo
-
- endif
-
- enddo
-
-
-! make sure fluid/solid (poroelastic) matching has been perfectly detected: check that the grid points
-! have the same physical coordinates
-! loop on all the coupling edges
-
- if ( myrank == 0 ) then
- print *,'Checking fluid/solid (poroelastic) edge topology...'
- endif
-
- do inum = 1,num_fluid_poro_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_poro_acoustic_ispec(inum)
- iedge_acoustic = fluid_poro_acoustic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the poroelastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_poroelastic)
- j = jvalue_inverse(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
-
-! get point values for the acoustic side
- i = ivalue(ipoin1D,iedge_acoustic)
- j = jvalue(ipoin1D,iedge_acoustic)
- iglob2 = ibool(i,j,ispec_acoustic)
-
-! if distance between the two points is not negligible, there is an error, since it should be zero
- if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
- call exit_MPI( 'error in fluid/solid (poroelastic) coupling buffer')
-
- enddo
-
- enddo
-
- if ( myrank == 0 ) then
- print *,'End of fluid/solid (poroelastic) edge detection'
- print *
- endif
-
- endif
-
-! exclude common points between acoustic absorbing edges and acoustic/elastic matching interfaces
- if(coupled_acoustic_elastic .and. anyabs) then
-
- if (myrank == 0) &
- print *,'excluding common points between acoustic absorbing edges and acoustic/elastic matching interfaces, if any'
-
-! loop on all the absorbing elements
- do ispecabs = 1,nelemabs
-
- ispec = numabs(ispecabs)
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_solid_acoustic_ispec(inum)
- iedge_acoustic = fluid_solid_acoustic_iedge(inum)
-
-! if acoustic absorbing element and acoustic/elastic coupled element is the same
- if(ispec_acoustic == ispec) then
-
- if(iedge_acoustic == IBOTTOM) then
- jbegin_left(ispecabs) = 2
- jbegin_right(ispecabs) = 2
- endif
-
- if(iedge_acoustic == ITOP) then
- jend_left(ispecabs) = NGLLZ - 1
- jend_right(ispecabs) = NGLLZ - 1
- endif
-
- if(iedge_acoustic == ILEFT) then
- ibegin_bottom(ispecabs) = 2
- ibegin_top(ispecabs) = 2
- endif
-
- if(iedge_acoustic == IRIGHT) then
- iend_bottom(ispecabs) = NGLLX - 1
- iend_top(ispecabs) = NGLLX - 1
- endif
-
- endif
-
- enddo
-
- enddo
-
- endif
-
-! exclude common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces
- if(coupled_acoustic_poro .and. anyabs) then
-
- if (myrank == 0) &
- print *,'excluding common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces, if any'
-
-! loop on all the absorbing elements
- do ispecabs = 1,nelemabs
-
- ispec = numabs(ispecabs)
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_poro_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_poro_acoustic_ispec(inum)
- iedge_acoustic = fluid_poro_acoustic_iedge(inum)
-
-! if acoustic absorbing element and acoustic/poroelastic coupled element is the same
- if(ispec_acoustic == ispec) then
-
- if(iedge_acoustic == IBOTTOM) then
- jbegin_left(ispecabs) = 2
- jbegin_right(ispecabs) = 2
- endif
-
- if(iedge_acoustic == ITOP) then
- jend_left(ispecabs) = NGLLZ - 1
- jend_right(ispecabs) = NGLLZ - 1
- endif
-
- if(iedge_acoustic == ILEFT) then
- ibegin_bottom(ispecabs) = 2
- ibegin_top(ispecabs) = 2
- endif
-
- if(iedge_acoustic == IRIGHT) then
- iend_bottom(ispecabs) = NGLLX - 1
- iend_top(ispecabs) = NGLLX - 1
- endif
-
- endif
-
- enddo
-
- enddo
-
- endif
-
-
-! determine if coupled elastic-poroelastic simulation
- coupled_elastic_poro = any_elastic .and. any_poroelastic
-
-! solid/porous edge detection
-! the two elements forming an edge are already known (computed in meshfem2D),
-! the common nodes forming the edge are computed here
- if(coupled_elastic_poro) then
-
- if(TURN_ATTENUATION_ON .or. TURN_VISCATTENUATION_ON) &
- stop 'Attenuation not supported for mixed elastic/poroelastic simulations'
-
- if ( myrank == 0 ) then
- print *
- print *,'Mixed elastic/poroelastic simulation'
- print *
- print *,'Beginning of solid/porous edge detection'
- endif
-
-! define the edges of a given element
- i_begin(IBOTTOM) = 1
- j_begin(IBOTTOM) = 1
- i_end(IBOTTOM) = NGLLX
- j_end(IBOTTOM) = 1
-
- i_begin(IRIGHT) = NGLLX
- j_begin(IRIGHT) = 1
- i_end(IRIGHT) = NGLLX
- j_end(IRIGHT) = NGLLZ
-
- i_begin(ITOP) = NGLLX
- j_begin(ITOP) = NGLLZ
- i_end(ITOP) = 1
- j_end(ITOP) = NGLLZ
-
- i_begin(ILEFT) = 1
- j_begin(ILEFT) = NGLLZ
- i_end(ILEFT) = 1
- j_end(ILEFT) = 1
-
-! define i and j points for each edge
- do ipoin1D = 1,NGLLX
-
- ivalue(ipoin1D,IBOTTOM) = ipoin1D
- ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
- jvalue(ipoin1D,IBOTTOM) = 1
- jvalue_inverse(ipoin1D,IBOTTOM) = 1
-
- ivalue(ipoin1D,IRIGHT) = NGLLX
- ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
- jvalue(ipoin1D,IRIGHT) = ipoin1D
- jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
-
- ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
- ivalue_inverse(ipoin1D,ITOP) = ipoin1D
- jvalue(ipoin1D,ITOP) = NGLLZ
- jvalue_inverse(ipoin1D,ITOP) = NGLLZ
-
- ivalue(ipoin1D,ILEFT) = 1
- ivalue_inverse(ipoin1D,ILEFT) = 1
- jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
- jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
-
- enddo
-
-
- do inum = 1, num_solid_poro_edges
- ispec_elastic = solid_poro_elastic_ispec(inum)
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
-
-! one element must be elastic and the other must be poroelastic
- if(ispec_elastic /= ispec_poroelastic .and. elastic(ispec_elastic) .and. &
- poroelastic(ispec_poroelastic)) then
-
-! loop on the four edges of the two elements
- do iedge_poroelastic = 1,NEDGES
- do iedge_elastic = 1,NEDGES
-
-! store the matching topology if the two edges match in inverse order
- if(ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic) == &
- ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
- ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) == &
- ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
- solid_poro_elastic_iedge(inum) = iedge_elastic
- solid_poro_poroelastic_iedge(inum) = iedge_poroelastic
- endif
-
- enddo
- enddo
-
- endif
-
- enddo
-
-! make sure solid/porous matching has been perfectly detected: check that the grid points
-! have the same physical coordinates
-! loop on all the coupling edges
-
- if ( myrank == 0 ) then
- print *,'Checking solid/porous edge topology...'
- endif
-
- do inum = 1,num_solid_poro_edges
-
-! get the edge of the elastic element
- ispec_elastic = solid_poro_elastic_ispec(inum)
- iedge_elastic = solid_poro_elastic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the poroelastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_elastic)
- j = jvalue_inverse(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
-! get point values for the elastic side
- i = ivalue(ipoin1D,iedge_poroelastic)
- j = jvalue(ipoin1D,iedge_poroelastic)
- iglob2 = ibool(i,j,ispec_poroelastic)
-
-! if distance between the two points is not negligible, there is an error, since it should be zero
- if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
- call exit_MPI( 'error in solid/porous coupling buffer')
-
- enddo
-
- enddo
-
- if ( myrank == 0 ) then
- print *,'End of solid/porous edge detection'
- print *
- endif
-
- endif
-
-! initiation
- if(any_poroelastic .and. anyabs) then
-! loop on all the absorbing elements
- do ispecabs = 1,nelemabs
- jbegin_left_poro(ispecabs) = 1
- jbegin_right_poro(ispecabs) = 1
-
- jend_left_poro(ispecabs) = NGLLZ
- jend_right_poro(ispecabs) = NGLLZ
-
- ibegin_bottom_poro(ispecabs) = 1
- ibegin_top_poro(ispecabs) = 1
-
- iend_bottom_poro(ispecabs) = NGLLX
- iend_top_poro(ispecabs) = NGLLX
- enddo
- endif
-
-! exclude common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces
- if(coupled_elastic_poro .and. anyabs) then
-
- if (myrank == 0) &
- print *,'excluding common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces, if any'
-
-! loop on all the absorbing elements
- do ispecabs = 1,nelemabs
-
- ispec = numabs(ispecabs)
-
-! loop on all the coupling edges
- do inum = 1,num_solid_poro_edges
-
-! get the edge of the acoustic element
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
-
-! if poroelastic absorbing element and elastic/poroelastic coupled element is the same
- if(ispec_poroelastic == ispec) then
-
- if(iedge_poroelastic == IBOTTOM) then
- jbegin_left_poro(ispecabs) = 2
- jbegin_right_poro(ispecabs) = 2
- endif
-
- if(iedge_poroelastic == ITOP) then
- jend_left_poro(ispecabs) = NGLLZ - 1
- jend_right_poro(ispecabs) = NGLLZ - 1
- endif
-
- if(iedge_poroelastic == ILEFT) then
- ibegin_bottom_poro(ispecabs) = 2
- ibegin_top_poro(ispecabs) = 2
- endif
-
- if(iedge_poroelastic == IRIGHT) then
- iend_bottom_poro(ispecabs) = NGLLX - 1
- iend_top_poro(ispecabs) = NGLLX - 1
- endif
-
- endif
-
- enddo
-
- enddo
-
- endif
-
-#ifdef USE_MPI
- if(OUTPUT_ENERGY) stop 'energy calculation currently serial only, should add an MPI_REDUCE in parallel'
-#endif
-! open the file in which we will store the energy curve
- if(OUTPUT_ENERGY) open(unit=IOUT_ENERGY,file='energy.gnu',status='unknown')
-
-!
-!---- s t a r t t i m e i t e r a t i o n s
-!
- if (myrank == 0) write(IOUT,400)
-
- ! count elapsed wall-clock time
- call date_and_time(datein,timein,zone,time_values)
- ! time_values(1): year
- ! time_values(2): month of the year
- ! time_values(3): day of the month
- ! time_values(5): hour of the day
- ! time_values(6): minutes of the hour
- ! time_values(7): seconds of the minute
- ! time_values(8): milliseconds of the second
- ! this fails if we cross the end of the month
- time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
- 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
- month_start = time_values(2)
- year_start = time_values(1)
-
- ! prepares image background
- if(output_color_image) then
- call prepare_color_image_vp(npoin,image_color_vp_display,iglob_image_color, &
- NX_IMAGE_color,NZ_IMAGE_color,nb_pixel_loc, &
- num_pixel_loc,nspec,poroelastic,ibool,kmato, &
- numat,density,poroelastcoef,porosity,tortuosity, &
- nproc,myrank,assign_external_model,vpext)
-
- endif
-
-! dummy allocation of plane wave arrays if they are unused (but still need to exist because
-! they are used as arguments to subroutines)
- if(.not. over_critical_angle) then
- allocate(v0x_left(1,NSTEP))
- allocate(v0z_left(1,NSTEP))
- allocate(t0x_left(1,NSTEP))
- allocate(t0z_left(1,NSTEP))
-
- allocate(v0x_right(1,NSTEP))
- allocate(v0z_right(1,NSTEP))
- allocate(t0x_right(1,NSTEP))
- allocate(t0z_right(1,NSTEP))
-
- allocate(v0x_bot(1,NSTEP))
- allocate(v0z_bot(1,NSTEP))
- allocate(t0x_bot(1,NSTEP))
- allocate(t0z_bot(1,NSTEP))
- endif
-
-! initialize variables for writing seismograms
- seismo_offset = 0
- seismo_current = 0
-
-! Precompute Runge Kutta coefficients if viscous attenuation
- if(TURN_VISCATTENUATION_ON) then
- theta_e = (sqrt(Q0**2+1.d0) +1.d0)/(2.d0*pi*freq0*Q0)
- theta_s = (sqrt(Q0**2+1.d0) -1.d0)/(2.d0*pi*freq0*Q0)
-
- thetainv = - 1.d0 / theta_s
- alphaval = 1.d0 + deltat*thetainv + deltat**2*thetainv**2 / 2.d0 + &
- deltat**3*thetainv**3 / 6.d0 + deltat**4*thetainv**4 / 24.d0
- betaval = deltat / 2.d0 + deltat**2*thetainv / 3.d0 + deltat**3*thetainv**2 / 8.d0 + deltat**4*thetainv**3 / 24.d0
- gammaval = deltat / 2.d0 + deltat**2*thetainv / 6.d0 + deltat**3*thetainv**2 / 24.d0
- print*,'************************************************************'
- print*,'****** Visco attenuation coefficients (poroelastic) ********'
- print*,'theta_e = ', theta_e
- print*,'theta_s = ', theta_s
- print*,'alpha = ', alphaval
- print*,'beta = ', betaval
- print*,'gamma = ', gammaval
- print*,'************************************************************'
-
-! initialize memory variables for attenuation
- viscox(:,:,:) = 0.d0
- viscoz(:,:,:) = 0.d0
- rx_viscous(:,:,:) = 0.d0
- rz_viscous(:,:,:) = 0.d0
-
- endif
-
-! allocate arrays for postscript output
-#ifdef USE_MPI
- if(modelvect) then
- d1_coorg_recv_ps_velocity_model=2
- call mpi_allreduce(nspec,d2_coorg_recv_ps_velocity_model,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
- d2_coorg_recv_ps_velocity_model=d2_coorg_recv_ps_velocity_model*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4
- d1_RGB_recv_ps_velocity_model=1
- call mpi_allreduce(nspec,d2_RGB_recv_ps_velocity_model,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
- d2_RGB_recv_ps_velocity_model=d2_RGB_recv_ps_velocity_model*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4
- else
- d1_coorg_recv_ps_velocity_model=1
- d2_coorg_recv_ps_velocity_model=1
- d1_RGB_recv_ps_velocity_model=1
- d2_RGB_recv_ps_velocity_model=1
- endif
-
- d1_coorg_send_ps_element_mesh=2
- if ( ngnod == 4 ) then
- if ( numbers == 1 ) then
- d2_coorg_send_ps_element_mesh=nspec*5
- if ( colors == 1 ) then
- d1_color_send_ps_element_mesh=2*nspec
- else
- d1_color_send_ps_element_mesh=1*nspec
- endif
- else
- d2_coorg_send_ps_element_mesh=nspec*6
- if ( colors == 1 ) then
- d1_color_send_ps_element_mesh=1*nspec
- endif
- endif
- else
- if ( numbers == 1 ) then
- d2_coorg_send_ps_element_mesh=nspec*((pointsdisp-1)*3+max(0,pointsdisp-2)+1+1)
- if ( colors == 1 ) then
- d1_color_send_ps_element_mesh=2*nspec
- else
- d1_color_send_ps_element_mesh=1*nspec
- endif
- else
- d2_coorg_send_ps_element_mesh=nspec*((pointsdisp-1)*3+max(0,pointsdisp-2)+1)
- if ( colors == 1 ) then
- d1_color_send_ps_element_mesh=1*nspec
- endif
- endif
- endif
-
-call mpi_allreduce(d1_coorg_send_ps_element_mesh,d1_coorg_recv_ps_element_mesh,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-call mpi_allreduce(d2_coorg_send_ps_element_mesh,d2_coorg_recv_ps_element_mesh,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-call mpi_allreduce(d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-
- d1_coorg_send_ps_abs=4
- d2_coorg_send_ps_abs=4*nelemabs
-call mpi_allreduce(d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-call mpi_allreduce(d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-
- d1_coorg_send_ps_free_surface=4
- d2_coorg_send_ps_free_surface=4*nelem_acoustic_surface
-call mpi_allreduce(d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-call mpi_allreduce(d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-
- d1_coorg_send_ps_vector_field=8
- if(interpol) then
- if(plot_lowerleft_corner_only) then
- d2_coorg_send_ps_vector_field=nspec*1*1
- else
- d2_coorg_send_ps_vector_field=nspec*pointsdisp*pointsdisp
- endif
- else
- d2_coorg_send_ps_vector_field=npoin
- endif
-call mpi_allreduce(d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-call mpi_allreduce(d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-
-
-#else
- d1_coorg_recv_ps_velocity_model=1
- d2_coorg_recv_ps_velocity_model=1
- d1_RGB_recv_ps_velocity_model=1
- d2_RGB_recv_ps_velocity_model=1
-
- d1_coorg_send_ps_element_mesh=1
- d2_coorg_send_ps_element_mesh=1
- d1_coorg_recv_ps_element_mesh=1
- d2_coorg_recv_ps_element_mesh=1
- d1_color_send_ps_element_mesh=1
- d1_color_recv_ps_element_mesh=1
-
- d1_coorg_send_ps_abs=1
- d2_coorg_send_ps_abs=1
- d1_coorg_recv_ps_abs=1
- d2_coorg_recv_ps_abs=1
- d1_coorg_send_ps_free_surface=1
- d2_coorg_send_ps_free_surface=1
- d1_coorg_recv_ps_free_surface=1
- d2_coorg_recv_ps_free_surface=1
-
- d1_coorg_send_ps_vector_field=1
- d2_coorg_send_ps_vector_field=1
- d1_coorg_recv_ps_vector_field=1
- d2_coorg_recv_ps_vector_field=1
-
-#endif
- d1_coorg_send_ps_velocity_model=2
- d2_coorg_send_ps_velocity_model=nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4
- d1_RGB_send_ps_velocity_model=1
- d2_RGB_send_ps_velocity_model=nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)
-
- allocate(coorg_send_ps_velocity_model(d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model))
- allocate(RGB_send_ps_velocity_model(d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model))
-
- allocate(coorg_recv_ps_velocity_model(d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model))
- allocate(RGB_recv_ps_velocity_model(d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model))
-
- allocate(coorg_send_ps_element_mesh(d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh))
- allocate(coorg_recv_ps_element_mesh(d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh))
- allocate(color_send_ps_element_mesh(d1_color_send_ps_element_mesh))
- allocate(color_recv_ps_element_mesh(d1_color_recv_ps_element_mesh))
-
- allocate(coorg_send_ps_abs(d1_coorg_send_ps_abs,d2_coorg_send_ps_abs))
- allocate(coorg_recv_ps_abs(d1_coorg_recv_ps_abs,d2_coorg_recv_ps_abs))
-
- allocate(coorg_send_ps_free_surface(d1_coorg_send_ps_free_surface,d2_coorg_send_ps_free_surface))
- allocate(coorg_recv_ps_free_surface(d1_coorg_recv_ps_free_surface,d2_coorg_recv_ps_free_surface))
-
- allocate(coorg_send_ps_vector_field(d1_coorg_send_ps_vector_field,d2_coorg_send_ps_vector_field))
- allocate(coorg_recv_ps_vector_field(d1_coorg_recv_ps_vector_field,d2_coorg_recv_ps_vector_field))
-
-! *********************************************************
-! ************* MAIN LOOP OVER THE TIME STEPS *************
-! *********************************************************
-
-#ifdef USE_MPI
-! add a barrier if we generate traces of the run for analysis with "ParaVer"
- if(GENERATE_PARAVER_TRACES) call MPI_BARRIER(MPI_COMM_WORLD,ier)
-#endif
-
- do it = 1,NSTEP
-
-! update position in seismograms
- seismo_current = seismo_current + 1
-
-! compute current time
- time = (it-1)*deltat
-
-! update displacement using finite-difference time scheme (Newmark)
- if(any_elastic) then
- displ_elastic = displ_elastic &
- + deltat*veloc_elastic &
- + deltatsquareover2*accel_elastic
- veloc_elastic = veloc_elastic + deltatover2*accel_elastic
- accel_elastic = ZERO
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation
- b_displ_elastic = b_displ_elastic &
- + b_deltat*b_veloc_elastic &
- + b_deltatsquareover2*b_accel_elastic
- b_veloc_elastic = b_veloc_elastic + b_deltatover2*b_accel_elastic
- b_accel_elastic = ZERO
- endif
- endif
-
- if(any_poroelastic) then
- !for the solid
- displs_poroelastic = displs_poroelastic &
- + deltat*velocs_poroelastic &
- + deltatsquareover2*accels_poroelastic
- velocs_poroelastic = velocs_poroelastic + deltatover2*accels_poroelastic
- accels_poroelastic = ZERO
- !for the fluid
- displw_poroelastic = displw_poroelastic &
- + deltat*velocw_poroelastic &
- + deltatsquareover2*accelw_poroelastic
- velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
- accelw_poroelastic = ZERO
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation
- !for the solid
- b_displs_poroelastic = b_displs_poroelastic &
- + b_deltat*b_velocs_poroelastic &
- + b_deltatsquareover2*b_accels_poroelastic
- b_velocs_poroelastic = b_velocs_poroelastic + b_deltatover2*b_accels_poroelastic
- b_accels_poroelastic = ZERO
- !for the fluid
- b_displw_poroelastic = b_displw_poroelastic &
- + b_deltat*b_velocw_poroelastic &
- + b_deltatsquareover2*b_accelw_poroelastic
- b_velocw_poroelastic = b_velocw_poroelastic + b_deltatover2*b_accelw_poroelastic
- b_accelw_poroelastic = ZERO
- endif
- endif
-
-!--------------------------------------------------------------------------------------------
-! implement viscous attenuation for poroelastic media
-!
- if(TURN_VISCATTENUATION_ON .and. any_poroelastic) then
-! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
-! loop over spectral elements
-
- do ispec = 1,nspec
-
- etal_f = poroelastcoef(2,2,kmato(ispec))
- permlxx = permeability(1,kmato(ispec))
- permlxz = permeability(2,kmato(ispec))
- permlzz = permeability(3,kmato(ispec))
-
- ! calcul of the inverse of k
-
- detk = permlxx*permlzz - permlxz*permlxz
-
- if(detk /= ZERO) then
- invpermlxx = permlzz/detk
- invpermlxz = -permlxz/detk
- invpermlzz = permlxx/detk
- else
- stop 'Permeability matrix is not invertible'
- endif
-
- ! relaxed viscous coef
- bl_relaxed(1) = etal_f*invpermlxx
- bl_relaxed(2) = etal_f*invpermlxz
- bl_relaxed(3) = etal_f*invpermlzz
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- viscox_loc(i,j) = velocw_poroelastic(1,iglob)*bl_relaxed(1) + &
- velocw_poroelastic(2,iglob)*bl_relaxed(2)
- viscoz_loc(i,j) = velocw_poroelastic(1,iglob)*bl_relaxed(2) + &
- velocw_poroelastic(2,iglob)*bl_relaxed(3)
-
- ! evolution rx_viscous
- Sn = - (1.d0 - theta_e/theta_s)/theta_s*viscox(i,j,ispec)
- Snp1 = - (1.d0 - theta_e/theta_s)/theta_s*viscox_loc(i,j)
- rx_viscous(i,j,ispec) = alphaval * rx_viscous(i,j,ispec) &
- + betaval * Sn + gammaval * Snp1
-
- ! evolution rz_viscous
- Sn = - (1.d0 - theta_e/theta_s)/theta_s*viscoz(i,j,ispec)
- Snp1 = - (1.d0 - theta_e/theta_s)/theta_s*viscoz_loc(i,j)
- rz_viscous(i,j,ispec) = alphaval * rz_viscous(i,j,ispec) &
- + betaval * Sn + gammaval * Snp1
-
-
- enddo
- enddo
-
- ! save visco for Runge-Kutta scheme
- viscox(:,:,ispec) = viscox_loc(:,:)
- viscoz(:,:,ispec) = viscoz_loc(:,:)
-
- enddo ! end of spectral element loop
- endif ! end of viscous attenuation for porous media
-
-!-----------------------------------------
- if(any_acoustic) then
-
- ! Newmark time scheme
- potential_acoustic = potential_acoustic &
- + deltat*potential_dot_acoustic &
- + deltatsquareover2*potential_dot_dot_acoustic
- potential_dot_acoustic = potential_dot_acoustic &
- + deltatover2*potential_dot_dot_acoustic
- potential_dot_dot_acoustic = ZERO
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation
- b_potential_acoustic = b_potential_acoustic &
- + b_deltat*b_potential_dot_acoustic &
- + b_deltatsquareover2*b_potential_dot_dot_acoustic
- b_potential_dot_acoustic = b_potential_dot_acoustic &
- + b_deltatover2*b_potential_dot_dot_acoustic
- b_potential_dot_dot_acoustic = ZERO
- endif
-
- ! free surface for an acoustic medium
- if ( nelem_acoustic_surface > 0 ) then
- call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
-
- if(SIMULATION_TYPE == 2) then ! Adjoint calculation
- call enforce_acoustic_free_surface(b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
- b_potential_acoustic,acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
- endif
- endif
-
-! *********************************************************
-! ************* compute forces for the acoustic elements
-! *********************************************************
-
-! call compute_forces_acoustic(npoin,nspec,nelemabs,numat,it,NSTEP, &
-! anyabs,assign_external_model,ibool,kmato,numabs, &
-! elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
-! potential_acoustic,b_potential_dot_dot_acoustic,b_potential_acoustic, &
-! density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
-! vpext,rhoext,hprime_xx,hprimewgll_xx, &
-! hprime_zz,hprimewgll_zz,wxgll,wzgll, &
-! ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
-! jbegin_left,jend_left,jbegin_right,jend_right, &
-! SIMULATION_TYPE,SAVE_FORWARD,b_absorb_acoustic_left,&
-! b_absorb_acoustic_right,b_absorb_acoustic_bottom,&
-! b_absorb_acoustic_top,nspec_xmin,nspec_xmax,&
-! nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top)
-
-
- call compute_forces_acoustic_2(npoin,nspec,nelemabs,numat,it,NSTEP, &
- anyabs,assign_external_model,ibool,kmato,numabs, &
- elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic, &
- density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
- vpext,rhoext,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll, &
- ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right, &
- SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
- nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
- b_absorb_acoustic_left,b_absorb_acoustic_right, &
- b_absorb_acoustic_bottom,b_absorb_acoustic_top)
- if( SIMULATION_TYPE == 2 ) then
- call compute_forces_acoustic_2(npoin,nspec,nelemabs,numat,it,NSTEP, &
- anyabs,assign_external_model,ibool,kmato,numabs, &
- elastic,poroelastic,codeabs,b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
- b_potential_acoustic, &
- density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
- vpext,rhoext,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll, &
- ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right, &
- SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
- nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
- b_absorb_acoustic_left,b_absorb_acoustic_right, &
- b_absorb_acoustic_bottom,b_absorb_acoustic_top)
- endif
-
-
- ! stores absorbing boundary contributions into files
- if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
- !--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
- do i=1,NGLLZ
- write(65) b_absorb_acoustic_left(i,ispec,it)
- enddo
- enddo
- endif
- !--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
- do i=1,NGLLZ
- write(66) b_absorb_acoustic_right(i,ispec,it)
- enddo
- enddo
- endif
- !--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
- do i=1,NGLLX
- write(67) b_absorb_acoustic_bottom(i,ispec,it)
- enddo
- enddo
- endif
- !--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
- do i=1,NGLLX
- write(68) b_absorb_acoustic_top(i,ispec,it)
- enddo
- enddo
- endif
- endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
-
- endif ! end of test if any acoustic element
-
-! *********************************************************
-! ************* add coupling with the elastic side
-! *********************************************************
-
- if(coupled_acoustic_elastic) then
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_solid_acoustic_ispec(inum)
- iedge_acoustic = fluid_solid_acoustic_iedge(inum)
-
-! get the corresponding edge of the elastic element
- ispec_elastic = fluid_solid_elastic_ispec(inum)
- iedge_elastic = fluid_solid_elastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the elastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_elastic)
- j = jvalue_inverse(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
- displ_x = displ_elastic(1,iglob)
- displ_z = displ_elastic(3,iglob)
-
- if(SIMULATION_TYPE == 2) then
- b_displ_x = b_displ_elastic(1,iglob)
- b_displ_z = b_displ_elastic(3,iglob)
- endif
-
-! get point values for the acoustic side
- i = ivalue(ipoin1D,iedge_acoustic)
- j = jvalue(ipoin1D,iedge_acoustic)
- iglob = ibool(i,j,ispec_acoustic)
-
-! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
-! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
-! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
-! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
-! Blackwell Science, page 110, equation (4.60).
- if(iedge_acoustic == ITOP)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic == IBOTTOM)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic ==ILEFT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- elseif(iedge_acoustic ==IRIGHT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- endif
-
-! compute dot product
- displ_n = displ_x*nx + displ_z*nz
-
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
-
- if(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) +&
- weight*(b_displ_x*nx + b_displ_z*nz)
- endif !if(SIMULATION_TYPE == 2) then
-
- enddo
-
- enddo
-
- endif
-
-! *********************************************************
-! ************* add coupling with the poroelastic side
-! *********************************************************
-
- if(coupled_acoustic_poro) then
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_poro_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_poro_acoustic_ispec(inum)
- iedge_acoustic = fluid_poro_acoustic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the poroelastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_poroelastic)
- j = jvalue_inverse(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
-
- displ_x = displs_poroelastic(1,iglob)
- displ_z = displs_poroelastic(2,iglob)
-
- phil = porosity(kmato(ispec_poroelastic))
- displw_x = displw_poroelastic(1,iglob)
- displw_z = displw_poroelastic(2,iglob)
-
- if(SIMULATION_TYPE == 2) then
- b_displ_x = b_displs_poroelastic(1,iglob)
- b_displ_z = b_displs_poroelastic(2,iglob)
-
- b_displw_x = b_displw_poroelastic(1,iglob)
- b_displw_z = b_displw_poroelastic(2,iglob)
- endif
-
-! get point values for the acoustic side
-! get point values for the acoustic side
- i = ivalue(ipoin1D,iedge_acoustic)
- j = jvalue(ipoin1D,iedge_acoustic)
- iglob = ibool(i,j,ispec_acoustic)
-
-! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
-! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
-! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
-! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
-! Blackwell Science, page 110, equation (4.60).
- if(iedge_acoustic == ITOP)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic == IBOTTOM)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic ==ILEFT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- elseif(iedge_acoustic ==IRIGHT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- endif
-
-! compute dot product [u_s + w]*n
- displ_n = (displ_x + displw_x)*nx + (displ_z + displw_z)*nz
-
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
-
- if(SIMULATION_TYPE == 2) then
- b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
- + weight*((b_displ_x + b_displw_x)*nx + (b_displ_z + b_displw_z)*nz)
- endif
-
- enddo
-
- enddo
-
- endif
-
-
-! ************************************************************************************
-! ************************************ add force source
-! ************************************************************************************
-
- if(any_acoustic) then
-
-! --- add the source
- if(.not. initialfield) then
-
- do i_source=1,NSOURCES
- ! if this processor carries the source and the source element is acoustic
- if (is_proc_source(i_source) == 1 .and. &
- .not. elastic(ispec_selected_source(i_source)) .and. &
- .not. poroelastic(ispec_selected_source(i_source))) then
-
-! collocated force
-! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
-! the sign is negative because pressure p = - Chi_dot_dot therefore we need
-! to add minus the source to Chi_dot_dot to get plus the source in pressure
- if(source_type(i_source) == 1) then
-
- if(SIMULATION_TYPE == 1) then
- ! forward wavefield
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
- - source_time_function(i_source,it)*hlagrange
- enddo
- enddo
- else
- ! backward wavefield
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
- - source_time_function(i_source,NSTEP-it+1)*hlagrange
- enddo
- enddo
- endif
-
- ! moment tensor
- else if(source_type(i_source) == 2) then
- call exit_MPI('cannot have moment tensor source in acoustic element')
-
- endif
- endif ! if this processor carries the source and the source element is acoustic
- enddo ! do i_source=1,NSOURCES
-
- if(SIMULATION_TYPE == 2) then ! adjoint wavefield
- irec_local = 0
- do irec = 1,nrec
- ! add the source (only if this proc carries the source)
- if (myrank == which_proc_receiver(irec)) then
-
- irec_local = irec_local + 1
- if (.not. elastic(ispec_selected_rec(irec)) .and. &
- .not. poroelastic(ispec_selected_rec(irec))) then
- ! add source array
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_rec(irec))
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
- - adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
- enddo
- enddo
- endif ! if element acoustic
-
- endif ! if this processor carries the adjoint source
- enddo ! irec = 1,nrec
- endif ! SIMULATION_TYPE == 2 adjoint wavefield
-
- endif ! if not using an initial field
-
- endif !if(any_acoustic)
-
-
-! assembling potential_dot_dot for acoustic elements
-#ifdef USE_MPI
- if ( nproc > 1 .and. any_acoustic .and. ninterface_acoustic > 0) then
- call assemble_MPI_vector_ac(potential_dot_dot_acoustic,npoin, &
- ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
- max_interface_size, max_ibool_interfaces_size_ac,&
- ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
- tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
- buffer_recv_faces_vector_ac, my_neighbours)
-
- if ( SIMULATION_TYPE == 2) then
- call assemble_MPI_vector_ac(b_potential_dot_dot_acoustic,npoin, &
- ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
- max_interface_size, max_ibool_interfaces_size_ac,&
- ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
- tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
- buffer_recv_faces_vector_ac, my_neighbours)
-
- endif
-
- endif
-
-! if ( nproc > 1 .and. any_acoustic .and. ninterface_acoustic > 0 .and. SIMULATION_TYPE == 2) then
-! call assemble_MPI_vector_ac(b_potential_dot_dot_acoustic,npoin, &
-! ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
-! max_interface_size, max_ibool_interfaces_size_ac,&
-! ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
-! tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
-! buffer_recv_faces_vector_ac, my_neighbours)
-! endif
-#endif
-
-! ************************************************************************************
-! ************* multiply by the inverse of the mass matrix and update velocity
-! ************************************************************************************
-
- if(any_acoustic) then
-
- potential_dot_dot_acoustic = potential_dot_dot_acoustic * rmass_inverse_acoustic
- potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
-
- if(SIMULATION_TYPE ==2)then
- b_potential_dot_dot_acoustic = b_potential_dot_dot_acoustic * rmass_inverse_acoustic
- b_potential_dot_acoustic = b_potential_dot_acoustic + b_deltatover2*b_potential_dot_dot_acoustic
- endif
-
-
-! free surface for an acoustic medium
- if ( nelem_acoustic_surface > 0 ) then
- call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
-
- if(SIMULATION_TYPE == 2) then
- call enforce_acoustic_free_surface(b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
- b_potential_acoustic,acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
- endif
-
- endif
-
- endif !if(any_acoustic)
-
-
-! *********************************************************
-! ************* main solver for the elastic elements
-! *********************************************************
-
- if(any_elastic) then
- call compute_forces_viscoelastic(p_sv,npoin,nspec,myrank,nelemabs,numat, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver, &
- source_type,it,NSTEP,anyabs,assign_external_model, &
- initialfield,TURN_ATTENUATION_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
- accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic, &
- density,poroelastcoef,xix,xiz,gammax,gammaz, &
- jacobian,vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy, &
- source_time_function,sourcearray,adj_sourcearrays, &
- e1,e11,e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
- dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1, &
- phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
- deltat,coord,add_Bielak_conditions, x0_source, z0_source, &
- A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset, f0(1),&
- v0x_left(1,it),v0z_left(1,it),v0x_right(1,it),v0z_right(1,it),v0x_bot(1,it),v0z_bot(1,it), &
- t0x_left(1,it),t0z_left(1,it),t0x_right(1,it),t0z_right(1,it),t0x_bot(1,it),t0z_bot(1,it), &
- count_left,count_right,count_bottom,over_critical_angle, &
- NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD, &
- b_absorb_elastic_left,b_absorb_elastic_right,b_absorb_elastic_bottom,b_absorb_elastic_top, &
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,mu_k,kappa_k)
-
- if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
-!--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLZ
- write(35) b_absorb_elastic_left(1,i,ispec,it)
- enddo
- do i=1,NGLLZ
- write(35) b_absorb_elastic_left(3,i,ispec,it)
- enddo
- else!SH (membrane) waves
- do i=1,NGLLZ
- write(35) b_absorb_elastic_left(2,i,ispec,it)
- enddo
- endif
-
- enddo
- endif
-
-!--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
-
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLZ
- write(36) b_absorb_elastic_right(1,i,ispec,it)
- enddo
- do i=1,NGLLZ
- write(36) b_absorb_elastic_right(3,i,ispec,it)
- enddo
- else!SH (membrane) waves
- do i=1,NGLLZ
- write(36) b_absorb_elastic_right(2,i,ispec,it)
- enddo
- endif
-
- enddo
- endif
-
-!--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLX
- write(37) b_absorb_elastic_bottom(1,i,ispec,it)
- enddo
- do i=1,NGLLX
- write(37) b_absorb_elastic_bottom(3,i,ispec,it)
- enddo
- else!SH (membrane) waves
- do i=1,NGLLX
- write(37) b_absorb_elastic_bottom(2,i,ispec,it)
- enddo
- endif
-
- enddo
- endif
-
-!--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
-
- if(p_sv)then!P-SV waves
- do i=1,NGLLX
- write(38) b_absorb_elastic_top(1,i,ispec,it)
- enddo
- do i=1,NGLLX
- write(38) b_absorb_elastic_top(3,i,ispec,it)
- enddo
- else!SH (membrane) waves
- do i=1,NGLLX
- write(38) b_absorb_elastic_top(2,i,ispec,it)
- enddo
- endif
-
- enddo
- endif
-
- endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
-
- endif !if(any_elastic)
-
-! *********************************************************
-! ************* add coupling with the acoustic side
-! *********************************************************
-
- if(coupled_acoustic_elastic) then
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_solid_acoustic_ispec(inum)
- iedge_acoustic = fluid_solid_acoustic_iedge(inum)
-
-! get the corresponding edge of the elastic element
- ispec_elastic = fluid_solid_elastic_ispec(inum)
- iedge_elastic = fluid_solid_elastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the acoustic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_acoustic)
- j = jvalue_inverse(ipoin1D,iedge_acoustic)
- iglob = ibool(i,j,ispec_acoustic)
-
-! compute pressure on the fluid/solid edge
- pressure = - potential_dot_dot_acoustic(iglob)
- if(SIMULATION_TYPE == 2) then
- b_pressure = - b_potential_dot_dot_acoustic(iglob)
- endif
-! get point values for the elastic side
- ii2 = ivalue(ipoin1D,iedge_elastic)
- jj2 = jvalue(ipoin1D,iedge_elastic)
- iglob = ibool(ii2,jj2,ispec_elastic)
-
-! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
-! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
-! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
-! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
-! Blackwell Science, page 110, equation (4.60).
- if(iedge_acoustic == ITOP)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic == IBOTTOM)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic ==ILEFT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- elseif(iedge_acoustic ==IRIGHT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- endif
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) + weight*nx*pressure
- accel_elastic(3,iglob) = accel_elastic(3,iglob) + weight*nz*pressure
-
- if(SIMULATION_TYPE == 2) then
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + weight*nx*b_pressure
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) + weight*nz*b_pressure
- endif !if(SIMULATION_TYPE == 2) then
-
- enddo
-
- enddo
-
- endif
-
-! ****************************************************************************
-! ************* add coupling with the poroelastic side
-! ****************************************************************************
- if(coupled_elastic_poro) then
-
-! loop on all the coupling edges
- do inum = 1,num_solid_poro_edges
-
-! get the edge of the elastic element
- ispec_elastic = solid_poro_elastic_ispec(inum)
- iedge_elastic = solid_poro_elastic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the poroelastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_poroelastic)
- j = jvalue_inverse(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
-
-! get poroelastic domain paramters
- phil = porosity(kmato(ispec_poroelastic))
- tortl = tortuosity(kmato(ispec_poroelastic))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec_poroelastic))
- kappal_s = poroelastcoef(3,1,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
- rhol_s = density(1,kmato(ispec_poroelastic))
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec_poroelastic))
- rhol_f = density(2,kmato(ispec_poroelastic))
-!frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec_poroelastic))
- kappal_fr = poroelastcoef(3,3,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-!Biot coefficients for the input phi
- D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
- kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
- mul_G = mul_fr
- lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
- lambdalplus2mul_G = lambdal_G + TWO*mul_G
-
-! derivative along x and along z for u_s and w
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
-
- b_dwx_dxi = ZERO
- b_dwz_dxi = ZERO
-
- b_dwx_dgamma = ZERO
- b_dwz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
-
- b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec_poroelastic)
- xizl = xiz(i,j,ispec_poroelastic)
- gammaxl = gammax(i,j,ispec_poroelastic)
- gammazl = gammaz(i,j,ispec_poroelastic)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
-
- dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
-
- b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
- b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
-
- b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
- b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
- endif
-! compute stress tensor (include attenuation or anisotropy if needed)
-
-! no attenuation
- sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = mul_G*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- if(SIMULATION_TYPE == 2) then
- b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
- b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- endif
-! get point values for the elastic domain, which matches our side in the inverse direction
- ii2 = ivalue(ipoin1D,iedge_elastic)
- jj2 = jvalue(ipoin1D,iedge_elastic)
- iglob = ibool(ii2,jj2,ispec_elastic)
-
-! get elastic properties
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec_elastic))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec_elastic))
- lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec_elastic))
-
-! derivative along x and along z for u_s and w
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
- duz_dxi = duz_dxi + displ_elastic(3,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
- dux_dgamma = dux_dgamma + displ_elastic(1,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
- duz_dgamma = duz_dgamma + displ_elastic(3,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
- b_duz_dxi = b_duz_dxi + b_displ_elastic(3,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
- b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
- b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
- endif
- enddo
-
- xixl = xix(ii2,jj2,ispec_elastic)
- xizl = xiz(ii2,jj2,ispec_elastic)
- gammaxl = gammax(ii2,jj2,ispec_elastic)
- gammazl = gammaz(ii2,jj2,ispec_elastic)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
- endif
-! compute stress tensor
-! full anisotropy
- if(kmato(ispec_elastic) == 2) then
-! implement anisotropy in 2D
- if(assign_external_model) then
- c11 = c11ext(ii2,jj2,ispec_elastic)
- c13 = c13ext(ii2,jj2,ispec_elastic)
- c15 = c15ext(ii2,jj2,ispec_elastic)
- c33 = c33ext(ii2,jj2,ispec_elastic)
- c35 = c35ext(ii2,jj2,ispec_elastic)
- c55 = c55ext(ii2,jj2,ispec_elastic)
- else
- c11 = anisotropy(1,kmato(ispec_elastic))
- c13 = anisotropy(2,kmato(ispec_elastic))
- c15 = anisotropy(3,kmato(ispec_elastic))
- c33 = anisotropy(4,kmato(ispec_elastic))
- c35 = anisotropy(5,kmato(ispec_elastic))
- c55 = anisotropy(6,kmato(ispec_elastic))
- end if
-
- sigma_xx = sigma_xx + c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
- sigma_zz = sigma_zz + c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
- sigma_xz = sigma_xz + c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
- else
-! no attenuation
- sigma_xx = sigma_xx + lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
- sigma_xz = sigma_xz + mul_relaxed*(duz_dxl + dux_dzl)
- sigma_zz = sigma_zz + lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
- endif
-
- if(SIMULATION_TYPE == 2) then
- b_sigma_xx = b_sigma_xx + lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
- b_sigma_xz = b_sigma_xz + mul_relaxed*(b_duz_dxl + b_dux_dzl)
- b_sigma_zz = b_sigma_zz + lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
- endif
-
-! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
-! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
-! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
-! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
-! Blackwell Science, page 110, equation (4.60).
- if(iedge_poroelastic == ITOP)then
- xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_poroelastic == IBOTTOM)then
- xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_poroelastic ==ILEFT)then
- xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- elseif(iedge_poroelastic ==IRIGHT)then
- xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- endif
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) - weight* &
- (sigma_xx*nx + sigma_xz*nz)/2.d0
-
- accel_elastic(3,iglob) = accel_elastic(3,iglob) - weight* &
- (sigma_xz*nx + sigma_zz*nz)/2.d0
-
- if(SIMULATION_TYPE == 2) then
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - weight* &
- (b_sigma_xx*nx + b_sigma_xz*nz)/2.d0
-
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - weight* &
- (b_sigma_xz*nx + b_sigma_zz*nz)/2.d0
- endif !if(SIMULATION_TYPE == 2) then
-
- enddo
-
- enddo
-
- endif
-
-
-! ************************************************************************************
-! ************************************ add force source
-! ************************************************************************************
-
- if(any_elastic) then
-
-! --- add the source if it is a collocated force
- if(.not. initialfield) then
-
- do i_source=1,NSOURCES
-! if this processor carries the source and the source element is elastic
- if (is_proc_source(i_source) == 1 .and. elastic(ispec_selected_source(i_source))) then
-
-! collocated force
- if(source_type(i_source) == 1) then
- if(SIMULATION_TYPE == 1) then ! forward wavefield
-
- if(p_sv) then ! P-SV calculation
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- accel_elastic(1,iglob) = accel_elastic(1,iglob) &
- - sin(angleforce(i_source))*source_time_function(i_source,it)*hlagrange
- accel_elastic(3,iglob) = accel_elastic(3,iglob) &
- + cos(angleforce(i_source))*source_time_function(i_source,it)*hlagrange
- enddo
- enddo
- else ! SH (membrane) calculation
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- accel_elastic(2,iglob) = accel_elastic(2,iglob) &
- + source_time_function(i_source,it)*hlagrange
- enddo
- enddo
- endif
-
- else ! backward wavefield
-
- if(p_sv) then ! P-SV calculation
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) &
- - sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1) &
- *hlagrange
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) &
- + cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1) &
- *hlagrange
- enddo
- enddo
- else ! SH (membrane) calculation
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
- b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) &
- + source_time_function(i_source,NSTEP-it+1)*hlagrange
- enddo
- enddo
-
- endif
-
- endif !endif SIMULATION_TYPE == 1
- endif
-
- endif ! if this processor carries the source and the source element is elastic
- enddo ! do i_source=1,NSOURCES
-
- endif ! if not using an initial field
- endif !if(any_elastic)
-
-! assembling accel_elastic for elastic elements
-#ifdef USE_MPI
- if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0) then
- call assemble_MPI_vector_el(accel_elastic,npoin, &
- ninterface, ninterface_elastic,inum_interfaces_elastic, &
- max_interface_size, max_ibool_interfaces_size_el,&
- ibool_interfaces_elastic, nibool_interfaces_elastic, &
- tab_requests_send_recv_elastic,buffer_send_faces_vector_el, &
- buffer_recv_faces_vector_el, my_neighbours)
- endif
-
- if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0 .and. SIMULATION_TYPE == 2) then
- call assemble_MPI_vector_el(b_accel_elastic,npoin, &
- ninterface, ninterface_elastic,inum_interfaces_elastic, &
- max_interface_size, max_ibool_interfaces_size_el,&
- ibool_interfaces_elastic, nibool_interfaces_elastic, &
- tab_requests_send_recv_elastic,buffer_send_faces_vector_el, &
- buffer_recv_faces_vector_el, my_neighbours)
- endif
-#endif
-
-
-! ************************************************************************************
-! ************* multiply by the inverse of the mass matrix and update velocity
-! ************************************************************************************
-
- if(any_elastic) then
- accel_elastic(1,:) = accel_elastic(1,:) * rmass_inverse_elastic
- accel_elastic(2,:) = accel_elastic(2,:) * rmass_inverse_elastic
- accel_elastic(3,:) = accel_elastic(3,:) * rmass_inverse_elastic
-
- veloc_elastic = veloc_elastic + deltatover2*accel_elastic
-
- if(SIMULATION_TYPE == 2) then
- b_accel_elastic(1,:) = b_accel_elastic(1,:) * rmass_inverse_elastic(:)
- b_accel_elastic(2,:) = b_accel_elastic(2,:) * rmass_inverse_elastic(:)
- b_accel_elastic(3,:) = b_accel_elastic(3,:) * rmass_inverse_elastic(:)
-
- b_veloc_elastic = b_veloc_elastic + b_deltatover2*b_accel_elastic
- endif
-
- endif !if(any_elastic)
-
-
-! ******************************************************************************************************************
-! ************* main solver for the poroelastic elements: first the solid (u_s) than the fluid (w)
-! ******************************************************************************************************************
-
- if(any_poroelastic) then
-
- if(SIMULATION_TYPE == 2) then
-! if inviscid fluid, comment the reading and uncomment the zeroing
-! read(23,rec=NSTEP-it+1) b_viscodampx
-! read(24,rec=NSTEP-it+1) b_viscodampz
- b_viscodampx(:) = ZERO
- b_viscodampz(:) = ZERO
- endif
-
- call compute_forces_poro_solid(npoin,nspec,myrank,nelemabs,numat, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
- source_type,it,NSTEP,anyabs, &
- initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
- accels_poroelastic,velocs_poroelastic,velocw_poroelastic,displs_poroelastic,displw_poroelastic,&
- b_accels_poroelastic,b_displs_poroelastic,b_displw_poroelastic,&
- density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
- jacobian,source_time_function,sourcearray,adj_sourcearrays,e11, &
- e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
- dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
- phi_nu2,Mu_nu2,N_SLS, &
- rx_viscous,rz_viscous,theta_e,theta_s,&
- b_viscodampx,b_viscodampz,&
- ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
- jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
- mufr_k,B_k,NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD,&
- b_absorb_poro_s_left,b_absorb_poro_s_right,b_absorb_poro_s_bottom,b_absorb_poro_s_top,&
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,f0(1),freq0,Q0)
-
-
-
- call compute_forces_poro_fluid(npoin,nspec,myrank,nelemabs,numat, &
- ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
- source_type,it,NSTEP,anyabs, &
- initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
- accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
- b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
- density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
- jacobian,source_time_function,sourcearray,adj_sourcearrays,e11, &
- e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
- dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
- phi_nu2,Mu_nu2,N_SLS, &
- rx_viscous,rz_viscous,theta_e,theta_s,&
- b_viscodampx,b_viscodampz,&
- ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
- jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
- C_k,M_k,NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD,&
- b_absorb_poro_w_left,b_absorb_poro_w_right,b_absorb_poro_w_bottom,b_absorb_poro_w_top,&
- nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,f0(1),freq0,Q0)
-
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
-! if inviscid fluid, comment
-! write(23,rec=it) b_viscodampx
-! write(24,rec=it) b_viscodampz
- endif
-
- if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
-
-!--- left absorbing boundary
- if(nspec_xmin >0) then
- do ispec = 1,nspec_xmin
- do id =1,2
- do i=1,NGLLZ
- write(45) b_absorb_poro_s_left(id,i,ispec,it)
- write(25) b_absorb_poro_w_left(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
-!--- right absorbing boundary
- if(nspec_xmax >0) then
- do ispec = 1,nspec_xmax
- do id =1,2
- do i=1,NGLLZ
- write(46) b_absorb_poro_s_right(id,i,ispec,it)
- write(26) b_absorb_poro_w_right(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
-!--- bottom absorbing boundary
- if(nspec_zmin >0) then
- do ispec = 1,nspec_zmin
- do id =1,2
- do i=1,NGLLX
- write(47) b_absorb_poro_s_bottom(id,i,ispec,it)
- write(29) b_absorb_poro_w_bottom(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
-!--- top absorbing boundary
- if(nspec_zmax >0) then
- do ispec = 1,nspec_zmax
- do id =1,2
- do i=1,NGLLX
- write(48) b_absorb_poro_s_top(id,i,ispec,it)
- write(28) b_absorb_poro_w_top(id,i,ispec,it)
- enddo
- enddo
- enddo
- endif
-
- endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
-
- endif !if(any_poroelastic) then
-
-! *********************************************************
-! ************* add coupling with the acoustic side
-! *********************************************************
-
- if(coupled_acoustic_poro) then
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_poro_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_poro_acoustic_ispec(inum)
- iedge_acoustic = fluid_poro_acoustic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the acoustic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_acoustic)
- j = jvalue_inverse(ipoin1D,iedge_acoustic)
- iglob = ibool(i,j,ispec_acoustic)
-
-! get poroelastic parameters
- phil = porosity(kmato(ispec_poroelastic))
- tortl = tortuosity(kmato(ispec_poroelastic))
- rhol_f = density(2,kmato(ispec_poroelastic))
- rhol_s = density(1,kmato(ispec_poroelastic))
- rhol_bar = (1._CUSTOM_REAL-phil)*rhol_s + phil*rhol_f
-
-! compute pressure on the fluid/porous medium edge
- pressure = - potential_dot_dot_acoustic(iglob)
- if(SIMULATION_TYPE == 2) then
- b_pressure = - b_potential_dot_dot_acoustic(iglob)
- endif
-
-! get point values for the poroelastic side
- ii2 = ivalue(ipoin1D,iedge_poroelastic)
- jj2 = jvalue(ipoin1D,iedge_poroelastic)
- iglob = ibool(ii2,jj2,ispec_poroelastic)
-
-! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
-! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
-! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
-! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
-! Blackwell Science, page 110, equation (4.60).
- if(iedge_acoustic == ITOP)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic == IBOTTOM)then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_acoustic ==ILEFT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- elseif(iedge_acoustic ==IRIGHT)then
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- endif
-
-! contribution to the solid phase
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + weight*nx*pressure*(1._CUSTOM_REAL-phil/tortl)
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + weight*nz*pressure*(1._CUSTOM_REAL-phil/tortl)
-
-! contribution to the fluid phase
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) + weight*nx*pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + weight*nz*pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
-
- if(SIMULATION_TYPE == 2) then
-! contribution to the solid phase
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-phil/tortl)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-phil/tortl)
-
-! contribution to the fluid phase
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
- endif !if(SIMULATION_TYPE == 2) then
-
- enddo ! do ipoin1D = 1,NGLLX
-
- enddo ! do inum = 1,num_fluid_poro_edges
-
- endif ! if(coupled_acoustic_poro)
-
-! ****************************************************************************
-! ************* add coupling with the elastic side
-! ****************************************************************************
-
- if(coupled_elastic_poro) then
-
-! loop on all the coupling edges
- do inum = 1,num_solid_poro_edges
-
-! get the edge of the elastic element
- ispec_elastic = solid_poro_elastic_ispec(inum)
- iedge_elastic = solid_poro_elastic_iedge(inum)
-
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the elastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_elastic)
- j = jvalue_inverse(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
-! get elastic properties
- lambdal_relaxed = poroelastcoef(1,1,kmato(ispec_elastic))
- mul_relaxed = poroelastcoef(2,1,kmato(ispec_elastic))
- lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec_elastic))
-
-! derivative along x and along z for u_s and w
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
- b_duz_dxi = b_duz_dxi + b_displ_elastic(3,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
- b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec_elastic)
- xizl = xiz(i,j,ispec_elastic)
- gammaxl = gammax(i,j,ispec_elastic)
- gammazl = gammaz(i,j,ispec_elastic)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
- endif
-! compute stress tensor
-! full anisotropy
- if(kmato(ispec_elastic) == 2) then
-! implement anisotropy in 2D
- if(assign_external_model) then
- c11 = c11ext(i,j,ispec_elastic)
- c13 = c13ext(i,j,ispec_elastic)
- c15 = c15ext(i,j,ispec_elastic)
- c33 = c33ext(i,j,ispec_elastic)
- c35 = c35ext(i,j,ispec_elastic)
- c55 = c55ext(i,j,ispec_elastic)
- else
- c11 = anisotropy(1,kmato(ispec_elastic))
- c13 = anisotropy(2,kmato(ispec_elastic))
- c15 = anisotropy(3,kmato(ispec_elastic))
- c33 = anisotropy(4,kmato(ispec_elastic))
- c35 = anisotropy(5,kmato(ispec_elastic))
- c55 = anisotropy(6,kmato(ispec_elastic))
- end if
- sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
- sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
- sigma_xz = c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
- else
-! no attenuation
- sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
- sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
- sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
- endif
-
- if(SIMULATION_TYPE == 2) then
- b_sigma_xx = lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
- b_sigma_xz = mul_relaxed*(b_duz_dxl + b_dux_dzl)
- b_sigma_zz = lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
- endif ! if(SIMULATION_TYPE == 2)
-
-! get point values for the poroelastic side
- i = ivalue(ipoin1D,iedge_poroelastic)
- j = jvalue(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
-
-! get poroelastic domain paramters
- phil = porosity(kmato(ispec_poroelastic))
- tortl = tortuosity(kmato(ispec_poroelastic))
-!solid properties
- mul_s = poroelastcoef(2,1,kmato(ispec_poroelastic))
- kappal_s = poroelastcoef(3,1,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
- rhol_s = density(1,kmato(ispec_poroelastic))
-!fluid properties
- kappal_f = poroelastcoef(1,2,kmato(ispec_poroelastic))
- rhol_f = density(2,kmato(ispec_poroelastic))
-!frame properties
- mul_fr = poroelastcoef(2,3,kmato(ispec_poroelastic))
- kappal_fr = poroelastcoef(3,3,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-!Biot coefficients for the input phi
- D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
- H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
- kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
- C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
- M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
- mul_G = mul_fr
- lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
- lambdalplus2mul_G = lambdal_G + TWO*mul_G
-
-! derivative along x and along z for u_s and w
- dux_dxi = ZERO
- duz_dxi = ZERO
-
- dux_dgamma = ZERO
- duz_dgamma = ZERO
-
- dwx_dxi = ZERO
- dwz_dxi = ZERO
-
- dwx_dgamma = ZERO
- dwz_dgamma = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = ZERO
- b_duz_dxi = ZERO
-
- b_dux_dgamma = ZERO
- b_duz_dgamma = ZERO
-
- b_dwx_dxi = ZERO
- b_dwz_dxi = ZERO
-
- b_dwx_dgamma = ZERO
- b_dwz_dgamma = ZERO
- endif
-
-! first double loop over GLL points to compute and store gradients
-! we can merge the two loops because NGLLX == NGLLZ
- do k = 1,NGLLX
- dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
-
- dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- if(SIMULATION_TYPE == 2) then
- b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
-
- b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
- b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
- endif
- enddo
-
- xixl = xix(i,j,ispec_poroelastic)
- xizl = xiz(i,j,ispec_poroelastic)
- gammaxl = gammax(i,j,ispec_poroelastic)
- gammazl = gammaz(i,j,ispec_poroelastic)
-
-! derivatives of displacement
- dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
- dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
-
- duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
- duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
-
- dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
- dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
-
- dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
- dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
-
- if(SIMULATION_TYPE == 2) then
- b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
- b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
-
- b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
- b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
-
- b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
- b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
-
- b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
- b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
- endif
-! compute stress tensor
-
-! no attenuation
- sigma_xx = sigma_xx + lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
- sigma_xz = sigma_xz + mul_G*(duz_dxl + dux_dzl)
- sigma_zz = sigma_zz + lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
-
- sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
-
- if(SIMULATION_TYPE == 2) then
- b_sigma_xx = b_sigma_xx + lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- b_sigma_xz = b_sigma_xz + mul_G*(b_duz_dxl + b_dux_dzl)
- b_sigma_zz = b_sigma_zz + lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
- b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
- endif
-
-! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
-! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
-! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
-! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
-! Blackwell Science, page 110, equation (4.60).
- if(iedge_poroelastic == ITOP)then
- xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = - zxi / jacobian1D
- nz = + xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_poroelastic == IBOTTOM)then
- xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
- weight = jacobian1D * wxgll(i)
- elseif(iedge_poroelastic ==ILEFT)then
- xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = - zgamma / jacobian1D
- nz = + xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- elseif(iedge_poroelastic ==IRIGHT)then
- xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
- weight = jacobian1D * wzgll(j)
- endif
-
-! contribution to the solid phase
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + &
- weight*((sigma_xx*nx + sigma_xz*nz)/2.d0 -phil/tortl*sigmap*nx)
-
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + &
- weight*((sigma_xz*nx + sigma_zz*nz)/2.d0 -phil/tortl*sigmap*nz)
-
-! contribution to the fluid phase
-! w = 0
-
- if(SIMULATION_TYPE == 2) then
-! contribution to the solid phase
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + &
- weight*((b_sigma_xx*nx + b_sigma_xz*nz)/2.d0 -phil/tortl*b_sigmap*nx)
-
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + &
- weight*((b_sigma_xz*nx + b_sigma_zz*nz)/2.d0 -phil/tortl*b_sigmap*nz)
-
-! contribution to the fluid phase
-! w = 0
- endif !if(SIMULATION_TYPE == 2) then
-
- enddo
-
- enddo
-
- endif ! if(coupled_elastic_poro)
-
-
-! ************************************************************************************
-! ******************************** add force source
-! ************************************************************************************
-
- if(any_poroelastic) then
-
-
-! --- add the source if it is a collocated force
- if(.not. initialfield) then
-
- do i_source=1,NSOURCES
-! if this processor carries the source and the source element is elastic
- if (is_proc_source(i_source) == 1 .and. poroelastic(ispec_selected_source(i_source))) then
-
- phil = porosity(kmato(ispec_selected_source(i_source)))
- tortl = tortuosity(kmato(ispec_selected_source(i_source)))
- rhol_s = density(1,kmato(ispec_selected_source(i_source)))
- rhol_f = density(2,kmato(ispec_selected_source(i_source)))
- rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
-
-! collocated force
- if(source_type(i_source) == 1) then
- if(SIMULATION_TYPE == 1) then ! forward wavefield
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
-! s
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - hlagrange * &
- (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,it)
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + hlagrange * &
- (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,it)
-! w
- accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - hlagrange * &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,it)
- accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + hlagrange * &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,it)
- enddo
- enddo
- else ! backward wavefield
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_source(i_source))
- hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
-! b_s
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - hlagrange * &
- (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + hlagrange * &
- (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
-!b_w
- b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - hlagrange * &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + hlagrange * &
- (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
- enddo
- enddo
- endif !endif SIMULATION_TYPE == 1
- endif
-
- endif ! if this processor carries the source and the source element is elastic
- enddo ! do i_source=1,NSOURCES
-
- endif ! if not using an initial field
- endif !if(any_poroelastic)
-
-! assembling accels_proelastic & accelw_poroelastic for poroelastic elements
-#ifdef USE_MPI
- if (nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0) then
- call assemble_MPI_vector_po(accels_poroelastic,accelw_poroelastic,npoin, &
- ninterface, ninterface_poroelastic,inum_interfaces_poroelastic, &
- max_interface_size, max_ibool_interfaces_size_po,&
- ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
- tab_requests_send_recv_poro,buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
- buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
- my_neighbours)
- endif
-
- if (nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0 .and. SIMULATION_TYPE == 2) then
- call assemble_MPI_vector_po(b_accels_poroelastic,b_accelw_poroelastic,npoin, &
- ninterface, ninterface_poroelastic,inum_interfaces_poroelastic, &
- max_interface_size, max_ibool_interfaces_size_po,&
- ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
- tab_requests_send_recv_poro,buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
- buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
- my_neighbours)
- endif
-#endif
-
-
-! ************************************************************************************
-! ************* multiply by the inverse of the mass matrix and update velocity
-! ************************************************************************************
-
- if(any_poroelastic) then
- accels_poroelastic(1,:) = accels_poroelastic(1,:) * rmass_s_inverse_poroelastic(:)
- accels_poroelastic(2,:) = accels_poroelastic(2,:) * rmass_s_inverse_poroelastic(:)
- velocs_poroelastic = velocs_poroelastic + deltatover2*accels_poroelastic
-
- accelw_poroelastic(1,:) = accelw_poroelastic(1,:) * rmass_w_inverse_poroelastic(:)
- accelw_poroelastic(2,:) = accelw_poroelastic(2,:) * rmass_w_inverse_poroelastic(:)
- velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
-
- if(SIMULATION_TYPE == 2) then
- b_accels_poroelastic(1,:) = b_accels_poroelastic(1,:) * rmass_s_inverse_poroelastic(:)
- b_accels_poroelastic(2,:) = b_accels_poroelastic(2,:) * rmass_s_inverse_poroelastic(:)
- b_velocs_poroelastic = b_velocs_poroelastic + b_deltatover2*b_accels_poroelastic
-
- b_accelw_poroelastic(1,:) = b_accelw_poroelastic(1,:) * rmass_w_inverse_poroelastic(:)
- b_accelw_poroelastic(2,:) = b_accelw_poroelastic(2,:) * rmass_w_inverse_poroelastic(:)
- b_velocw_poroelastic = b_velocw_poroelastic + b_deltatover2*b_accelw_poroelastic
- endif
-
- endif !if(any_poroelastic)
-
-!*******************************************************************************
-! assembling the displacements on the elastic-poro boundaries
-!*******************************************************************************
- if(coupled_elastic_poro) then
- icount(:)=ZERO
-
-! loop on all the coupling edges
- do inum = 1,num_solid_poro_edges
-! get the edge of the elastic element
- ispec_elastic = solid_poro_elastic_ispec(inum)
- iedge_elastic = solid_poro_elastic_iedge(inum)
-! get the corresponding edge of the poroelastic element
- ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
- iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
-
- do ipoin1D = 1,NGLLX
-! recovering original velocities and accelerations on boundaries (elastic side)
- i = ivalue(ipoin1D,iedge_poroelastic)
- j = jvalue(ipoin1D,iedge_poroelastic)
- iglob = ibool(i,j,ispec_poroelastic)
- icount(iglob) = icount(iglob) + 1
-
- if(icount(iglob) ==1)then
- veloc_elastic(1,iglob) = veloc_elastic(1,iglob) - deltatover2*accel_elastic(1,iglob)
- veloc_elastic(3,iglob) = veloc_elastic(3,iglob) - deltatover2*accel_elastic(3,iglob)
- accel_elastic(1,iglob) = accel_elastic(1,iglob) / rmass_inverse_elastic(iglob)
- accel_elastic(3,iglob) = accel_elastic(3,iglob) / rmass_inverse_elastic(iglob)
-! recovering original velocities and accelerations on boundaries (poro side)
- velocs_poroelastic(1,iglob) = velocs_poroelastic(1,iglob) - deltatover2*accels_poroelastic(1,iglob)
- velocs_poroelastic(2,iglob) = velocs_poroelastic(2,iglob) - deltatover2*accels_poroelastic(2,iglob)
- accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) / rmass_s_inverse_poroelastic(iglob)
- accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) / rmass_s_inverse_poroelastic(iglob)
-! assembling accelerations
- accel_elastic(1,iglob) = ( accel_elastic(1,iglob) + accels_poroelastic(1,iglob) ) / &
- ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
- accel_elastic(3,iglob) = ( accel_elastic(3,iglob) + accels_poroelastic(2,iglob) ) / &
- ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
- accels_poroelastic(1,iglob) = accel_elastic(1,iglob)
- accels_poroelastic(2,iglob) = accel_elastic(3,iglob)
-! updating velocities
- velocs_poroelastic(1,iglob) = velocs_poroelastic(1,iglob) + deltatover2*accels_poroelastic(1,iglob)
- velocs_poroelastic(2,iglob) = velocs_poroelastic(2,iglob) + deltatover2*accels_poroelastic(2,iglob)
- veloc_elastic(1,iglob) = veloc_elastic(1,iglob) + deltatover2*accel_elastic(1,iglob)
- veloc_elastic(3,iglob) = veloc_elastic(3,iglob) + deltatover2*accel_elastic(3,iglob)
-! zeros w
- accelw_poroelastic(1,iglob) = ZERO
- accelw_poroelastic(2,iglob) = ZERO
- velocw_poroelastic(1,iglob) = ZERO
- velocw_poroelastic(2,iglob) = ZERO
-
- if(SIMULATION_TYPE == 2) then
- b_veloc_elastic(1,iglob) = b_veloc_elastic(1,iglob) - b_deltatover2*b_accel_elastic(1,iglob)
- b_veloc_elastic(3,iglob) = b_veloc_elastic(3,iglob) - b_deltatover2*b_accel_elastic(3,iglob)
- b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) / rmass_inverse_elastic(iglob)
- b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) / rmass_inverse_elastic(iglob)
-! recovering original velocities and accelerations on boundaries (poro side)
- b_velocs_poroelastic(1,iglob) = b_velocs_poroelastic(1,iglob) - b_deltatover2*b_accels_poroelastic(1,iglob)
- b_velocs_poroelastic(2,iglob) = b_velocs_poroelastic(2,iglob) - b_deltatover2*b_accels_poroelastic(2,iglob)
- b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) / rmass_s_inverse_poroelastic(iglob)
- b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) / rmass_s_inverse_poroelastic(iglob)
-! assembling accelerations
- b_accel_elastic(1,iglob) = ( b_accel_elastic(1,iglob) + b_accels_poroelastic(1,iglob) ) / &
- ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
- b_accel_elastic(3,iglob) = ( b_accel_elastic(3,iglob) + b_accels_poroelastic(2,iglob) ) / &
- ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
- b_accels_poroelastic(1,iglob) = b_accel_elastic(1,iglob)
- b_accels_poroelastic(2,iglob) = b_accel_elastic(3,iglob)
-! updating velocities
- b_velocs_poroelastic(1,iglob) = b_velocs_poroelastic(1,iglob) + b_deltatover2*b_accels_poroelastic(1,iglob)
- b_velocs_poroelastic(2,iglob) = b_velocs_poroelastic(2,iglob) + b_deltatover2*b_accels_poroelastic(2,iglob)
- b_veloc_elastic(1,iglob) = b_veloc_elastic(1,iglob) + b_deltatover2*b_accel_elastic(1,iglob)
- b_veloc_elastic(3,iglob) = b_veloc_elastic(3,iglob) + b_deltatover2*b_accel_elastic(3,iglob)
-! zeros w
- b_accelw_poroelastic(1,iglob) = ZERO
- b_accelw_poroelastic(2,iglob) = ZERO
- b_velocw_poroelastic(1,iglob) = ZERO
- b_velocw_poroelastic(2,iglob) = ZERO
- endif !if(SIMULATION_TYPE == 2)
-
- endif !if(icount(iglob) ==1)
-
- enddo
-
- enddo
- endif
-
-! ********************************************************************************************
-! reading lastframe for adjoint/kernels calculation
-! ********************************************************************************************
- if(it == 1 .and. SIMULATION_TYPE == 2) then
-
-! acoustic medium
- if(any_acoustic) then
- write(outputname,'(a,i6.6,a)') 'lastframe_acoustic',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
- do j=1,npoin
- read(55) b_potential_acoustic(j),&
- b_potential_dot_acoustic(j),&
- b_potential_dot_dot_acoustic(j)
- enddo
- close(55)
-
-! free surface for an acoustic medium
- if ( nelem_acoustic_surface > 0 ) then
- call enforce_acoustic_free_surface(b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
- b_potential_acoustic,acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
- endif
- endif
-
-! elastic medium
- if(any_elastic) then
- write(outputname,'(a,i6.6,a)') 'lastframe_elastic',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
- if(p_sv)then !P-SV waves
- do j=1,npoin
- read(55) (b_displ_elastic(i,j), i=1,NDIM), &
- (b_veloc_elastic(i,j), i=1,NDIM), &
- (b_accel_elastic(i,j), i=1,NDIM)
- enddo
- b_displ_elastic(3,:) = b_displ_elastic(2,:)
- b_displ_elastic(2,:) = 0._CUSTOM_REAL
- b_veloc_elastic(3,:) = b_veloc_elastic(2,:)
- b_veloc_elastic(2,:) = 0._CUSTOM_REAL
- b_accel_elastic(3,:) = b_accel_elastic(2,:)
- b_accel_elastic(2,:) = 0._CUSTOM_REAL
- else !SH (membrane) waves
- do j=1,npoin
- read(55) b_displ_elastic(2,j), &
- b_veloc_elastic(2,j), &
- b_accel_elastic(2,j)
- enddo
- b_displ_elastic(1,:) = 0._CUSTOM_REAL
- b_displ_elastic(3,:) = 0._CUSTOM_REAL
- b_veloc_elastic(1,:) = 0._CUSTOM_REAL
- b_veloc_elastic(3,:) = 0._CUSTOM_REAL
- b_accel_elastic(1,:) = 0._CUSTOM_REAL
- b_accel_elastic(3,:) = 0._CUSTOM_REAL
- endif
- close(55)
- endif
-
-! poroelastic medium
- if(any_poroelastic) then
- write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
- write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_w',myrank,'.bin'
- open(unit=56,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
- do j=1,npoin
- read(55) (b_displs_poroelastic(i,j), i=1,NDIM), &
- (b_velocs_poroelastic(i,j), i=1,NDIM), &
- (b_accels_poroelastic(i,j), i=1,NDIM)
- read(56) (b_displw_poroelastic(i,j), i=1,NDIM), &
- (b_velocw_poroelastic(i,j), i=1,NDIM), &
- (b_accelw_poroelastic(i,j), i=1,NDIM)
- enddo
- close(55)
- close(56)
- endif
-
- endif ! if(it == 1 .and. SIMULATION_TYPE == 2)
-
-! ********************************************************************************************
-! kernels calculation
-! ********************************************************************************************
- if(any_elastic .and. SIMULATION_TYPE == 2) then ! kernels calculation
- do iglob = 1,npoin
- rho_k(iglob) = accel_elastic(1,iglob)*b_displ_elastic(1,iglob) +&
- accel_elastic(2,iglob)*b_displ_elastic(2,iglob) +&
- accel_elastic(3,iglob)*b_displ_elastic(3,iglob)
- rhorho_el_hessian_temp1(iglob) = accel_elastic(1,iglob)*accel_elastic(1,iglob) +&
- accel_elastic(2,iglob)*accel_elastic(2,iglob) +&
- accel_elastic(3,iglob)*accel_elastic(3,iglob)
- rhorho_el_hessian_temp2(iglob) = accel_elastic(1,iglob)*b_accel_elastic(1,iglob) +&
- accel_elastic(2,iglob)*b_accel_elastic(2,iglob) +&
- accel_elastic(3,iglob)*b_accel_elastic(3,iglob)
- enddo
- endif
-
- if(any_poroelastic .and. SIMULATION_TYPE ==2) then
- do iglob =1,npoin
- rhot_k(iglob) = accels_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
- accels_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob)
- rhof_k(iglob) = accelw_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
- accelw_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob) + &
- accels_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
- accels_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
- sm_k(iglob) = accelw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
- accelw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
- eta_k(iglob) = velocw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
- velocw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
- enddo
- endif
-
-!---- compute kinetic and potential energy
- if(OUTPUT_ENERGY) &
- call compute_energy(displ_elastic,veloc_elastic, &
- displs_poroelastic,velocs_poroelastic, &
- displw_poroelastic,velocw_poroelastic, &
- xix,xiz,gammax,gammaz,jacobian,ibool,elastic,poroelastic,hprime_xx,hprime_zz, &
- nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- assign_external_model,it,deltat,t0,kmato,poroelastcoef,density, &
- porosity,tortuosity, &
- vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext, &
- anisotropic,anisotropy,wxgll,wzgll,numat, &
- pressure_element,vector_field_element,e1,e11, &
- potential_dot_acoustic,potential_dot_dot_acoustic, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS,p_sv)
-
-!---- display time step and max of norm of displacement
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
- call check_stability(myrank,time,it,NSTEP, &
- npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- any_elastic_glob,any_elastic,displ_elastic, &
- any_poroelastic_glob,any_poroelastic, &
- displs_poroelastic,displw_poroelastic, &
- any_acoustic_glob,any_acoustic,potential_acoustic, &
- year_start,month_start,time_start)
- endif
-
-! loop on all the receivers to compute and store the seismograms
- do irecloc = 1,nrecloc
-
- irec = recloc(irecloc)
-
- ispec = ispec_selected_rec(irec)
-
-! compute pressure in this element if needed
- if(seismotype == 4) then
-
- call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
- displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
- npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
-
- else if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
-
-! for acoustic medium, compute vector field from gradient of potential for seismograms
- if(seismotype == 1) then
- call compute_vector_one_element(vector_field_element,potential_acoustic, &
- displ_elastic,displs_poroelastic,&
- elastic,poroelastic,xix,xiz,gammax,gammaz, &
- ibool,hprime_xx,hprime_zz, &
- nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- ispec,numat,kmato,density,rhoext,assign_external_model)
- else if(seismotype == 2) then
- call compute_vector_one_element(vector_field_element,potential_dot_acoustic, &
- veloc_elastic,velocs_poroelastic, &
- elastic,poroelastic,xix,xiz,gammax,gammaz, &
- ibool,hprime_xx,hprime_zz, &
- nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- ispec,numat,kmato,density,rhoext,assign_external_model)
- else if(seismotype == 3) then
- call compute_vector_one_element(vector_field_element,potential_dot_dot_acoustic, &
- accel_elastic,accels_poroelastic, &
- elastic,poroelastic,xix,xiz,gammax,gammaz, &
- ibool,hprime_xx,hprime_zz, &
- nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- ispec,numat,kmato,density,rhoext,assign_external_model)
- endif
-
- else if(seismotype == 5) then
- call compute_curl_one_element(curl_element,displ_elastic, &
- displs_poroelastic,elastic,poroelastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
- nspec,npoin_elastic,npoin_poroelastic,ispec)
- endif
-
-! perform the general interpolation using Lagrange polynomials
- valux = ZERO
- valuy = ZERO
- valuz = ZERO
- valcurl = ZERO
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- hlagrange = hxir_store(irec,i)*hgammar_store(irec,j)
-
- dcurld=ZERO
-
- if(seismotype == 4) then
-
- dxd = pressure_element(i,j)
- dzd = ZERO
-
- else if(.not. elastic(ispec) .and. .not. poroelastic(ispec) .and. seismotype /= 6) then
-
- dxd = vector_field_element(1,i,j)
- dzd = vector_field_element(3,i,j)
-
- else if(seismotype == 6) then
-
- dxd = potential_acoustic(iglob)
- dzd = ZERO
-
- else if(seismotype == 1) then
-
- if(poroelastic(ispec)) then
- dxd = displs_poroelastic(1,iglob)
- dzd = displs_poroelastic(2,iglob)
- elseif(elastic(ispec)) then
- dxd = displ_elastic(1,iglob)
- dyd = displ_elastic(2,iglob)
- dzd = displ_elastic(3,iglob)
- endif
-
- else if(seismotype == 2) then
-
- if(poroelastic(ispec)) then
- dxd = velocs_poroelastic(1,iglob)
- dzd = velocs_poroelastic(2,iglob)
- elseif(elastic(ispec)) then
- dxd = veloc_elastic(1,iglob)
- dyd = veloc_elastic(2,iglob)
- dzd = veloc_elastic(3,iglob)
- endif
-
- else if(seismotype == 3) then
-
- if(poroelastic(ispec)) then
- dxd = accels_poroelastic(1,iglob)
- dzd = accels_poroelastic(2,iglob)
- elseif(elastic(ispec)) then
- dxd = accel_elastic(1,iglob)
- dyd = accel_elastic(2,iglob)
- dzd = accel_elastic(3,iglob)
- endif
-
- else if(seismotype == 5) then
-
- if(poroelastic(ispec)) then
- dxd = displs_poroelastic(1,iglob)
- dzd = displs_poroelastic(2,iglob)
- elseif(elastic(ispec)) then
- dxd = displ_elastic(1,iglob)
- dzd = displ_elastic(2,iglob)
- endif
- dcurld = curl_element(i,j)
-
- endif
-
-! compute interpolated field
- valux = valux + dxd*hlagrange
- if(elastic(ispec)) valuy = valuy + dyd*hlagrange
- valuz = valuz + dzd*hlagrange
- valcurl = valcurl + dcurld*hlagrange
-
- enddo
- enddo
-
-! rotate seismogram components if needed, except if recording pressure, which is a scalar
- if(seismotype /= 4 .and. seismotype /= 6) then
- if(p_sv) then
- sisux(seismo_current,irecloc) = cosrot_irec(irecloc)*valux + sinrot_irec(irecloc)*valuz
- sisuz(seismo_current,irecloc) = - sinrot_irec(irecloc)*valux + cosrot_irec(irecloc)*valuz
- else
- sisux(seismo_current,irecloc) = valuy
- sisuz(seismo_current,irecloc) = ZERO
- endif
- else
- sisux(seismo_current,irecloc) = valux
- sisuz(seismo_current,irecloc) = ZERO
- endif
- siscurl(seismo_current,irecloc) = valcurl
-
- enddo
-
-
-!----- writing the kernels
-!
-! kernels output
- if(SIMULATION_TYPE == 2) then
-
- if(any_acoustic) then
-
- do ispec = 1, nspec
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- kappal_ac_global(iglob) = poroelastcoef(3,1,kmato(ispec))
- rhol_ac_global(iglob) = density(1,kmato(ispec))
-
-! calcul the displacement by computing the gradient of potential / rho
-! and calcul the acceleration by computing the gradient of potential_dot_dot / rho
- tempx1l = ZERO
- tempx2l = ZERO
- b_tempx1l = ZERO
- b_tempx2l = ZERO
- do k = 1,NGLLX
-! derivative along x
- tempx1l = tempx1l + potential_dot_dot_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
- b_tempx1l = b_tempx1l + b_potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
- bb_tempx1l = bb_tempx1l + b_potential_dot_dot_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
-! derivative along z
- tempx2l = tempx2l + potential_dot_dot_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
- b_tempx2l = b_tempx2l + b_potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
- bb_tempx2l = bb_tempx2l + b_potential_dot_dot_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
- if(assign_external_model) rhol_ac_global(iglob) = rhoext(i,j,ispec)
-
-! derivatives of potential
- accel_ac(1,iglob) = (tempx1l*xixl + tempx2l*gammaxl) / rhol_ac_global(iglob)
- accel_ac(2,iglob) = (tempx1l*xizl + tempx2l*gammazl) / rhol_ac_global(iglob)
- b_displ_ac(1,iglob) = (b_tempx1l*xixl + b_tempx2l*gammaxl) / rhol_ac_global(iglob)
- b_displ_ac(2,iglob) = (b_tempx1l*xizl + b_tempx2l*gammazl) / rhol_ac_global(iglob)
- b_accel_ac(1,iglob) = (bb_tempx1l*xixl + bb_tempx2l*gammaxl) / rhol_ac_global(iglob)
- b_accel_ac(2,iglob) = (bb_tempx1l*xizl + bb_tempx2l*gammazl) / rhol_ac_global(iglob)
-
- enddo !i = 1, NGLLX
- enddo !j = 1, NGLLZ
- endif
- enddo
-
- do ispec = 1,nspec
- if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- rho_ac_kl(i,j,ispec) = rho_ac_kl(i,j,ispec) - rhol_ac_global(iglob) * &
- dot_product(accel_ac(:,iglob),b_displ_ac(:,iglob)) * deltat
- kappa_ac_kl(i,j,ispec) = kappa_ac_kl(i,j,ispec) - kappal_ac_global(iglob) * &
- potential_dot_dot_acoustic(iglob)/kappal_ac_global(iglob) * &
- b_potential_dot_dot_acoustic(iglob)/kappal_ac_global(iglob)&
- * deltat
-!
- rhop_ac_kl(i,j,ispec) = rho_ac_kl(i,j,ispec) + kappa_ac_kl(i,j,ispec)
- alpha_ac_kl(i,j,ispec) = TWO * kappa_ac_kl(i,j,ispec)
- rhorho_ac_hessian_final1(i,j,ispec) = rhorho_ac_hessian_final1(i,j,ispec) + &
- dot_product(accel_ac(:,iglob),accel_ac(:,iglob)) * deltat
- rhorho_ac_hessian_final2(i,j,ispec) = rhorho_ac_hessian_final2(i,j,ispec) + &
- dot_product(accel_ac(:,iglob),b_accel_ac(:,iglob)) * deltat
- enddo
- enddo
- endif
- enddo
-
- endif !if(any_acoustic)
-
- if(any_elastic) then
-
- do ispec = 1, nspec
- if(elastic(ispec)) then
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- mul_global(iglob) = poroelastcoef(2,1,kmato(ispec))
- kappal_global(iglob) = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_global(iglob)/3._CUSTOM_REAL
- rhol_global(iglob) = density(1,kmato(ispec))
-
- rho_kl(i,j,ispec) = rho_kl(i,j,ispec) - rhol_global(iglob) * rho_k(iglob) * deltat
- mu_kl(i,j,ispec) = mu_kl(i,j,ispec) - TWO * mul_global(iglob) * mu_k(iglob) * deltat
- kappa_kl(i,j,ispec) = kappa_kl(i,j,ispec) - kappal_global(iglob) * kappa_k(iglob) * deltat
-!
- rhop_kl(i,j,ispec) = rho_kl(i,j,ispec) + kappa_kl(i,j,ispec) + mu_kl(i,j,ispec)
- beta_kl(i,j,ispec) = TWO * (mu_kl(i,j,ispec) - 4._CUSTOM_REAL * mul_global(iglob) &
- / (3._CUSTOM_REAL * kappal_global(iglob)) * kappa_kl(i,j,ispec))
- alpha_kl(i,j,ispec) = TWO * (1._CUSTOM_REAL + 4._CUSTOM_REAL * mul_global(iglob)/&
- (3._CUSTOM_REAL * kappal_global(iglob))) * kappa_kl(i,j,ispec)
- rhorho_el_hessian_final1(i,j,ispec) = rhorho_el_hessian_final1(i,j,ispec) + rhorho_el_hessian_temp1(iglob) * deltat
- rhorho_el_hessian_final2(i,j,ispec) = rhorho_el_hessian_final2(i,j,ispec) + rhorho_el_hessian_temp2(iglob) * deltat
-
- enddo
- enddo
- endif
- enddo
-
- endif !if(any_elastic)
-
- if(any_poroelastic) then
-
- do ispec = 1, nspec
- if(poroelastic(ispec)) then
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- phil_global(iglob) = porosity(kmato(ispec))
- tortl_global(iglob) = tortuosity(kmato(ispec))
- rhol_s_global(iglob) = density(1,kmato(ispec))
- rhol_f_global(iglob) = density(2,kmato(ispec))
- rhol_bar_global(iglob) = (1._CUSTOM_REAL - phil_global(iglob))*rhol_s_global(iglob) &
- + phil_global(iglob)*rhol_f_global(iglob)
- etal_f_global(iglob) = poroelastcoef(2,2,kmato(ispec))
- permlxx_global(iglob) = permeability(1,kmato(ispec))
- permlxz_global(iglob) = permeability(2,kmato(ispec))
- permlzz_global(iglob) = permeability(3,kmato(ispec))
- mulfr_global(iglob) = poroelastcoef(2,3,kmato(ispec))
-
- rhot_kl(i,j,ispec) = rhot_kl(i,j,ispec) - deltat * rhol_bar_global(iglob) * rhot_k(iglob)
- rhof_kl(i,j,ispec) = rhof_kl(i,j,ispec) - deltat * rhol_f_global(iglob) * rhof_k(iglob)
- sm_kl(i,j,ispec) = sm_kl(i,j,ispec) - deltat * rhol_f_global(iglob)*tortl_global(iglob)/phil_global(iglob) * sm_k(iglob)
-!at the moment works with constant permeability
- eta_kl(i,j,ispec) = eta_kl(i,j,ispec) - deltat * etal_f_global(iglob)/permlxx_global(iglob) * eta_k(iglob)
- B_kl(i,j,ispec) = B_kl(i,j,ispec) - deltat * B_k(iglob)
- C_kl(i,j,ispec) = C_kl(i,j,ispec) - deltat * C_k(iglob)
- M_kl(i,j,ispec) = M_kl(i,j,ispec) - deltat * M_k(iglob)
- mufr_kl(i,j,ispec) = mufr_kl(i,j,ispec) - TWO * deltat * mufr_k(iglob)
-! density kernels
- rholb = rhol_bar_global(iglob) - phil_global(iglob)*rhol_f_global(iglob)/tortl_global(iglob)
- rhob_kl(i,j,ispec) = rhot_kl(i,j,ispec) + B_kl(i,j,ispec) + mufr_kl(i,j,ispec)
- rhofb_kl(i,j,ispec) = rhof_kl(i,j,ispec) + C_kl(i,j,ispec) + M_kl(i,j,ispec) + sm_kl(i,j,ispec)
- Bb_kl(i,j,ispec) = B_kl(i,j,ispec)
- Cb_kl(i,j,ispec) = C_kl(i,j,ispec)
- Mb_kl(i,j,ispec) = M_kl(i,j,ispec)
- mufrb_kl(i,j,ispec) = mufr_kl(i,j,ispec)
- phi_kl(i,j,ispec) = - sm_kl(i,j,ispec) - M_kl(i,j,ispec)
-! wave speed kernels
- dd1 = (1._CUSTOM_REAL+rholb/rhol_f_global(iglob))*ratio**2 + 2._CUSTOM_REAL*ratio +&
- tortl_global(iglob)/phil_global(iglob)
- rhobb_kl(i,j,ispec) = rhob_kl(i,j,ispec) - &
- phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
- (cpIIsquare + (cpIsquare - cpIIsquare)*( (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1+&
- (rhol_bar_global(iglob)**2*ratio**2/rhol_f_global(iglob)**2*(phil_global(iglob)/tortl_global(iglob)*&
- ratio+1)*(phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*&
- (1+rhol_f_global(iglob)/rhol_bar_global(iglob))-1) )/dd1**2 )- FOUR_THIRDS*cssquare )*&
- Bb_kl(i,j,ispec) - &
- rhol_bar_global(iglob)*ratio**2/M_biot * (cpIsquare - cpIIsquare)* &
- (phil_global(iglob)/tortl_global(iglob)*ratio + 1._CUSTOM_REAL)**2/dd1**2*Mb_kl(i,j,ispec) + &
- rhol_bar_global(iglob)*ratio/C_biot * (cpIsquare - cpIIsquare)* (&
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
- phil_global(iglob)*ratio/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
- (1+rhol_bar_global(iglob)*ratio/rhol_f_global(iglob))/dd1**2)*Cb_kl(i,j,ispec)+ &
- phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
- rhofbb_kl(i,j,ispec) = rhofb_kl(i,j,ispec) + &
- phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
- (cpIIsquare + (cpIsquare - cpIIsquare)*( (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1+&
- (rhol_bar_global(iglob)**2*ratio**2/rhol_f_global(iglob)**2*(phil_global(iglob)/tortl_global(iglob)*&
- ratio+1)*(phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*&
- (1+rhol_f_global(iglob)/rhol_bar_global(iglob))-1) )/dd1**2 )- FOUR_THIRDS*cssquare )*&
- Bb_kl(i,j,ispec) + &
- rhol_bar_global(iglob)*ratio**2/M_biot * (cpIsquare - cpIIsquare)* &
- (phil_global(iglob)/tortl_global(iglob)*ratio + 1._CUSTOM_REAL)**2/dd1**2*Mb_kl(i,j,ispec) - &
- rhol_bar_global(iglob)*ratio/C_biot * (cpIsquare - cpIIsquare)* (&
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
- phil_global(iglob)*ratio/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
- (1+rhol_bar_global(iglob)*ratio/rhol_f_global(iglob))/dd1**2)*Cb_kl(i,j,ispec)- &
- phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
- phib_kl(i,j,ispec) = phi_kl(i,j,ispec) - &
- phil_global(iglob)*rhol_bar_global(iglob)/(tortl_global(iglob)*B_biot) * ( cpIsquare - rhol_f_global(iglob)/&
- rhol_bar_global(iglob)*cpIIsquare- &
- (cpIsquare-cpIIsquare)*( (TWO*ratio**2*phil_global(iglob)/tortl_global(iglob) + (1._CUSTOM_REAL+&
- rhol_f_global(iglob)/rhol_bar_global(iglob))*(TWO*ratio*phil_global(iglob)/tortl_global(iglob)+&
- 1._CUSTOM_REAL))/dd1 + (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)*&
- ratio/tortl_global(iglob)+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/&
- rhol_bar_global(iglob))-1._CUSTOM_REAL)*((1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-&
- TWO*phil_global(iglob)/tortl_global(iglob))*ratio**2+TWO*ratio)/dd1**2 ) - &
- FOUR_THIRDS*rhol_f_global(iglob)*cssquare/rhol_bar_global(iglob) )*Bb_kl(i,j,ispec) + &
- rhol_f_global(iglob)/M_biot * (cpIsquare-cpIIsquare)*(&
- TWO*ratio*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2*((1._CUSTOM_REAL+rhol_bar_global(iglob)/&
- rhol_f_global(iglob)-TWO*phil_global(iglob)/tortl_global(iglob))*ratio**2+TWO*ratio)/dd1**2&
- )*Mb_kl(i,j,ispec) + &
- phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*C_biot)*(cpIsquare-cpIIsquare)*ratio* (&
- (1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob)*ratio)/dd1 - &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/&
- rhol_f_global(iglob)*ratio)*((1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-TWO*&
- phil_global(iglob)/tortl_global(iglob))*ratio+TWO)/dd1**2&
- )*Cb_kl(i,j,ispec) -&
- phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
- cpI_kl(i,j,ispec) = 2._CUSTOM_REAL*cpIsquare/B_biot*rhol_bar_global(iglob)*( &
- 1._CUSTOM_REAL-phil_global(iglob)/tortl_global(iglob) + &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)/tortl_global(iglob)*&
- ratio+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-&
- 1._CUSTOM_REAL)/dd1 &
- )* Bb_kl(i,j,ispec) +&
- 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) *&
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2/dd1*Mb_kl(i,j,ispec)+&
- 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)/C_biot * &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/&
- rhol_f_global(iglob)*ratio)/dd1*Cb_kl(i,j,ispec)
- cpII_kl(i,j,ispec) = 2._CUSTOM_REAL*cpIIsquare*rhol_bar_global(iglob)/B_biot * (&
- phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*rhol_bar_global(iglob)) - &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)/tortl_global(iglob)*&
- ratio+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-&
- 1._CUSTOM_REAL)/dd1 ) * Bb_kl(i,j,ispec) +&
- 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) * (&
- 1._CUSTOM_REAL - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2/dd1 )*Mb_kl(i,j,ispec) + &
- 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)/C_biot * (&
- 1._CUSTOM_REAL - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+&
- rhol_bar_global(iglob)/rhol_f_global(iglob)*ratio)/dd1 )*Cb_kl(i,j,ispec)
- cs_kl(i,j,ispec) = - 8._CUSTOM_REAL/3._CUSTOM_REAL*cssquare*rhol_bar_global(iglob)/B_biot*(1._CUSTOM_REAL-&
- phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*rhol_bar_global(iglob)))*Bb_kl(i,j,ispec) + &
- 2._CUSTOM_REAL*(rhol_bar_global(iglob)-rhol_f_global(iglob)*phil_global(iglob)/tortl_global(iglob))/&
- mulfr_global(iglob)*cssquare*mufrb_kl(i,j,ispec)
- ratio_kl(i,j,ispec) = ratio*rhol_bar_global(iglob)*phil_global(iglob)/(tortl_global(iglob)*B_biot) * &
- (cpIsquare-cpIIsquare) * ( &
- phil_global(iglob)/tortl_global(iglob)*(2._CUSTOM_REAL*ratio+1._CUSTOM_REAL+rhol_f_global(iglob)/ &
- rhol_bar_global(iglob))/dd1 - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
- (phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*(&
- 1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-1._CUSTOM_REAL)*(2._CUSTOM_REAL*ratio*(&
- 1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob)) +&
- 2._CUSTOM_REAL)/dd1**2 )*Bb_kl(i,j,ispec) + &
- ratio*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot)*(cpIsquare-cpIIsquare) * &
- 2._CUSTOM_REAL*phil_global(iglob)/tortl_global(iglob) * (&
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
- (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2*((1._CUSTOM_REAL+rhol_bar_global(iglob)/&
- rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob))*ratio+1._CUSTOM_REAL)/dd1**2 )*Mb_kl(i,j,ispec) +&
- ratio*rhol_f_global(iglob)/C_biot*(cpIsquare-cpIIsquare) * (&
- (2._CUSTOM_REAL*phil_global(iglob)*rhol_bar_global(iglob)*ratio/(tortl_global(iglob)*rhol_f_global(iglob))+&
- phil_global(iglob)/tortl_global(iglob)+rhol_bar_global(iglob)/rhol_f_global(iglob))/dd1 - &
- 2._CUSTOM_REAL*phil_global(iglob)/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+&
- 1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)*ratio)*((1._CUSTOM_REAL+&
- rhol_bar_global(iglob)/rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob))*ratio+1._CUSTOM_REAL)/&
- dd1**2 )*Cb_kl(i,j,ispec)
-
- enddo
- enddo
- endif
- enddo
-
- endif ! if(any_poroelastic)
-
- endif ! if(SIMULATION_TYPE == 2)
-
-!
-!---- display results at given time steps
-!
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
-
-!
-! kernels output files
-!
-
- if(SIMULATION_TYPE == 2 .and. it == NSTEP) then
-
- if ( myrank == 0 ) then
- write(IOUT,*) 'Writing Kernels file'
- endif
-
- if(any_acoustic) then
- do ispec = 1, nspec
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- xx = coord(1,iglob)
- zz = coord(2,iglob)
- write(95,'(5e11.3)')xx,zz,rho_ac_kl(i,j,ispec),kappa_ac_kl(i,j,ispec)
- write(96,'(5e11.3)')rhorho_ac_hessian_final1(i,j,ispec), rhorho_ac_hessian_final2(i,j,ispec),&
- rhop_ac_kl(i,j,ispec),alpha_ac_kl(i,j,ispec)
- enddo
- enddo
- enddo
- close(95)
- close(96)
- endif
-
- if(any_elastic) then
- do ispec = 1, nspec
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- xx = coord(1,iglob)
- zz = coord(2,iglob)
- write(97,'(5e11.3)')xx,zz,rho_kl(i,j,ispec),kappa_kl(i,j,ispec),mu_kl(i,j,ispec)
- write(98,'(5e11.3)')xx,zz,rhop_kl(i,j,ispec),alpha_kl(i,j,ispec),beta_kl(i,j,ispec)
- !write(98,'(5e11.3)')rhorho_el_hessian_final1(i,j,ispec), rhorho_el_hessian_final2(i,j,ispec),&
- ! rhop_kl(i,j,ispec),alpha_kl(i,j,ispec),beta_kl(i,j,ispec)
- enddo
- enddo
- enddo
- close(97)
- close(98)
- endif
-
- if(any_poroelastic) then
- do ispec = 1, nspec
- do j = 1, NGLLZ
- do i = 1, NGLLX
- iglob = ibool(i,j,ispec)
- xx = coord(1,iglob)
- zz = coord(2,iglob)
- write(144,'(5e11.3)')xx,zz,mufr_kl(i,j,ispec),B_kl(i,j,ispec),C_kl(i,j,ispec)
- write(155,'(5e11.3)')xx,zz,M_kl(i,j,ispec),rhot_kl(i,j,ispec),rhof_kl(i,j,ispec)
- write(16,'(5e11.3)')xx,zz,sm_kl(i,j,ispec),eta_kl(i,j,ispec)
- write(17,'(5e11.3)')xx,zz,mufrb_kl(i,j,ispec),Bb_kl(i,j,ispec),Cb_kl(i,j,ispec)
- write(18,'(5e11.3)')xx,zz,Mb_kl(i,j,ispec),rhob_kl(i,j,ispec),rhofb_kl(i,j,ispec)
- write(19,'(5e11.3)')xx,zz,phi_kl(i,j,ispec),eta_kl(i,j,ispec)
- write(20,'(5e11.3)')xx,zz,cpI_kl(i,j,ispec),cpII_kl(i,j,ispec),cs_kl(i,j,ispec)
- write(21,'(5e11.3)')xx,zz,rhobb_kl(i,j,ispec),rhofbb_kl(i,j,ispec),ratio_kl(i,j,ispec)
- write(22,'(5e11.3)')xx,zz,phib_kl(i,j,ispec),eta_kl(i,j,ispec)
- enddo
- enddo
- enddo
- close(144)
- close(155)
- close(16)
- close(17)
- close(18)
- close(19)
- close(20)
- close(21)
- close(22)
- endif
-
- endif
-
-!
-!---- PostScript display
-!
- if(output_postscript_snapshot) then
-
- if (myrank == 0) write(IOUT,*) 'Writing PostScript file'
-
- if(imagetype == 1 .and. p_sv) then
-
- if (myrank == 0) write(IOUT,*) 'drawing displacement vector as small arrows...'
-
- call compute_vector_whole_medium(potential_acoustic,displ_elastic,displs_poroelastic,&
- elastic,poroelastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
- nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
- it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
- poroelastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
- simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
- any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,&
- fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
- solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
- myrank,nproc,ier,&
- d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
- d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
- d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
- d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
- coorg_send_ps_velocity_model,RGB_send_ps_velocity_model, &
- coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model, &
- d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
- d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
- d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
- coorg_send_ps_element_mesh,color_send_ps_element_mesh, &
- coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
- d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
- coorg_send_ps_abs,coorg_recv_ps_abs, &
- d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface, &
- d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
- coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
- d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field, &
- d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
- coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
-
- else if(imagetype == 2 .and. p_sv) then
-
- if (myrank == 0) write(IOUT,*) 'drawing velocity vector as small arrows...'
-
- call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,velocs_poroelastic,&
- elastic,poroelastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
- nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
- it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
- poroelastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
- simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
- any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,&
- fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
- solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
- myrank,nproc,ier,&
- d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
- d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
- d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
- d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
- coorg_send_ps_velocity_model,RGB_send_ps_velocity_model, &
- coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model, &
- d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
- d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
- d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
- coorg_send_ps_element_mesh,color_send_ps_element_mesh, &
- coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
- d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
- coorg_send_ps_abs,coorg_recv_ps_abs, &
- d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface, &
- d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
- coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
- d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field, &
- d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
- coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
-
- else if(imagetype == 3 .and. p_sv) then
-
- if (myrank == 0) write(IOUT,*) 'drawing acceleration vector as small arrows...'
-
- call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,accels_poroelastic,&
- elastic,poroelastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
- nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
- it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
- poroelastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
- simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
- any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
- fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
- solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
- myrank,nproc,ier,&
- d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
- d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
- d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
- d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
- coorg_send_ps_velocity_model,RGB_send_ps_velocity_model, &
- coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model, &
- d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
- d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
- d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
- coorg_send_ps_element_mesh,color_send_ps_element_mesh, &
- coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
- d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
- coorg_send_ps_abs,coorg_recv_ps_abs, &
- d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface, &
- d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
- coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
- d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field, &
- d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
- coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
-
- else if(imagetype == 4 .or. .not. p_sv) then
-
- if (myrank == 0) write(IOUT,*) 'cannot draw scalar pressure field or y-component field as a vector plot, skipping...'
-
- else
- call exit_MPI('wrong type for snapshots')
- endif
-
- if (myrank == 0 .and. imagetype /= 4 .and. p_sv) write(IOUT,*) 'PostScript file written'
-
- endif
-
-!
-!---- display color image
-!
- if(output_color_image) then
-
- if (myrank == 0) write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color,' for time step ',it
-
- if(imagetype == 1) then
-
- if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) component of displacement vector...'
-
- call compute_vector_whole_medium(potential_acoustic,displ_elastic,displs_poroelastic,&
- elastic,poroelastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
- nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- else if(imagetype == 2) then
-
- if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) component of velocity vector...'
-
- call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,velocs_poroelastic,&
- elastic,poroelastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
- nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- else if(imagetype == 3) then
-
- if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) component of acceleration vector...'
-
- call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,accels_poroelastic,&
- elastic,poroelastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
- nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
- numat,kmato,density,rhoext,assign_external_model)
-
- else if(imagetype == 4 .and. p_sv) then
-
- if (myrank == 0) write(IOUT,*) 'drawing image of pressure field...'
-
- call compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,&
- displs_poroelastic,displw_poroelastic,elastic,poroelastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
- npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
- numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
- c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,e1,e11, &
- TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
-
- else if(imagetype == 4 .and. .not. p_sv) then
- call exit_MPI('cannot draw pressure field for SH (membrane) waves')
- else
- call exit_MPI('wrong type for snapshots')
- endif
-
- image_color_data(:,:) = 0.d0
-
- do k = 1, nb_pixel_loc
- j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
- i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
- if(p_sv) then !P-SH waves, plot vertical component or pressure
- image_color_data(i,j) = vector_field_display(3,iglob_image_color(i,j))
- else !SH (membrane) waves, plot y-component
- image_color_data(i,j) = vector_field_display(2,iglob_image_color(i,j))
- endif
- enddo
-
-! assembling array image_color_data on process zero for color output
-#ifdef USE_MPI
- if (nproc > 1) then
- if (myrank == 0) then
-
- do iproc = 1, nproc-1
- call MPI_RECV(data_pixel_recv(1),nb_pixel_per_proc(iproc+1), MPI_DOUBLE_PRECISION, &
- iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
-
- do k = 1, nb_pixel_per_proc(iproc+1)
- j = ceiling(real(num_pixel_recv(k,iproc+1)) / real(NX_IMAGE_color))
- i = num_pixel_recv(k,iproc+1) - (j-1)*NX_IMAGE_color
- image_color_data(i,j) = data_pixel_recv(k)
- enddo
- enddo
-
- else
- do k = 1, nb_pixel_loc
- j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
- i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
- if(p_sv) then !P-SH waves, plot vertical component or pressure
- data_pixel_send(k) = vector_field_display(3,iglob_image_color(i,j))
- else !SH (membrane) waves, plot y-component
- data_pixel_send(k) = vector_field_display(2,iglob_image_color(i,j))
- endif
- enddo
-
- call MPI_SEND(data_pixel_send(1),nb_pixel_loc,MPI_DOUBLE_PRECISION, 0, 43, MPI_COMM_WORLD, ier)
-
- endif
- endif
-
-#endif
-
- if (myrank == 0) then
- call create_color_image(image_color_data,iglob_image_color, &
- NX_IMAGE_color,NZ_IMAGE_color,it,cutsnaps,image_color_vp_display)
- write(IOUT,*) 'Color image created'
- endif
-
- endif
-
-!---- save temporary or final seismograms
-! suppress seismograms if we generate traces of the run for analysis with "ParaVer", because time consuming
- if(.not. GENERATE_PARAVER_TRACES) &
- call write_seismograms(sisux,sisuz,siscurl,station_name,network_name,NSTEP, &
- nrecloc,which_proc_receiver,nrec,myrank,deltat,seismotype,st_xval,t0, &
- NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current,p_sv)
-
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
-
- endif
-
-#ifdef USE_MPI
-! add a barrier if we generate traces of the run for analysis with "ParaVer"
- if(GENERATE_PARAVER_TRACES) call MPI_BARRIER(MPI_COMM_WORLD,ier)
-#endif
-
- enddo ! end of the main time loop
-
- if((SAVE_FORWARD .and. SIMULATION_TYPE==1) .or. SIMULATION_TYPE ==2) then
- if(any_acoustic) then
- close(65)
- close(66)
- close(67)
- close(68)
- endif
- if(any_elastic) then
- close(35)
- close(36)
- close(37)
- close(38)
- endif
- if(any_poroelastic) then
- close(25)
- close(45)
- close(26)
- close(46)
- close(29)
- close(47)
- close(28)
- close(48)
- endif
- endif
-
-!
-!--- save last frame
-!
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_elastic) then
- if ( myrank == 0 ) then
- write(IOUT,*)
- write(IOUT,*) 'Saving elastic last frame...'
- write(IOUT,*)
- endif
- write(outputname,'(a,i6.6,a)') 'lastframe_elastic',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
- if(p_sv)then !P-SV waves
- do j=1,npoin
- write(55) displ_elastic(1,j), displ_elastic(3,j), &
- veloc_elastic(1,j), veloc_elastic(3,j), &
- accel_elastic(1,j), accel_elastic(3,j)
- enddo
- else !SH (membrane) waves
- do j=1,npoin
- write(55) displ_elastic(2,j), &
- veloc_elastic(2,j), &
- accel_elastic(2,j)
- enddo
- endif
- close(55)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_poroelastic) then
- if ( myrank == 0 ) then
- write(IOUT,*)
- write(IOUT,*) 'Saving poroelastic last frame...'
- write(IOUT,*)
- endif
- write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
- write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_w',myrank,'.bin'
- open(unit=56,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
- do j=1,npoin
- write(55) (displs_poroelastic(i,j), i=1,NDIM), &
- (velocs_poroelastic(i,j), i=1,NDIM), &
- (accels_poroelastic(i,j), i=1,NDIM)
- write(56) (displw_poroelastic(i,j), i=1,NDIM), &
- (velocw_poroelastic(i,j), i=1,NDIM), &
- (accelw_poroelastic(i,j), i=1,NDIM)
- enddo
- close(55)
- close(56)
- endif
-
- if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_acoustic) then
- if ( myrank == 0 ) then
- write(IOUT,*)
- write(IOUT,*) 'Saving acoustic last frame...'
- write(IOUT,*)
- endif
- write(outputname,'(a,i6.6,a)') 'lastframe_acoustic',myrank,'.bin'
- open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
- do j=1,npoin
- write(55) potential_acoustic(j),&
- potential_dot_acoustic(j),&
- potential_dot_dot_acoustic(j)
- enddo
- close(55)
- endif
-
-
- deallocate(v0x_left)
- deallocate(v0z_left)
- deallocate(t0x_left)
- deallocate(t0z_left)
-
- deallocate(v0x_right)
- deallocate(v0z_right)
- deallocate(t0x_right)
- deallocate(t0z_right)
-
- deallocate(v0x_bot)
- deallocate(v0z_bot)
- deallocate(t0x_bot)
- deallocate(t0z_bot)
-
-!---- close energy file and create a gnuplot script to display it
- if(OUTPUT_ENERGY .and. myrank == 0) then
- close(IOUT_ENERGY)
- open(unit=IOUT_ENERGY,file='plotenergy',status='unknown')
- write(IOUT_ENERGY,*) 'set term postscript landscape color solid "Helvetica" 22'
- write(IOUT_ENERGY,*) 'set output "energy.ps"'
- write(IOUT_ENERGY,*) 'set xlabel "Time (s)"'
- write(IOUT_ENERGY,*) 'set ylabel "Energy (J)"'
- write(IOUT_ENERGY,*) 'plot "energy.gnu" us 1:4 t ''Total Energy'' w l 1, "energy.gnu" us 1:3 t ''Potential Energy'' w l 2'
- close(IOUT_ENERGY)
- endif
-
- if (.not. any_poroelastic) then
-open(unit=1001,file='DATA/model_velocity.dat_output',status='unknown')
- if ( .NOT. assign_external_model) then
-allocate(rho_local(ngllx,ngllz,nspec)); rho_local=0.
-allocate(vp_local(ngllx,ngllz,nspec)); vp_local=0.
-allocate(vs_local(ngllx,ngllz,nspec)); vs_local=0.
-!! write(1001,*) npoin
-!! do iglob = 1,npoin
-!! write(1001,*) coord(1,iglob),coord(2,iglob),rho_global(iglob),vp_global(iglob),vs_global(iglob)
-!! end do
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- rho_local(i,j,ispec) = density(1,kmato(ispec))
- vp_local(i,j,ispec) = sqrt(poroelastcoef(3,1,kmato(ispec))/density(1,kmato(ispec)))
- vs_local(i,j,ispec) = sqrt(poroelastcoef(2,1,kmato(ispec))/density(1,kmato(ispec)))
- write(1001,'(I10, 5F13.4)') iglob, coord(1,iglob),coord(2,iglob),&
- rho_local(i,j,ispec),vp_local(i,j,ispec),vs_local(i,j,ispec)
- end do
- end do
- end do
- else
-!! write(1001,*) npoin
-!! do iglob = 1,npoin
-!! write(1001,*) coord(1,iglob),coord(2,iglob),rhoext_global(iglob),vpext_global(iglob),vsext_global(iglob)
-!! end do
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- write(1001,'(I10,5F13.4)') iglob, coord(1,iglob),coord(2,iglob),&
- rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec)
- end do
- end do
- end do
- endif
-close(1001)
- endif
-
-! print exit banner
- if (myrank == 0) call datim(simulation_title)
-
-!
-!---- close output file
-!
- if(IOUT /= ISTANDARD_OUTPUT) close(IOUT)
-
-!
-!---- end MPI
-!
-#ifdef USE_MPI
- call MPI_FINALIZE(ier)
-#endif
-
-!
-!---- formats
-!
-
- 400 format(/1x,41('=')/,' = T i m e e v o l u t i o n l o o p ='/1x,41('=')/)
-
- end program specfem2D
-
Deleted: seismo/2D/SPECFEM2D/trunk/spline_routines.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/spline_routines.f90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/spline_routines.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,174 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! compute spline coefficients
-
- subroutine spline_construction(xpoint,ypoint,npoint,tangent_first_point,tangent_last_point,spline_coefficients)
-
- implicit none
-
-! tangent to the spline imposed at the first and last points
- double precision, intent(in) :: tangent_first_point,tangent_last_point
-
-! number of input points and coordinates of the input points
- integer, intent(in) :: npoint
- double precision, dimension(npoint), intent(in) :: xpoint,ypoint
-
-! spline coefficients output by the routine
- double precision, dimension(npoint), intent(out) :: spline_coefficients
-
- integer :: i
-
- double precision, dimension(:), allocatable :: temporary_array
-
- allocate(temporary_array(npoint))
-
- spline_coefficients(1) = - 1.d0 / 2.d0
-
- temporary_array(1) = (3.d0/(xpoint(2)-xpoint(1)))*((ypoint(2)-ypoint(1))/(xpoint(2)-xpoint(1))-tangent_first_point)
-
- do i = 2,npoint-1
-
- spline_coefficients(i) = ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))-1.d0) &
- / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
-
- temporary_array(i) = (6.d0*((ypoint(i+1)-ypoint(i))/(xpoint(i+1)-xpoint(i)) &
- - (ypoint(i)-ypoint(i-1))/(xpoint(i)-xpoint(i-1)))/(xpoint(i+1)-xpoint(i-1)) &
- - (xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*temporary_array(i-1)) &
- / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
-
- enddo
-
- spline_coefficients(npoint) = ((3.d0/(xpoint(npoint)-xpoint(npoint-1))) &
- * (tangent_last_point-(ypoint(npoint)-ypoint(npoint-1))/(xpoint(npoint)-xpoint(npoint-1))) &
- - 1.d0/2.d0*temporary_array(npoint-1))/(1.d0/2.d0*spline_coefficients(npoint-1)+1.d0)
-
- do i = npoint-1,1,-1
- spline_coefficients(i) = spline_coefficients(i)*spline_coefficients(i+1) + temporary_array(i)
- enddo
-
- deallocate(temporary_array)
-
- end subroutine spline_construction
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! evaluate a spline
-
- subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate_spline,y_spline_obtained)
-
- implicit none
-
-! number of input points and coordinates of the input points
- integer, intent(in) :: npoint
- double precision, dimension(npoint), intent(in) :: xpoint,ypoint
-
-! spline coefficients to use
- double precision, dimension(npoint), intent(in) :: spline_coefficients
-
-! abscissa at which we need to evaluate the value of the spline
- double precision, intent(in):: x_evaluate_spline
-
-! ordinate evaluated by the routine for the spline at this abscissa
- double precision, intent(out):: y_spline_obtained
-
- integer :: index_loop,index_lower,index_higher
-
- double precision :: coef1,coef2
-
-! initialize to the whole interval
- index_lower = 1
- index_higher = npoint
-
-! determine the right interval to use, by dichotomy
- do while (index_higher - index_lower > 1)
-! compute the middle of the interval
- index_loop = (index_higher + index_lower) / 2
- if(xpoint(index_loop) > x_evaluate_spline) then
- index_higher = index_loop
- else
- index_lower = index_loop
- endif
- enddo
-
-! test that the interval obtained does not have a size of zero
-! (this could happen for instance in the case of duplicates in the input list of points)
- if(xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation'
-
- coef1 = (xpoint(index_higher) - x_evaluate_spline) / (xpoint(index_higher) - xpoint(index_lower))
- coef2 = (x_evaluate_spline - xpoint(index_lower)) / (xpoint(index_higher) - xpoint(index_lower))
-
- y_spline_obtained = coef1*ypoint(index_lower) + coef2*ypoint(index_higher) + &
- ((coef1**3 - coef1)*spline_coefficients(index_lower) + &
- (coef2**3 - coef2)*spline_coefficients(index_higher))*((xpoint(index_higher) - xpoint(index_lower))**2)/6.d0
-
- end subroutine spline_evaluation
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-!--- spline to describe the interfaces
-
-double precision function value_spline(x,xinterface,zinterface,coefs_interface,npoints_interface)
-
- implicit none
-
- integer npoints_interface
- double precision x,xp
- double precision, dimension(npoints_interface) :: xinterface,zinterface,coefs_interface
-
- value_spline = 0.d0
-
- xp = x
-
- ! assign the value on the edge if point is outside the model
- if(xp < xinterface(1)) xp = xinterface(1)
- if(xp > xinterface(npoints_interface)) xp = xinterface(npoints_interface)
-
- call spline_evaluation(xinterface,zinterface,coefs_interface,npoints_interface,xp,value_spline)
-
-end function value_spline
Copied: seismo/2D/SPECFEM2D/trunk/src/adj_seismogram.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/adj_seismogram.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/adj_seismogram.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/adj_seismogram.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,176 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ program adj_seismogram
+
+! This program cuts a certain portion of the seismograms and convert it
+! into the adjoint source for generating banana-dougnut kernels
+
+ implicit none
+!
+!!!! user edit
+ integer, parameter :: NSTEP = 3000
+ integer, parameter :: nrec = 1
+ double precision, parameter :: t0 = 12
+ double precision, parameter :: deltat = 6d-2
+ double precision, parameter :: EPS = 1.d-40
+!!!!
+ integer :: itime,icomp,istart,iend,nlen,irec,NDIM,NDIMr,adj_comp
+ double precision :: time,tstart(nrec),tend(nrec)
+ character(len=150), dimension(nrec) :: station_name
+ double precision, dimension(NSTEP) :: time_window
+ double precision :: seism(NSTEP,3),Nnorm,seism_win(NSTEP)
+ double precision :: seism_veloc(NSTEP),seism_accel(NSTEP),ft_bar(NSTEP)
+ character(len=3) :: compr(2),comp(3)
+ character(len=150) :: filename,filename2
+
+ NDIM=3
+ comp = (/"BHX","BHY","BHZ"/)
+
+!!!! user edit
+! which calculation: P-SV (use (1)) or SH (membrane) (use (2)) waves
+ NDIMr=2 !(1)
+! NDIMr=1 !(2)
+! list of stations
+ station_name(1) = 'S0001'
+ tstart(1) = 100d0 + t0
+ tend(1) = 120d0 + t0
+! which calculation: P-SV (use (1)) or SH (membrane) (use (2)) waves
+ compr = (/"BHX","BHZ"/) !(1)
+! compr = (/"BHY","dummy"/) !(2)
+! chose the component for the adjoint source (adj_comp = 1: X, 2:Y, 3:Z)
+ adj_comp = 1
+!!!!
+
+ do irec =1,nrec
+
+ do icomp = 1, NDIMr
+
+ filename = 'OUTPUT_FILES/'//trim(station_name(irec))//'.AA.'// compr(icomp) // '.semd'
+ open(unit = 10, file = trim(filename))
+
+ do itime = 1,NSTEP
+ read(10,*) time , seism(itime,icomp)
+ enddo
+
+ enddo
+
+ if(NDIMr==2)then
+ seism(:,3) = seism(:,2)
+ seism(:,2) = 0.d0
+ else
+ seism(:,2) = seism(:,1)
+ seism(:,1) = 0.d0
+ seism(:,3) = 0.d0
+ endif
+
+ close(10)
+
+
+ istart = max(floor(tstart(irec)/deltat),1)
+ iend = min(floor(tend(irec)/deltat),NSTEP)
+ print*,'istart =',istart, 'iend =', iend
+ print*,'tstart =',istart*deltat, 'tend =', iend*deltat
+ if(istart >= iend) stop 'check istart,iend'
+ nlen = iend - istart +1
+
+ do icomp = 1, NDIM
+
+ print*,comp(icomp)
+
+ filename = 'OUTPUT_FILES/'//trim(station_name(irec))//'.AA.'// comp(icomp) // '.adj'
+ open(unit = 11, file = trim(filename))
+
+ time_window(:) = 0.d0
+ seism_win(:) = seism(:,icomp)
+ seism_veloc(:) = 0.d0
+ seism_accel(:) = 0.d0
+
+ do itime =istart,iend
+! time_window(itime) = 1.d0 - cos(pi*(itime-1)/NSTEP+1)**10 ! cosine window
+ time_window(itime) = 1.d0 - (2* (dble(itime) - istart)/(iend-istart) -1.d0)**2 ! Welch window
+ enddo
+
+ do itime = 2,NSTEP-1
+ seism_veloc(itime) = (seism_win(itime+1) - seism_win(itime-1))/(2*deltat)
+ enddo
+ seism_veloc(1) = (seism_win(2) - seism_win(1))/deltat
+ seism_veloc(NSTEP) = (seism_win(NSTEP) - seism_win(NSTEP-1))/deltat
+
+ do itime = 2,NSTEP-1
+ seism_accel(itime) = (seism_veloc(itime+1) - seism_veloc(itime-1))/(2*deltat)
+ enddo
+ seism_accel(1) = (seism_veloc(2) - seism_veloc(1))/deltat
+ seism_accel(NSTEP) = (seism_veloc(NSTEP) - seism_veloc(NSTEP-1))/deltat
+
+ Nnorm = deltat * sum(time_window(:) * seism_win(:) * seism_accel(:))
+! Nnorm = deltat * sum(time_window(:) * seism_veloc(:) * seism_veloc(:))
+! cross-correlation traveltime adjoint source
+ if(abs(Nnorm) > EPS) then
+! ft_bar(:) = - seism_veloc(:) * time_window(:) / Nnorm
+ ft_bar(:) = seism_veloc(:) * time_window(:) / Nnorm
+ print*,'Norm =', Nnorm
+ else
+ print *, 'norm < EPS for file '
+ print*,'Norm =', Nnorm
+ ft_bar(:) = 0.d0
+ endif
+
+ do itime =1,NSTEP
+ if(icomp == adj_comp) then
+ write(11,*) (itime-1)*deltat - t0, ft_bar(itime)
+ else
+ write(11,*) (itime-1)*deltat - t0, 0.d0
+ endif
+ enddo
+
+ enddo
+ close(11)
+
+ enddo
+ print*,'*************************'
+ print*,'The input files (S****.AA.BHX/BHY/BHZ.adj) needed to run the adjoint simulation are in OUTPUT_FILES'
+ print*,'*************************'
+
+ end program adj_seismogram
Copied: seismo/2D/SPECFEM2D/trunk/src/assemble_MPI.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/assemble_MPI.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/assemble_MPI.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/assemble_MPI.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,563 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!
+! This file contains subroutines related to assembling (of the mass matrix, potential_dot_dot and
+! accel_elastic, accels_poroelastic, accelw_poroelastic).
+! These subroutines are for the most part not used in the sequential version.
+!
+
+
+#ifdef USE_MPI
+
+!-----------------------------------------------
+! Assembling the mass matrix.
+!-----------------------------------------------
+ subroutine assemble_MPI_scalar(array_val1,npoin_val1, &
+ array_val2,npoin_val2, &
+ array_val3,array_val4,npoin_val3, &
+ ninterface, max_interface_size, max_ibool_interfaces_size_ac, &
+ max_ibool_interfaces_size_el, &
+ max_ibool_interfaces_size_po, &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic, &
+ ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic,nibool_interfaces_elastic, &
+ nibool_interfaces_poroelastic,my_neighbours)
+
+ implicit none
+
+ include 'constants.h'
+ include 'mpif.h'
+
+ integer, intent(in) :: ninterface
+ integer, intent(in) :: max_interface_size
+ integer, intent(in) :: max_ibool_interfaces_size_ac,max_ibool_interfaces_size_el, &
+ max_ibool_interfaces_size_po
+ integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic,nibool_interfaces_elastic, &
+ nibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(in) :: my_neighbours
+ ! array to assemble
+ ! acoustic
+ integer :: npoin_val1
+ real(kind=CUSTOM_REAL), dimension(npoin_val1), intent(inout) :: array_val1
+ ! elastic
+ integer :: npoin_val2
+ real(kind=CUSTOM_REAL), dimension(npoin_val2), intent(inout) :: array_val2
+ ! poroelastic
+ integer :: npoin_val3
+ real(kind=CUSTOM_REAL), dimension(npoin_val3), intent(inout) :: array_val3,array_val4
+
+ integer :: ipoin, num_interface
+ integer :: ier
+ integer :: i
+ double precision, dimension(max_ibool_interfaces_size_ac+max_ibool_interfaces_size_el+&
+ 2*max_ibool_interfaces_size_po, ninterface) :: &
+ buffer_send_faces_scalar, &
+ buffer_recv_faces_scalar
+ integer, dimension(MPI_STATUS_SIZE) :: msg_status
+ integer, dimension(ninterface) :: msg_requests
+
+ buffer_send_faces_scalar(:,:) = 0.d0
+ buffer_recv_faces_scalar(:,:) = 0.d0
+
+ do num_interface = 1, ninterface
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_acoustic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val1(ibool_interfaces_acoustic(i,num_interface))
+ end do
+
+ do i = 1, nibool_interfaces_elastic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val2(ibool_interfaces_elastic(i,num_interface))
+ end do
+
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val3(ibool_interfaces_poroelastic(i,num_interface))
+ end do
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val4(ibool_interfaces_poroelastic(i,num_interface))
+ end do
+
+ ! non-blocking synchronous send request
+ call MPI_ISSEND( buffer_send_faces_scalar(1,num_interface), &
+ nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface)+&
+ nibool_interfaces_poroelastic(num_interface)+nibool_interfaces_poroelastic(num_interface), &
+ MPI_DOUBLE_PRECISION, &
+ my_neighbours(num_interface), 11, &
+ MPI_COMM_WORLD, msg_requests(num_interface), ier)
+
+ end do
+
+ do num_interface = 1, ninterface
+
+ ! starts a blocking receive
+ call MPI_recv ( buffer_recv_faces_scalar(1,num_interface), &
+ nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface)+&
+ nibool_interfaces_poroelastic(num_interface)+nibool_interfaces_poroelastic(num_interface), &
+ MPI_DOUBLE_PRECISION, &
+ my_neighbours(num_interface), 11, &
+ MPI_COMM_WORLD, msg_status(1), ier)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_acoustic(num_interface)
+ ipoin = ipoin + 1
+ array_val1(ibool_interfaces_acoustic(i,num_interface)) = &
+ array_val1(ibool_interfaces_acoustic(i,num_interface)) &
+ + buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+
+ do i = 1, nibool_interfaces_elastic(num_interface)
+ ipoin = ipoin + 1
+ array_val2(ibool_interfaces_elastic(i,num_interface)) = &
+ array_val2(ibool_interfaces_elastic(i,num_interface)) &
+ + buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ array_val3(ibool_interfaces_poroelastic(i,num_interface)) = &
+ array_val3(ibool_interfaces_poroelastic(i,num_interface)) &
+ + buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ array_val4(ibool_interfaces_poroelastic(i,num_interface)) = &
+ array_val4(ibool_interfaces_poroelastic(i,num_interface)) &
+ + buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+
+ end do
+
+ ! synchronizes MPI processes
+ call MPI_BARRIER(mpi_comm_world,ier)
+
+ end subroutine assemble_MPI_scalar
+
+
+!-----------------------------------------------
+! Assembling potential_dot_dot for acoustic elements :
+! the buffers are filled, the Isend and Irecv are started here, then
+! contributions are added.
+! The previous version included communication overlap using persistent
+! communication, but the merging of the outer and inner elements rendered
+! overlap no longer possible, while persistent communications were removed
+! because trace tool MPITrace does not yet instrument those.
+! Particular care should be taken concerning possible optimisations of the
+! communication scheme.
+!-----------------------------------------------
+ subroutine assemble_MPI_vector_ac(array_val1,npoin, &
+ ninterface, ninterface_acoustic, &
+ inum_interfaces_acoustic, &
+ max_interface_size, max_ibool_interfaces_size_ac,&
+ ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
+ tab_requests_send_recv_acoustic, &
+ buffer_send_faces_vector_ac, &
+ buffer_recv_faces_vector_ac, &
+ my_neighbours )
+
+ implicit none
+
+ include 'constants.h'
+ include 'mpif.h'
+ include 'precision_mpi.h'
+
+ integer, intent(in) :: npoin
+ integer, intent(in) :: ninterface, ninterface_acoustic
+ integer, dimension(ninterface), intent(in) :: inum_interfaces_acoustic
+ integer, intent(in) :: max_interface_size
+ integer, intent(in) :: max_ibool_interfaces_size_ac
+ integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_acoustic
+ integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic
+ integer, dimension(ninterface_acoustic*2), intent(inout) :: tab_requests_send_recv_acoustic
+ real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(inout) :: &
+ buffer_send_faces_vector_ac
+ real(kind=CUSTOM_REAL), dimension(max_ibool_interfaces_size_ac,ninterface_acoustic), intent(inout) :: &
+ buffer_recv_faces_vector_ac
+ ! array to assemble
+ real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1
+ integer, dimension(ninterface), intent(in) :: my_neighbours
+
+ ! local parameters
+ integer :: ipoin, num_interface,iinterface,ier,iglob
+ integer, dimension(MPI_STATUS_SIZE) :: status_acoustic
+
+ ! initializes buffers
+ buffer_send_faces_vector_ac(:,:) = 0._CUSTOM_REAL
+ buffer_recv_faces_vector_ac(:,:) = 0._CUSTOM_REAL
+ tab_requests_send_recv_acoustic(:) = 0
+
+ ! loops over acoustic interfaces only
+ do iinterface = 1, ninterface_acoustic
+
+ ! gets interface index in the range of all interfaces [1,ninterface]
+ num_interface = inum_interfaces_acoustic(iinterface)
+
+ ! loops over all interface points
+ do ipoin = 1, nibool_interfaces_acoustic(num_interface)
+ iglob = ibool_interfaces_acoustic(ipoin,num_interface)
+
+ ! copies array values to buffer
+ buffer_send_faces_vector_ac(ipoin,iinterface) = array_val1(iglob)
+ end do
+
+ end do
+
+ do iinterface = 1, ninterface_acoustic
+
+ ! gets global interface index
+ num_interface = inum_interfaces_acoustic(iinterface)
+
+ ! non-blocking synchronous send
+ call MPI_ISSEND( buffer_send_faces_vector_ac(1,iinterface), &
+ nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_acoustic(iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_start')
+ end if
+
+ ! starts a non-blocking receive
+ call MPI_Irecv ( buffer_recv_faces_vector_ac(1,iinterface), &
+ nibool_interfaces_acoustic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_acoustic(ninterface_acoustic+iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector')
+ end if
+
+ end do
+
+
+ ! waits for MPI requests to complete (recv)
+ ! each wait returns once the specified MPI request completed
+ do iinterface = 1, ninterface_acoustic
+ call MPI_Wait (tab_requests_send_recv_acoustic(ninterface_acoustic+iinterface), &
+ status_acoustic, ier)
+ enddo
+
+ ! assembles the array values
+ do iinterface = 1, ninterface_acoustic
+
+ ! gets global interface index
+ num_interface = inum_interfaces_acoustic(iinterface)
+
+ ! loops over all interface points
+ do ipoin = 1, nibool_interfaces_acoustic(num_interface)
+ iglob = ibool_interfaces_acoustic(ipoin,num_interface)
+ ! adds buffer contribution
+ array_val1(iglob) = array_val1(iglob) + buffer_recv_faces_vector_ac(ipoin,iinterface)
+ end do
+
+ end do
+
+
+ ! waits for MPI requests to complete (send)
+ ! just to make sure that all sending is done
+ do iinterface = 1, ninterface_acoustic
+ call MPI_Wait (tab_requests_send_recv_acoustic(iinterface), status_acoustic, ier)
+ enddo
+
+
+ end subroutine assemble_MPI_vector_ac
+
+
+!-----------------------------------------------
+! Assembling accel_elastic for elastic elements :
+! the buffers are filled, the Isend and Irecv are started here, then
+! contributions are added.
+! The previous version included communication overlap using persistent
+! communication, but the merging of the outer and inner elements rendered
+! overlap no longer possible, while persistent communications were removed
+! because trace tool MPITrace does not yet instrument those.
+! Particular care should be taken concerning possible optimisations of the
+! communication scheme.
+!-----------------------------------------------
+ subroutine assemble_MPI_vector_el(array_val2,npoin, &
+ ninterface, ninterface_elastic, &
+ inum_interfaces_elastic, &
+ max_interface_size, max_ibool_interfaces_size_el,&
+ ibool_interfaces_elastic, nibool_interfaces_elastic, &
+ tab_requests_send_recv_elastic, &
+ buffer_send_faces_vector_el, &
+ buffer_recv_faces_vector_el, &
+ my_neighbours)
+
+ implicit none
+
+ include 'constants.h'
+ include 'mpif.h'
+ include 'precision_mpi.h'
+
+ integer, intent(in) :: npoin
+ integer, intent(in) :: ninterface, ninterface_elastic
+ integer, dimension(ninterface), intent(in) :: inum_interfaces_elastic
+ integer, intent(in) :: max_interface_size
+ integer, intent(in) :: max_ibool_interfaces_size_el
+ integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_elastic
+ integer, dimension(ninterface), intent(in) :: nibool_interfaces_elastic
+ integer, dimension(ninterface_elastic*2), intent(inout) :: tab_requests_send_recv_elastic
+ real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_el,ninterface_elastic), intent(inout) :: &
+ buffer_send_faces_vector_el
+ real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_el,ninterface_elastic), intent(inout) :: &
+ buffer_recv_faces_vector_el
+ ! array to assemble
+ real(kind=CUSTOM_REAL), dimension(3,npoin), intent(inout) :: array_val2
+ integer, dimension(ninterface), intent(in) :: my_neighbours
+
+ integer :: ipoin, num_interface, iinterface, ier, i
+ integer, dimension(MPI_STATUS_SIZE) :: status_elastic
+
+
+ do iinterface = 1, ninterface_elastic
+
+ num_interface = inum_interfaces_elastic(iinterface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_elastic(num_interface)
+ buffer_send_faces_vector_el(ipoin+1:ipoin+3,iinterface) = &
+ array_val2(:,ibool_interfaces_elastic(i,num_interface))
+ ipoin = ipoin + 3
+ end do
+
+ end do
+
+ do iinterface = 1, ninterface_elastic
+
+ num_interface = inum_interfaces_elastic(iinterface)
+
+ call MPI_ISSEND( buffer_send_faces_vector_el(1,iinterface), &
+ 3*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_elastic(iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_el')
+ end if
+
+ call MPI_Irecv ( buffer_recv_faces_vector_el(1,iinterface), &
+ 3*nibool_interfaces_elastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_elastic(ninterface_elastic+iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_el')
+ end if
+
+ end do
+
+ do iinterface = 1, ninterface_elastic*2
+
+ call MPI_Wait (tab_requests_send_recv_elastic(iinterface), status_elastic, ier)
+
+ enddo
+
+ do iinterface = 1, ninterface_elastic
+
+ num_interface = inum_interfaces_elastic(iinterface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_elastic(num_interface)
+ array_val2(:,ibool_interfaces_elastic(i,num_interface)) = &
+ array_val2(:,ibool_interfaces_elastic(i,num_interface)) &
+ + buffer_recv_faces_vector_el(ipoin+1:ipoin+3,iinterface)
+ ipoin = ipoin + 3
+ end do
+
+ end do
+
+ end subroutine assemble_MPI_vector_el
+
+
+!-----------------------------------------------
+! Assembling accel_elastic for elastic elements :
+! the buffers are filled, the Isend and Irecv are started here, then
+! contributions are added.
+! The previous version included communication overlap using persistent
+! communication, but the merging of the outer and inner elements rendered
+! overlap no longer possible, while persistent communications were removed
+! because trace tool MPITrace does not yet instrument those.
+! Particular care should be taken concerning possible optimisations of the
+! communication scheme.
+!-----------------------------------------------
+ subroutine assemble_MPI_vector_po(array_val3,array_val4,npoin, &
+ ninterface, ninterface_poroelastic, &
+ inum_interfaces_poroelastic, &
+ max_interface_size, max_ibool_interfaces_size_po,&
+ ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
+ tab_requests_send_recv_poro, &
+ buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
+ my_neighbours)
+
+ implicit none
+
+ include 'constants.h'
+ include 'mpif.h'
+ include 'precision_mpi.h'
+
+ integer, intent(in) :: npoin
+ integer, intent(in) :: ninterface, ninterface_poroelastic
+ integer, dimension(ninterface), intent(in) :: inum_interfaces_poroelastic
+ integer, intent(in) :: max_interface_size
+ integer, intent(in) :: max_ibool_interfaces_size_po
+ integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(in) :: nibool_interfaces_poroelastic
+ integer, dimension(ninterface_poroelastic*4), intent(inout) :: tab_requests_send_recv_poro
+ real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(inout) :: &
+ buffer_send_faces_vector_pos,buffer_send_faces_vector_pow
+ real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(inout) :: &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow
+ ! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(inout) :: array_val3,array_val4
+ integer, dimension(ninterface), intent(in) :: my_neighbours
+
+ integer :: ipoin, num_interface, iinterface, ier, i
+ integer, dimension(MPI_STATUS_SIZE) :: status_poroelastic
+
+
+ do iinterface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(iinterface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ buffer_send_faces_vector_pos(ipoin+1:ipoin+2,iinterface) = &
+ array_val3(:,ibool_interfaces_poroelastic(i,num_interface))
+ ipoin = ipoin + 2
+ end do
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ buffer_send_faces_vector_pow(ipoin+1:ipoin+2,iinterface) = &
+ array_val4(:,ibool_interfaces_poroelastic(i,num_interface))
+ ipoin = ipoin + 2
+ end do
+
+ end do
+
+ do iinterface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(iinterface)
+
+ call MPI_ISSEND( buffer_send_faces_vector_pos(1,iinterface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poro(iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pos')
+ end if
+
+ call MPI_Irecv ( buffer_recv_faces_vector_pos(1,iinterface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poro(ninterface_poroelastic+iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pos')
+ end if
+
+ call MPI_ISSEND( buffer_send_faces_vector_pow(1,iinterface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poro(ninterface_poroelastic*2+iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pow')
+ end if
+
+ call MPI_Irecv ( buffer_recv_faces_vector_pow(1,iinterface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poro(ninterface_poroelastic*3+iinterface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pow')
+ end if
+
+ end do
+
+ do iinterface = 1, ninterface_poroelastic*4
+
+ call MPI_Wait (tab_requests_send_recv_poro(iinterface), status_poroelastic, ier)
+
+ enddo
+
+ do iinterface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(iinterface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) = &
+ array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_vector_pos(ipoin+1:ipoin+2,iinterface)
+ ipoin = ipoin + 2
+ end do
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ array_val4(:,ibool_interfaces_poroelastic(i,num_interface)) = &
+ array_val4(:,ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_vector_pow(ipoin+1:ipoin+2,iinterface)
+ ipoin = ipoin + 2
+ end do
+
+ end do
+
+ end subroutine assemble_MPI_vector_po
+
+#endif
Copied: seismo/2D/SPECFEM2D/trunk/src/attenuation_compute_param.c (from rev 17978, seismo/2D/SPECFEM2D/trunk/attenuation_compute_param.c)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/attenuation_compute_param.c (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/attenuation_compute_param.c 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,1176 @@
+
+/* See Liu, Anderson & Kanamori (Geophysical Journal of the Royal Astronomical Society, vol. 47, p. 41-58, 1976) for details */
+
+/* cleaned by Dimitri Komatitsch, University of Pau, France, July 2007 */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <stdio.h>
+#include <math.h>
+#include <sgtty.h>
+#include <signal.h>
+#include <stdlib.h>
+
+/* useful constants */
+
+#define PI 3.14159265358979
+#define PI2 6.28318530717958
+
+/* Underscores should or should not follow this function name, depending on the compiler and its options.
+ It is called in "attenuation_model.f90".
+*/
+int attenuation_compute_param_(int *nmech_in, double *Qp_in, double *Qs_in, double *f1_in, double *f2_in,
+ double *tau_sigma_nu1, double *tau_sigma_nu2,
+ double *tau_epsilon_nu1, double *tau_epsilon_nu2
+ )
+
+{
+ int xmgr, n, i, j, plot, nu;
+ double Q_s, target_Qp, target_Qs;
+ double f1, f2, Q, om0, Omega;
+ double a, b;
+ double kappa, mu, kappa0, mu0, kappaR, muR;
+ double *tau_s, *tau_e;
+ double *dvector();
+ void constant_Q2_sub(),plot_modulus();
+ void free_dvector();
+
+
+ /* We get the arguments passed in fortran by adress. */
+ target_Qp = *Qp_in; /* target value of Qp */
+ target_Qs = *Qs_in; /* target value of Qs */
+ n = *nmech_in; /* number of mechanisms */
+ f1 = *f1_in; /* shortest frequency (Hz) */
+ f2 = *f2_in; /* highest frequency (Hz) */
+
+ /*
+ printf("target value of Qp: ");
+ scanf("%lf",&target_Qp);
+ printf("%lf\n",target_Qp);
+
+ printf("target value of Qs: ");
+ scanf("%lf",&target_Qs);
+ printf("%lf\n",target_Qs);
+
+ printf("shortest frequency (Hz): ");
+ scanf("%lf",&f1);
+ printf("%lf\n",f1);
+
+ printf("highest frequency (Hz): ");
+ scanf("%lf",&f2);
+ printf("%lf\n",f2);
+
+ printf("number of mechanisms: ");
+ scanf("%d",&n);
+ printf("%d\n",n);
+ */
+
+/* DK DK printf("1 = use xmgr 0 = do not use xmgr: "); */
+/* scanf("%d",&xmgr); */
+ xmgr = 0;
+
+ if (f2 < f1) {
+ printf("T2 > T1\n");
+ exit; }
+
+ if (target_Qp <= 0.0001) {
+ printf("Qp cannot be negative or null\n");
+ exit; }
+
+ if (target_Qs <= 0.0001) {
+ printf("Qs cannot be negative or null\n");
+ exit; }
+
+ if (n < 1) {
+ printf("n < 1\n");
+ exit; }
+
+ om0 = PI2 * pow(10.0, 0.5 * (log10(f1) + log10(f2)));
+
+ /*
+ printf("\n! put this in file constants.h\n\n");
+
+ printf("! number of standard linear solids for attenuation\n");
+ printf(" integer, parameter :: N_SLS = %d\n\n",n);
+
+ printf("! put this in file attenuation_model.f90\n\n");
+
+ printf("! frequency range: %lf Hz - %lf Hz\n", f1 , f2);
+ printf("! central frequency in log scale in Hz = %20.15f\n",om0 / PI2);
+
+ printf("! target constant attenuation factor Qp = %20.10lf\n", target_Qp);
+ printf("! target constant attenuation factor Qs = %20.10lf\n\n", target_Qs);
+
+ printf("! tau_sigma evenly spaced in log frequency, do not depend on value of Q\n\n");
+ */
+
+ plot = 0;
+
+/* loop on the Qp dilatation mode (nu = 1) and Qs shear mode (nu = 2) */
+ for (nu = 1; nu <= 2; nu++) {
+
+/* assign Qp or Qs to generic variable Q_s which is used for the calculations */
+ if (nu == 1) { Q_s = target_Qp ; }
+ if (nu == 2) { Q_s = target_Qs ; }
+
+ tau_s = dvector(1, n);
+ tau_e = dvector(1, n);
+
+ constant_Q2_sub(f1, f2, n, Q_s, tau_s, tau_e, xmgr);
+
+/* output in Fortran90 format */
+ for (i = 1; i <= n; i++) {
+ /*
+ printf(" tau_sigma_nu%d(%1d) = %30.20lfd0\n", nu, i, tau_s[i]);
+ */
+ /* We put the results in tau_sigma_nu to get them in fortran. */
+ if ( nu == 1 ) {
+ tau_sigma_nu1[i-1] = tau_s[i];
+ }
+ if ( nu == 2 ) {
+ tau_sigma_nu2[i-1] = tau_s[i];
+ }
+
+ }
+ //printf("\n");
+
+ for (i = 1; i <= n; i++) {
+ /*
+ printf(" tau_epsilon_nu%d(%1d) = %30.20lfd0\n", nu, i, tau_e[i]);
+ */
+ /* We put the results in tau_epsilon_nu to get them in fortran. */
+ if ( nu == 1 ) {
+ tau_epsilon_nu1[i-1] = tau_e[i];
+ }
+ if ( nu == 2 ) {
+ tau_epsilon_nu2[i-1] = tau_e[i];
+ }
+
+ }
+ //printf("\n");
+
+ free_dvector(tau_s, 1, n);
+ free_dvector(tau_e, 1, n);
+
+ }
+
+}
+
+void plot_modulus(f1, f2, n, m, mR, Q, tau_e, tau_s ,xmgr)
+ int n, xmgr;
+ double f1, f2, m, mR, Q, *tau_e, *tau_s;
+{
+int pid, i;
+double exp1, exp2, dexp, expo;
+double f, om, Omega;
+double a, b, m_om, m_prem;
+char strng[180];
+int getpid(), system();
+FILE *fp_v, *fp_q;
+
+pid = getpid();
+sprintf(strng, "modulus%1d", pid);
+if((fp_v=fopen(strng,"w"))==NULL) {
+ puts("cannot open file\n");
+ exit;
+}
+sprintf(strng, "Q%1d", pid);
+if((fp_q=fopen(strng,"w"))==NULL) {
+ puts("cannot open file\n");
+ exit;
+}
+
+exp1 = log10(f1) - 2.0;
+exp2 = log10(f2) + 2.0;
+dexp = (exp2 - exp1) / 100.0;
+for (expo = exp1; expo <= exp2; expo += dexp) {
+ f = pow(10.0, expo);
+ om = PI2 * f;
+ a = 1.0;
+ b = 0.0;
+ for (i = 1; i <= n; i++) {
+ a -= om * om * tau_e[i] * (tau_e[i] - tau_s[i]) /
+ (1.0 + om * om * tau_e[i] * tau_e[i]);
+ b += om * (tau_e[i] - tau_s[i]) /
+ (1.0 + om * om * tau_e[i] * tau_e[i]);
+ }
+ Omega=a*(sqrt(1.0+b*b/(a*a))-1.0);
+ m_om = 2.0*mR* Omega/(b*b);
+ m_prem = m * (1.0 + (2.0 / (PI * Q)) * log(om / PI2));
+ fprintf(fp_v, "%f %f %f\n", expo, m_om/m, m_prem/m);
+ if (om >= PI2 * f1 && om <= PI2 * f2) {
+ fprintf(fp_q, "%f %f %f\n", expo, 1.0/atan(b/a), Q);
+ }
+}
+fclose(fp_v);
+fclose(fp_q);
+
+/* DK DK call xmgr to plot curves if needed */
+
+if (xmgr == 1) {
+ sprintf(strng, "xmgr -nxy Q%1d", pid);
+ system(strng);
+ sprintf(strng, "xmgr -nxy modulus%1d", pid);
+ system(strng);
+ sprintf(strng, "rm modulus%1d", pid);
+ system(strng);
+ sprintf(strng, "rm Q%1d", pid);
+ system(strng);
+}
+
+}
+
+#include <malloc.h>
+#include <stdio.h>
+
+void nrerror(error_text)
+char error_text[];
+{
+ void exit();
+
+ fprintf(stderr,"Numerical Recipes run-time error...\n");
+ fprintf(stderr,"%s\n",error_text);
+ fprintf(stderr,"...now exiting to system...\n");
+ exit(1);
+}
+
+float *vector(nl,nh)
+int nl,nh;
+{
+ float *v;
+
+ v=(float *)malloc((unsigned) (nh-nl+1)*sizeof(float));
+ if (!v) nrerror("allocation failure in vector()");
+ return v-nl;
+}
+
+int *ivector(nl,nh)
+int nl,nh;
+{
+ int *v;
+
+ v=(int *)malloc((unsigned) (nh-nl+1)*sizeof(int));
+ if (!v) nrerror("allocation failure in ivector()");
+ return v-nl;
+}
+
+double *dvector(nl,nh)
+int nl,nh;
+{
+ double *v;
+
+ v=(double *)malloc((unsigned) (nh-nl+1)*sizeof(double));
+ if (!v) nrerror("allocation failure in dvector()");
+ return v-nl;
+}
+
+
+
+float **matrix(nrl,nrh,ncl,nch)
+int nrl,nrh,ncl,nch;
+{
+ int i;
+ float **m;
+
+ m=(float **) malloc((unsigned) (nrh-nrl+1)*sizeof(float*));
+ if (!m) nrerror("allocation failure 1 in matrix()");
+ m -= nrl;
+
+ for(i=nrl;i<=nrh;i++) {
+ m[i]=(float *) malloc((unsigned) (nch-ncl+1)*sizeof(float));
+ if (!m[i]) nrerror("allocation failure 2 in matrix()");
+ m[i] -= ncl;
+ }
+ return m;
+}
+
+double **dmatrix(nrl,nrh,ncl,nch)
+int nrl,nrh,ncl,nch;
+{
+ int i;
+ double **m;
+
+ m=(double **) malloc((unsigned) (nrh-nrl+1)*sizeof(double*));
+ if (!m) nrerror("allocation failure 1 in dmatrix()");
+ m -= nrl;
+
+ for(i=nrl;i<=nrh;i++) {
+ m[i]=(double *) malloc((unsigned) (nch-ncl+1)*sizeof(double));
+ if (!m[i]) nrerror("allocation failure 2 in dmatrix()");
+ m[i] -= ncl;
+ }
+ return m;
+}
+
+int **imatrix(nrl,nrh,ncl,nch)
+int nrl,nrh,ncl,nch;
+{
+ int i,**m;
+
+ m=(int **)malloc((unsigned) (nrh-nrl+1)*sizeof(int*));
+ if (!m) nrerror("allocation failure 1 in imatrix()");
+ m -= nrl;
+
+ for(i=nrl;i<=nrh;i++) {
+ m[i]=(int *)malloc((unsigned) (nch-ncl+1)*sizeof(int));
+ if (!m[i]) nrerror("allocation failure 2 in imatrix()");
+ m[i] -= ncl;
+ }
+ return m;
+}
+
+
+
+float **submatrix(a,oldrl,oldrh,oldcl,oldch,newrl,newcl)
+float **a;
+int oldrl,oldrh,oldcl,oldch,newrl,newcl;
+{
+ int i,j;
+ float **m;
+
+ m=(float **) malloc((unsigned) (oldrh-oldrl+1)*sizeof(float*));
+ if (!m) nrerror("allocation failure in submatrix()");
+ m -= newrl;
+
+ for(i=oldrl,j=newrl;i<=oldrh;i++,j++) m[j]=a[i]+oldcl-newcl;
+
+ return m;
+}
+
+
+
+void free_vector(v,nl,nh)
+float *v;
+int nl,nh;
+{
+ free((char*) (v+nl));
+}
+
+void free_ivector(v,nl,nh)
+int *v,nl,nh;
+{
+ free((char*) (v+nl));
+}
+
+void free_dvector(v,nl,nh)
+double *v;
+int nl,nh;
+{
+ free((char*) (v+nl));
+}
+
+
+
+void free_matrix(m,nrl,nrh,ncl,nch)
+float **m;
+int nrl,nrh,ncl,nch;
+{
+ int i;
+
+ for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
+ free((char*) (m+nrl));
+}
+
+void free_dmatrix(m,nrl,nrh,ncl,nch)
+double **m;
+int nrl,nrh,ncl,nch;
+{
+ int i;
+
+ for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
+ free((char*) (m+nrl));
+}
+
+void free_imatrix(m,nrl,nrh,ncl,nch)
+int **m;
+int nrl,nrh,ncl,nch;
+{
+ int i;
+
+ for(i=nrh;i>=nrl;i--) free((char*) (m[i]+ncl));
+ free((char*) (m+nrl));
+}
+
+
+
+void free_submatrix(b,nrl,nrh,ncl,nch)
+float **b;
+int nrl,nrh,ncl,nch;
+{
+ free((char*) (b+nrl));
+}
+
+
+
+float **convert_matrix(a,nrl,nrh,ncl,nch)
+float *a;
+int nrl,nrh,ncl,nch;
+{
+ int i,j,nrow,ncol;
+ float **m;
+
+ nrow=nrh-nrl+1;
+ ncol=nch-ncl+1;
+ m = (float **) malloc((unsigned) (nrow)*sizeof(float*));
+ if (!m) nrerror("allocation failure in convert_matrix()");
+ m -= nrl;
+ for(i=0,j=nrl;i<=nrow-1;i++,j++) m[j]=a+ncol*i-ncl;
+ return m;
+}
+
+
+
+void free_convert_matrix(b,nrl,nrh,ncl,nch)
+float **b;
+int nrl,nrh,ncl,nch;
+{
+ free((char*) (b+nrl));
+}
+
+#include <math.h>
+
+#define NMAX 5000
+#define ALPHA 1.0
+#define BETA 0.5
+#define GAMMA 2.0
+
+#define GET_PSUM for (j=1;j<=ndim;j++) { for (i=1,sum=0.0;i<=mpts;i++)\
+ sum += p[i][j]; psum[j]=sum;}
+
+void amoeba(p,y,ndim,ftol,funk,nfunk)
+float **p,y[],ftol,(*funk)();
+int ndim,*nfunk;
+{
+ int i,j,ilo,ihi,inhi,mpts=ndim+1;
+ float ytry,ysave,sum,rtol,amotry(),*psum,*vector();
+ void nrerror(),free_vector();
+
+ psum=vector(1,ndim);
+ *nfunk=0;
+ GET_PSUM
+ for (;;) {
+ ilo=1;
+ ihi = y[1]>y[2] ? (inhi=2,1) : (inhi=1,2);
+ for (i=1;i<=mpts;i++) {
+ if (y[i] < y[ilo]) ilo=i;
+ if (y[i] > y[ihi]) {
+ inhi=ihi;
+ ihi=i;
+ } else if (y[i] > y[inhi])
+ if (i != ihi) inhi=i;
+ }
+ rtol=2.0*fabs(y[ihi]-y[ilo])/(fabs(y[ihi])+fabs(y[ilo]));
+ if (rtol < ftol) break;
+ if (*nfunk >= NMAX) nrerror("Too many iterations in AMOEBA");
+ ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,-ALPHA);
+ if (ytry <= y[ilo])
+ ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,GAMMA);
+ else if (ytry >= y[inhi]) {
+ ysave=y[ihi];
+ ytry=amotry(p,y,psum,ndim,funk,ihi,nfunk,BETA);
+ if (ytry >= ysave) {
+ for (i=1;i<=mpts;i++) {
+ if (i != ilo) {
+ for (j=1;j<=ndim;j++) {
+ psum[j]=0.5*(p[i][j]+p[ilo][j]);
+ p[i][j]=psum[j];
+ }
+ y[i]=(*funk)(psum);
+ }
+ }
+ *nfunk += ndim;
+ GET_PSUM
+ }
+ }
+ }
+ free_vector(psum,1,ndim);
+}
+
+float amotry(p,y,psum,ndim,funk,ihi,nfunk,fac)
+float **p,*y,*psum,(*funk)(),fac;
+int ndim,ihi,*nfunk;
+{
+ int j;
+ float fac1,fac2,ytry,*ptry,*vector();
+ void nrerror(),free_vector();
+
+ ptry=vector(1,ndim);
+ fac1=(1.0-fac)/ndim;
+ fac2=fac1-fac;
+ for (j=1;j<=ndim;j++) ptry[j]=psum[j]*fac1-p[ihi][j]*fac2;
+ ytry=(*funk)(ptry);
+ ++(*nfunk);
+ if (ytry < y[ihi]) {
+ y[ihi]=ytry;
+ for (j=1;j<=ndim;j++) {
+ psum[j] += ptry[j]-p[ihi][j];
+ p[ihi][j]=ptry[j];
+ }
+ }
+ free_vector(ptry,1,ndim);
+ return ytry;
+}
+
+#undef ALPHA
+#undef BETA
+#undef GAMMA
+#undef NMAX
+
+void spline(x,y,n,yp1,ypn,y2)
+float x[],y[],yp1,ypn,y2[];
+int n;
+{
+ int i,k;
+ float p,qn,sig,un,*u,*vector();
+ void free_vector();
+
+ u=vector(1,n-1);
+ if (yp1 > 0.99e30)
+ y2[1]=u[1]=0.0;
+ else {
+ y2[1] = -0.5;
+ u[1]=(3.0/(x[2]-x[1]))*((y[2]-y[1])/(x[2]-x[1])-yp1);
+ }
+ for (i=2;i<=n-1;i++) {
+ sig=(x[i]-x[i-1])/(x[i+1]-x[i-1]);
+ p=sig*y2[i-1]+2.0;
+ y2[i]=(sig-1.0)/p;
+ u[i]=(y[i+1]-y[i])/(x[i+1]-x[i]) - (y[i]-y[i-1])/(x[i]-x[i-1]);
+ u[i]=(6.0*u[i]/(x[i+1]-x[i-1])-sig*u[i-1])/p;
+ }
+ if (ypn > 0.99e30)
+ qn=un=0.0;
+ else {
+ qn=0.5;
+ un=(3.0/(x[n]-x[n-1]))*(ypn-(y[n]-y[n-1])/(x[n]-x[n-1]));
+ }
+ y2[n]=(un-qn*u[n-1])/(qn*y2[n-1]+1.0);
+ for (k=n-1;k>=1;k--)
+ y2[k]=y2[k]*y2[k+1]+u[k];
+ free_vector(u,1,n-1);
+}
+
+void splint(xa,ya,y2a,n,x,y)
+float xa[],ya[],y2a[],x,*y;
+int n;
+{
+ int klo,khi,k;
+ float h,b,a;
+ void nrerror();
+
+ klo=1;
+ khi=n;
+ while (khi-klo > 1) {
+ k=(khi+klo) >> 1;
+ if (xa[k] > x) khi=k;
+ else klo=k;
+ }
+ h=xa[khi]-xa[klo];
+ if (h == 0.0) nrerror("Bad XA input to routine SPLINT");
+ a=(xa[khi]-x)/h;
+ b=(x-xa[klo])/h;
+ *y=a*ya[klo]+b*ya[khi]+((a*a*a-a)*y2a[klo]+(b*b*b-b)*y2a[khi])*(h*h)/6.0;
+}
+
+#define FUNC(x) ((*func)(x))
+
+float trapzd(func,a,b,n)
+float a,b;
+float (*func)(); /* ANSI: float (*func)(float); */
+int n;
+{
+ float x,tnm,sum,del;
+ static float s;
+ static int it;
+ int j;
+
+ if (n == 1) {
+ it=1;
+ return (s=0.5*(b-a)*(FUNC(a)+FUNC(b)));
+ } else {
+ tnm=it;
+ del=(b-a)/tnm;
+ x=a+0.5*del;
+ for (sum=0.0,j=1;j<=it;j++,x+=del) sum += FUNC(x);
+ it *= 2;
+ s=0.5*(s+(b-a)*sum/tnm);
+ return s;
+ }
+}
+
+#include <math.h>
+
+#define EPS 0.5e-5
+#define JMAX 20
+#define JMAXP JMAX+1
+#define K 5
+
+float qromb(func,a,b)
+float a,b;
+float (*func)();
+{
+ float ss,dss,trapzd();
+ float s[JMAXP+1],h[JMAXP+1];
+ int j;
+ void polint(),nrerror();
+
+ h[1]=1.0;
+ for (j=1;j<=JMAX;j++) {
+ s[j]=trapzd(func,a,b,j);
+ if (j >= K) {
+ polint(&h[j-K],&s[j-K],K,0.0,&ss,&dss);
+ if (fabs(dss) < EPS*fabs(ss)) return ss;
+ }
+ s[j+1]=s[j];
+ h[j+1]=0.25*h[j];
+ }
+ nrerror("Too many steps in routine QROMB");
+}
+
+#undef EPS
+#undef JMAX
+#undef JMAXP
+#undef K
+
+#include <math.h>
+
+void polint(xa,ya,n,x,y,dy)
+float xa[],ya[],x,*y,*dy;
+int n;
+{
+ int i,m,ns=1;
+ float den,dif,dift,ho,hp,w;
+ float *c,*d,*vector();
+ void nrerror(),free_vector();
+
+ dif=fabs(x-xa[1]);
+ c=vector(1,n);
+ d=vector(1,n);
+ for (i=1;i<=n;i++) {
+ if ( (dift=fabs(x-xa[i])) < dif) {
+ ns=i;
+ dif=dift;
+ }
+ c[i]=ya[i];
+ d[i]=ya[i];
+ }
+ *y=ya[ns--];
+ for (m=1;m<n;m++) {
+ for (i=1;i<=n-m;i++) {
+ ho=xa[i]-x;
+ hp=xa[i+m]-x;
+ w=c[i+1]-d[i];
+ if ( (den=ho-hp) == 0.0) nrerror("Error in routine POLINT");
+ den=w/den;
+ d[i]=hp*den;
+ c[i]=ho*den;
+ }
+ *y += (*dy=(2*ns < (n-m) ? c[ns+1] : d[ns--]));
+ }
+ free_vector(d,1,n);
+ free_vector(c,1,n);
+}
+
+#define MBIG 1000000000
+#define MSEED 161803398
+#define MZ 0
+#define FAC (1.0/MBIG)
+
+float ran3(idum)
+int *idum;
+{
+ static int inext,inextp;
+ static long ma[56];
+ static int iff=0;
+ long mj,mk;
+ int i,ii,k;
+
+ if (*idum < 0 || iff == 0) {
+ iff=1;
+ mj=MSEED-(*idum < 0 ? -*idum : *idum);
+ mj %= MBIG;
+ ma[55]=mj;
+ mk=1;
+ for (i=1;i<=54;i++) {
+ ii=(21*i) % 55;
+ ma[ii]=mk;
+ mk=mj-mk;
+ if (mk < MZ) mk += MBIG;
+ mj=ma[ii];
+ }
+ for (k=1;k<=4;k++)
+ for (i=1;i<=55;i++) {
+ ma[i] -= ma[1+(i+30) % 55];
+ if (ma[i] < MZ) ma[i] += MBIG;
+ }
+ inext=0;
+ inextp=31;
+ *idum=1;
+ }
+ if (++inext == 56) inext=1;
+ if (++inextp == 56) inextp=1;
+ mj=ma[inext]-ma[inextp];
+ if (mj < MZ) mj += MBIG;
+ ma[inext]=mj;
+ return mj*FAC;
+}
+
+#undef MBIG
+#undef MSEED
+#undef MZ
+#undef FAC
+
+#include <math.h>
+
+static double at,bt,ct;
+#define PYTHAG(a,b) ((at=fabs(a)) > (bt=fabs(b)) ? \
+(ct=bt/at,at*sqrt(1.0+ct*ct)) : (bt ? (ct=at/bt,bt*sqrt(1.0+ct*ct)): 0.0))
+
+static double maxarg1,maxarg2;
+#define MAX(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1) > (maxarg2) ?\
+ (maxarg1) : (maxarg2))
+#define SIGN(a,b) ((b) >= 0.0 ? fabs(a) : -fabs(a))
+
+void dsvdcmp(a,m,n,w,v)
+double **a,*w,**v;
+int m,n;
+{
+ int flag,i,its,j,jj,k,l,nm;
+ double c,f,h,s,x,y,z;
+ double anorm=0.0,g=0.0,scale=0.0;
+ double *rv1,*dvector();
+ void nrerror(),free_dvector();
+
+ if (m < n) nrerror("SVDCMP: You must augment A with extra zero rows");
+ rv1=dvector(1,n);
+ for (i=1;i<=n;i++) {
+ l=i+1;
+ rv1[i]=scale*g;
+ g=s=scale=0.0;
+ if (i <= m) {
+ for (k=i;k<=m;k++) scale += fabs(a[k][i]);
+ if (scale) {
+ for (k=i;k<=m;k++) {
+ a[k][i] /= scale;
+ s += a[k][i]*a[k][i];
+ }
+ f=a[i][i];
+ g = -SIGN(sqrt(s),f);
+ h=f*g-s;
+ a[i][i]=f-g;
+ if (i != n) {
+ for (j=l;j<=n;j++) {
+ for (s=0.0,k=i;k<=m;k++) s += a[k][i]*a[k][j];
+ f=s/h;
+ for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
+ }
+ }
+ for (k=i;k<=m;k++) a[k][i] *= scale;
+ }
+ }
+ w[i]=scale*g;
+ g=s=scale=0.0;
+ if (i <= m && i != n) {
+ for (k=l;k<=n;k++) scale += fabs(a[i][k]);
+ if (scale) {
+ for (k=l;k<=n;k++) {
+ a[i][k] /= scale;
+ s += a[i][k]*a[i][k];
+ }
+ f=a[i][l];
+ g = -SIGN(sqrt(s),f);
+ h=f*g-s;
+ a[i][l]=f-g;
+ for (k=l;k<=n;k++) rv1[k]=a[i][k]/h;
+ if (i != m) {
+ for (j=l;j<=m;j++) {
+ for (s=0.0,k=l;k<=n;k++) s += a[j][k]*a[i][k];
+ for (k=l;k<=n;k++) a[j][k] += s*rv1[k];
+ }
+ }
+ for (k=l;k<=n;k++) a[i][k] *= scale;
+ }
+ }
+ anorm=MAX(anorm,(fabs(w[i])+fabs(rv1[i])));
+ }
+ for (i=n;i>=1;i--) {
+ if (i < n) {
+ if (g) {
+ for (j=l;j<=n;j++)
+ v[j][i]=(a[i][j]/a[i][l])/g;
+ for (j=l;j<=n;j++) {
+ for (s=0.0,k=l;k<=n;k++) s += a[i][k]*v[k][j];
+ for (k=l;k<=n;k++) v[k][j] += s*v[k][i];
+ }
+ }
+ for (j=l;j<=n;j++) v[i][j]=v[j][i]=0.0;
+ }
+ v[i][i]=1.0;
+ g=rv1[i];
+ l=i;
+ }
+ for (i=n;i>=1;i--) {
+ l=i+1;
+ g=w[i];
+ if (i < n)
+ for (j=l;j<=n;j++) a[i][j]=0.0;
+ if (g) {
+ g=1.0/g;
+ if (i != n) {
+ for (j=l;j<=n;j++) {
+ for (s=0.0,k=l;k<=m;k++) s += a[k][i]*a[k][j];
+ f=(s/a[i][i])*g;
+ for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
+ }
+ }
+ for (j=i;j<=m;j++) a[j][i] *= g;
+ } else {
+ for (j=i;j<=m;j++) a[j][i]=0.0;
+ }
+ ++a[i][i];
+ }
+ for (k=n;k>=1;k--) {
+ for (its=1;its<=30;its++) {
+ flag=1;
+ for (l=k;l>=1;l--) {
+ nm=l-1;
+ if (fabs(rv1[l])+anorm == anorm) {
+ flag=0;
+ break;
+ }
+ if (fabs(w[nm])+anorm == anorm) break;
+ }
+ if (flag) {
+ c=0.0;
+ s=1.0;
+ for (i=l;i<=k;i++) {
+ f=s*rv1[i];
+ if (fabs(f)+anorm != anorm) {
+ g=w[i];
+ h=PYTHAG(f,g);
+ w[i]=h;
+ h=1.0/h;
+ c=g*h;
+ s=(-f*h);
+ for (j=1;j<=m;j++) {
+ y=a[j][nm];
+ z=a[j][i];
+ a[j][nm]=y*c+z*s;
+ a[j][i]=z*c-y*s;
+ }
+ }
+ }
+ }
+ z=w[k];
+ if (l == k) {
+ if (z < 0.0) {
+ w[k] = -z;
+ for (j=1;j<=n;j++) v[j][k]=(-v[j][k]);
+ }
+ break;
+ }
+ if (its == 60) nrerror("No convergence in 60 SVDCMP iterations");
+ x=w[l];
+ nm=k-1;
+ y=w[nm];
+ g=rv1[nm];
+ h=rv1[k];
+ f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y);
+ g=PYTHAG(f,1.0);
+ f=((x-z)*(x+z)+h*((y/(f+SIGN(g,f)))-h))/x;
+ c=s=1.0;
+ for (j=l;j<=nm;j++) {
+ i=j+1;
+ g=rv1[i];
+ y=w[i];
+ h=s*g;
+ g=c*g;
+ z=PYTHAG(f,h);
+ rv1[j]=z;
+ c=f/z;
+ s=h/z;
+ f=x*c+g*s;
+ g=g*c-x*s;
+ h=y*s;
+ y=y*c;
+ for (jj=1;jj<=n;jj++) {
+ x=v[jj][j];
+ z=v[jj][i];
+ v[jj][j]=x*c+z*s;
+ v[jj][i]=z*c-x*s;
+ }
+ z=PYTHAG(f,h);
+ w[j]=z;
+ if (z) {
+ z=1.0/z;
+ c=f*z;
+ s=h*z;
+ }
+ f=(c*g)+(s*y);
+ x=(c*y)-(s*g);
+ for (jj=1;jj<=m;jj++) {
+ y=a[jj][j];
+ z=a[jj][i];
+ a[jj][j]=y*c+z*s;
+ a[jj][i]=z*c-y*s;
+ }
+ }
+ rv1[l]=0.0;
+ rv1[k]=f;
+ w[k]=x;
+ }
+ }
+ free_dvector(rv1,1,n);
+}
+
+#undef SIGN
+#undef MAX
+#undef PYTHAG
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <stdio.h>
+#include <math.h>
+#include <sgtty.h>
+#include <signal.h>
+#include <stdlib.h>
+
+/* useful constants */
+
+#define PI 3.14159265358979
+#define PI2 6.28318530717958
+
+void constant_Q2_sub(f1, f2, n, Q, tau_s, tau_e, xmgr)
+
+ int n, xmgr;
+ double f1, f2, Q;
+ double *tau_s, *tau_e;
+{
+ int i,j;
+ double *x1, *x2;
+ double *gradient, **hessian;
+ double *dvector(), **dmatrix();
+ void derivatives();
+ void initialize(), invert();
+ void free_dvector(), free_dmatrix();
+
+ if (f2 < f1) {
+ printf("T2 > T1\n");
+ exit;
+ }
+ if (Q < 0.0) {
+ printf("Q < 0\n");
+ exit;
+ }
+ if (n < 1) {
+ printf("n < 1\n");
+ exit;
+ }
+
+ x1 = dvector(1, n);
+ x2 = dvector(1, n);
+ gradient = dvector(1, n);
+ hessian = dmatrix(1, n, 1, n);
+ for(i=1;i<=n;i++) {
+ x1[i]=0.0;
+ x2[i]=0.0;
+ gradient[i]=0.0;
+ for(j=1;j<=n;j++) hessian[i][j]=0.0;
+ }
+
+ initialize(f1, f2, n, Q, x1, x2);
+
+ derivatives(f1, f2, n, Q, x1, x2, gradient, hessian);
+
+ invert(x1, gradient, hessian, n);
+
+ free_dvector(gradient, 1, n);
+ free_dmatrix(hessian, 1, n, 1, n);
+
+ for (i = 1; i <= n; i++) {
+ tau_e[i]=x1[i] + x2[i];
+ }
+ for (i = 1; i <= n; i++) {
+ tau_s[i]=x2[i];
+ }
+
+ free_dvector(x1, 1, n);
+ free_dvector(x2, 1, n);
+
+}
+
+void initialize(f1, f2, n, Q, x1, x2)
+ int n;
+ double f1, f2, Q, *x1, *x2;
+{
+int i;
+double q, omega, *tau_e, *tau_s;
+double exp1, exp2, dexp, expo;
+double *dvector();
+void free_dvector();
+
+tau_e = dvector(1, n);
+tau_s = dvector(1, n);
+if (n > 1) {
+ exp1 = log10(f1);
+ exp2 = log10(f2);
+ dexp = (exp2 - exp1) / ((double) (n - 1));
+ q = 1.0 / ((n - 1.0) * Q);
+ for (i = 1, expo = exp1; i <= n; i++, expo += dexp) {
+ omega = PI2 * pow(10.0, expo);
+ tau_s[i] = 1.0 / omega;
+ tau_e[i] = tau_s[i] * (1.0 + q) / (1.0 - q);
+ }
+} else {
+ q = 1.0 / Q;
+ exp1 = log10(f1);
+ exp2 = log10(f2);
+ expo=(exp1+exp2)/2.0;
+ omega = PI2 * pow(10.0, expo);
+ tau_s[1] = 1.0 / omega;
+ tau_e[1] = tau_s[1] * (1.0 + q) / (1.0 - q);
+}
+/*
+ * x1 denotes the parameter tau_e - tau_s and x2 denotes the parameter tau_s
+ */
+for (i = 1; i <= n; i++) {
+ x1[i] = tau_e[i] - tau_s[i];
+ x2[i] = tau_s[i];
+}
+
+free_dvector(tau_e, 1, n);
+free_dvector(tau_s, 1, n);
+}
+
+double penalty(f1, f2, n, Q, x1, x2)
+ int n;
+ double f1, f2, Q, *x1, *x2;
+{
+int i;
+double exp1, exp2, dexp, expo;
+double pnlt;
+double f, df, omega;
+double tau_e, tau_s, a, b, Q_omega;
+
+exp1 = log10(f1);
+exp2 = log10(f2);
+dexp = (exp2 - exp1) / 100.0;
+pnlt = 0.0;
+for (expo = exp1; expo <= exp2; expo += dexp) {
+ f = pow(10.0, expo);
+ df = pow(10.0, expo + dexp) - f;
+ omega = PI2 * f;
+ a = (double) (1 - n);
+ b = 0.0;
+ for (i = 1; i <= n; i++) {
+ tau_e = x1[i] + x2[i];
+ tau_s = x2[i];
+ a += (1.0 + omega * omega * tau_e * tau_s) /
+ (1.0 + omega * omega * tau_s * tau_s);
+ b += omega * (tau_e - tau_s) /
+ (1.0 + omega * omega * tau_s * tau_s);
+ }
+ Q_omega = a / b;
+ pnlt += pow(1.0 / Q - 1.0 / Q_omega, 2.0) * df;
+}
+pnlt /= (f2 - f1);
+return pnlt;
+}
+
+
+void derivatives(f1, f2, n, Q, x1, x2, gradient, hessian)
+ int n;
+ double f1, f2, Q, *x1, *x2;
+ double *gradient, **hessian;
+{
+int i, j;
+double exp1, exp2, dexp, expo;
+double f, df, omega;
+double *dadp, *dbdp, *dqdp, d2qdp2;
+double tau_e, tau_s, a, b, Q_omega;
+double *dvector();
+void free_dvector();
+
+dadp = dvector(1, n);
+dbdp = dvector(1, n);
+dqdp = dvector(1, n);
+exp1 = log10(f1);
+exp2 = log10(f2);
+dexp = (exp2 - exp1) / 100.0;
+for (i = 1; i <= n; i++) {
+ gradient[i] = 0.0;
+ for (j = 1; j <= i; j++) {
+ hessian[j][i] = 0.0;
+ hessian[j][i] = hessian[i][j];
+ }
+}
+for (expo = exp1; expo <= exp2; expo += dexp) {
+ f = pow(10.0, expo);
+ df = pow(10.0, expo + dexp) - f;
+ omega = PI2 * f;
+ a = (double) (1 - n);
+ b = 0.0;
+ for (i = 1; i <= n; i++) {
+ tau_e = x1[i] + x2[i];
+ tau_s = x2[i];
+ a += (1.0 + omega * omega * tau_e * tau_s) /
+ (1.0 + omega * omega * tau_s * tau_s);
+ b += omega * (tau_e - tau_s) /
+ (1.0 + omega * omega * tau_s * tau_s);
+ dadp[i] = omega * omega * tau_s / (1.0 + omega * omega * tau_s * tau_s);
+ dbdp[i] = omega / (1.0 + omega * omega * tau_s * tau_s);
+ }
+ Q_omega = a / b;
+ for (i = 1; i <= n; i++) {
+ dqdp[i] = (dbdp[i] - (b / a) * dadp[i]) / a;
+ gradient[i] += 2.0 * (1.0 / Q_omega - 1.0 / Q) * dqdp[i] * df / (f2 - f1);
+ for (j = 1; j <= i; j++) {
+ d2qdp2 = -(dadp[i] * dbdp[j] + dbdp[i] * dadp[j]
+ - 2.0 * (b / a) * dadp[i] * dadp[j]) / (a * a);
+ hessian[i][j] += (2.0 * dqdp[i] * dqdp[j] + 2.0 * (1.0 / Q_omega - 1.0 / Q) * d2qdp2)
+ * df / (f2 - f1);
+ hessian[j][i] = hessian[i][j];
+ }
+ }
+}
+free_dvector(dadp, 1, n);
+free_dvector(dbdp, 1, n);
+free_dvector(dqdp, 1, n);
+}
+
+void invert(x, b, A, n)
+ int n;
+ double *x;
+ double *b, **A;
+{
+int i, j, k;
+double *dvector(), **dmatrix();
+double *xp, *W, **V, **A_inverse;
+void free_dvector(), free_dmatrix(), dsvdcmp();
+
+xp = dvector(1, n);
+W = dvector(1, n);
+V = dmatrix(1, n, 1, n);
+A_inverse = dmatrix(1, n, 1, n);
+dsvdcmp(A, n, n, W, V);
+for (i = 1; i <= n; i++)
+ for (j = 1; j <= n; j++)
+ V[i][j] = (1.0 / W[i]) * A[j][i];
+for (i = 1; i <= n; i++) {
+ for (j = 1; j <= n; j++) {
+ A_inverse[i][j] = 0.0;
+ for (k = 1; k <= n; k++)
+ A_inverse[i][j] += A[i][k] * V[k][j];
+ }
+}
+free_dvector(W, 1, n);
+free_dmatrix(V, 1, n, 1, n);
+for (i = 1; i <= n; i++) {
+ xp[i] = x[i];
+ for (j = 1; j <= n; j++) {
+ xp[i] -= A_inverse[i][j] * b[j];
+ }
+ x[i] = xp[i];
+}
+free_dvector(xp, 1, n);
+free_dmatrix(A_inverse, 1, n, 1, n);
+}
Copied: seismo/2D/SPECFEM2D/trunk/src/attenuation_model.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/attenuation_model.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/attenuation_model.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/attenuation_model.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,153 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine attenuation_model(N_SLS,Qp_attenuation,Qs_attenuation,f0_attenuation, &
+ inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2)
+
+! define the attenuation constants
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: N_SLS
+ double precision :: Qp_attenuation,Qs_attenuation,f0_attenuation
+ double precision, dimension(N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
+ double precision :: Mu_nu1,Mu_nu2
+
+ integer :: i_sls
+
+ double precision, dimension(N_SLS) :: tau_epsilon_nu1,tau_sigma_nu1,tau_epsilon_nu2,tau_sigma_nu2
+
+ double precision :: f1_attenuation, f2_attenuation
+
+
+! f1 and f2 are computed as : f2/f1=12 and (log(f1)+log(f2))/2 = log(f0)
+ f1_attenuation = exp(log(f0_attenuation)-log(12.d0)/2.d0)
+ f2_attenuation = 12.d0 * f1_attenuation
+
+! Call of C function that computes attenuation parameters (function in file "attenuation_compute_param.c";
+! a main can be found in UTILS/attenuation directory).
+! Beware of underscores in this function name; depending on your compiler and compilation options, you will have to add or
+! delete underscores. Also look in file "attenuation_compute_param.c" for this issue.
+ call attenuation_compute_param(N_SLS, Qp_attenuation, Qs_attenuation, &
+ f1_attenuation,f2_attenuation, &
+ tau_sigma_nu1, tau_sigma_nu2, tau_epsilon_nu1, tau_epsilon_nu2)
+
+! attenuation constants for standard linear solids
+
+! nu1 is the dilatation mode
+! nu2 is the shear mode
+
+! array index (1) is the first standard linear solid, (2) is the second etc.
+
+! from J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993) for two memory-variable mechanisms (page 112).
+! Beware: these values implement specific values of the quality factors:
+! Qp approximately equal to 13 and Qs approximately equal to 10,
+! which means very high attenuation, see that paper for details.
+! tau_epsilon_nu1(1) = 0.0334d0
+! tau_sigma_nu1(1) = 0.0303d0
+! tau_epsilon_nu2(1) = 0.0352d0
+! tau_sigma_nu2(1) = 0.0287d0
+
+! tau_epsilon_nu1(2) = 0.0028d0
+! tau_sigma_nu1(2) = 0.0025d0
+! tau_epsilon_nu2(2) = 0.0029d0
+! tau_sigma_nu2(2) = 0.0024d0
+
+! from J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation
+! in a linear viscoelastic medium, Geophysical Journal International,
+! vol. 95, p. 597-611 (1988) for two memory-variable mechanisms (page 604).
+! Beware: these values implement specific values of the quality factors:
+! Qp approximately equal to 27 and Qs approximately equal to 20,
+! which means very high attenuation, see that paper for details.
+! tau_epsilon_nu1(1) = 0.0325305d0
+! tau_sigma_nu1(1) = 0.0311465d0
+! tau_epsilon_nu2(1) = 0.0332577d0
+! tau_sigma_nu2(1) = 0.0304655d0
+
+! tau_epsilon_nu1(2) = 0.0032530d0
+! tau_sigma_nu1(2) = 0.0031146d0
+! tau_epsilon_nu2(2) = 0.0033257d0
+! tau_sigma_nu2(2) = 0.0030465d0
+
+! values for Paul Cristini for fluid-solid ocean acoustics simulations
+
+! for N_SLS = 2
+! frequency range: 1.500000 Hz - 18.000000 Hz
+! central frequency in log scale in Hz = 5.196152422706633
+! target constant attenuation factor Q = 136.4376068115
+! tau sigma evenly spaced in log frequency, do not depend on value of Q
+
+! tau_sigma_nu1(1) = 0.10610329539459699422d0
+! tau_sigma_nu1(2) = 0.00884194128288308401d0
+
+! tau_epsilon_nu1(1) = 0.10754721280605997191d0
+! tau_epsilon_nu1(2) = 0.00895488050110176612d0
+
+! tau_epsilon_nu2(1) = tau_epsilon_nu1(1)
+! tau_epsilon_nu2(2) = tau_epsilon_nu1(2)
+! tau_sigma_nu2(1) = tau_sigma_nu1(1)
+! tau_sigma_nu2(2) = tau_sigma_nu1(2)
+
+!
+!--- other constants computed from the parameters above, do not modify
+!
+ inv_tau_sigma_nu1(:) = ONE / tau_sigma_nu1(:)
+ inv_tau_sigma_nu2(:) = ONE / tau_sigma_nu2(:)
+
+ phi_nu1(:) = (ONE - tau_epsilon_nu1(:)/tau_sigma_nu1(:)) / tau_sigma_nu1(:)
+ phi_nu2(:) = (ONE - tau_epsilon_nu2(:)/tau_sigma_nu2(:)) / tau_sigma_nu2(:)
+
+ Mu_nu1 = ONE
+ Mu_nu2 = ONE
+
+ do i_sls = 1,N_SLS
+ Mu_nu1 = Mu_nu1 - (ONE - tau_epsilon_nu1(i_sls)/tau_sigma_nu1(i_sls))
+ Mu_nu2 = Mu_nu2 - (ONE - tau_epsilon_nu2(i_sls)/tau_sigma_nu2(i_sls))
+ enddo
+
+ end subroutine attenuation_model
+
Copied: seismo/2D/SPECFEM2D/trunk/src/calendar.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/calendar.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/calendar.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/calendar.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,729 @@
+
+ integer function julian_day(yr,mo,da)
+
+ implicit none
+
+ integer yr,mo,da
+
+ integer mon(12)
+ integer lpyr
+ data mon /0,31,59,90,120,151,181,212,243,273,304,334/
+
+ julian_day = da + mon(mo)
+ if(mo>2) julian_day = julian_day + lpyr(yr)
+
+ end function julian_day
+
+! ------------------------------------------------------------------
+
+ integer function lpyr(yr)
+
+ implicit none
+
+ integer yr
+!
+!---- returns 1 if leap year
+!
+ lpyr=0
+ if(mod(yr,400) == 0) then
+ lpyr=1
+ else if(mod(yr,4) == 0) then
+ lpyr=1
+ if(mod(yr,100) == 0) lpyr=0
+ endif
+
+ end function lpyr
+
+! ------------------------------------------------------------------
+
+! function to determine if year is a leap year
+ logical function is_leap_year(yr)
+
+ implicit none
+
+ integer yr
+
+ integer, external :: lpyr
+
+!---- function lpyr above returns 1 if leap year
+ if(lpyr(yr) == 1) then
+ is_leap_year = .true.
+ else
+ is_leap_year = .false.
+ endif
+
+ end function is_leap_year
+
+
+!----------------------------------------------------------------------------------------------
+! open-source subroutines below taken from ftp://ftp.met.fsu.edu/pub/ahlquist/calendar_software
+!----------------------------------------------------------------------------------------------
+
+ integer function idaywk(jdayno)
+
+! IDAYWK = compute the DAY of the WeeK given the Julian Day number,
+! version 1.0.
+
+ implicit none
+
+! Input variable
+ integer, intent(in) :: jdayno
+! jdayno = Julian Day number starting at noon of the day in question.
+
+! Output of the function:
+! idaywk = day of the week, where 0=Sunday, 1=Monday, ..., 6=Saturday.
+
+!----------
+! Compute the day of the week given the Julian Day number.
+! You can find the Julian Day number given (day,month,year)
+! using subroutine calndr below.
+! Example: For the first day of the Gregorian calendar,
+! Friday 15 October 1582, compute the Julian day number (option 3 of
+! subroutine calndr) and compute the day of the week.
+! call calndr (3, 15, 10, 1582, jdayno)
+! write(*,*) jdayno, idaywk(jdayno)
+! The numbers printed should be 2299161 and 5, where 5 refers to Friday.
+!
+! Copyright (C) 1999 Jon Ahlquist.
+! Issued under the second GNU General Public License.
+! See www.gnu.org for details.
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+! If you find any errors, please notify:
+! Jon Ahlquist <ahlquist at met.fsu.edu>
+! Dept of Meteorology
+! Florida State University
+! Tallahassee, FL 32306-4520
+! 15 March 1999.
+!
+!-----
+
+! converted to Fortran90 by Dimitri Komatitsch,
+! University of Pau, France, January 2008.
+
+! jdSun is the Julian Day number starting at noon on any Sunday.
+! I arbitrarily chose the first Sunday after Julian Day 1,
+! which is Julian Day 6.
+ integer, parameter :: jdSun = 6
+
+ idaywk = mod(jdayno-jdSun,7)
+
+! If jdayno-jdSun < 0, then we are taking the modulus of a negative
+! number. Fortran's built-in mod function returns a negative value
+! when the argument is negative. In that case, we adjust the result
+! to a positive value.
+ if (idaywk < 0) idaywk = idaywk + 7
+
+ end function idaywk
+
+!
+!----
+!
+
+ subroutine calndr(iday,month,iyear,idayct)
+
+! CALNDR = CALeNDaR conversions, version 1.0
+
+ implicit none
+
+! specify the desired calendar conversion option.
+! in order to return the julian day number, compatible with function idaywk from above,
+! we choose option 3
+! (tested with dates: Feb, 23 2010 -> idaywk = Tue
+! Dec, 24 2009 -> idaywk = Thu
+! Oct, 15 1582 -> idaywk = Fri ...which all look o.k. )
+ integer, parameter :: ioptn = 3
+
+! Input/Output variables
+ integer, intent(inout) :: iday,month,iyear,idayct
+
+!----------
+!
+! Subroutine calndr() performs calendar calculations using either
+! the standard Gregorian calendar or the old Julian calendar.
+! This subroutine extends the definitions of these calendar systems
+! to any arbitrary year. The algorithms in this subroutine
+! will work with any date in the past or future,
+! but overflows will occur if the numbers are sufficiently large.
+! For a computer using a 32-bit integer, this routine can handle
+! any date between roughly 5.8 million BC and 5.8 million AD
+! without experiencing overflow during calculations.
+!
+! No external functions or subroutines are called.
+!
+!----------
+!
+! INPUT/OUTPUT ARGUMENTS FOR SUBROUTINE CALNDR()
+!
+! "ioptn" is the desired calendar conversion option explained below.
+! Positive option values use the standard modern Gregorian calendar.
+! Negative option values use the old Julian calendar which was the
+! standard in Europe from its institution by Julius Caesar in 45 BC
+! until at least 4 October 1582. The Gregorian and Julian calendars
+! are explained further below.
+!
+! (iday,month,iyear) is a calendar date where "iday" is the day of
+! the month, "month" is 1 for January, 2 for February, etc.,
+! and "iyear" is the year. If the year is 1968 AD, enter iyear=1968,
+! since iyear=68 would refer to 68 AD.
+! For BC years, iyear should be negative, so 45 BC would be iyear=-45.
+! By convention, there is no year 0 under the BC/AD year numbering
+! scheme. That is, years proceed as 2 BC, 1 BC, 1 AD, 2 AD, etc.,
+! without including 0. Subroutine calndr() will print an error message
+! and stop if you specify iyear=0.
+!
+! "idayct" is a day count. It is either the day number during the
+! specified year or the Julian Day number, depending on the value
+! of ioptn. By day number during the specified year, we mean
+! idayct=1 on 1 January, idayct=32 on 1 February, etc., to idayct=365
+! or 366 on 31 December, depending on whether the specified year
+! is a leap year.
+!
+! The values of input variables are not changed by this subroutine.
+!
+!
+! ALLOWABLE VALUES FOR "IOPTN" and the conversions they invoke.
+! Positive option values ( 1 to 5) use the standard Gregorian calendar.
+! Negative option values (-1 to -5) use the old Julian calendar.
+!
+! Absolute
+! value
+! of ioptn Input variable(s) Output variable(s)
+!
+! 1 iday,month,iyear idayct
+! Given a calendar date (iday,month,iyear), compute the day number
+! (idayct) during the year, where 1 January is day number 1 and
+! 31 December is day number 365 or 366, depending on whether it is
+! a leap year.
+!
+! 2 idayct,iyear iday,month
+! Given the day number of the year (idayct) and the year (iyear),
+! compute the day of the month (iday) and the month (month).
+!
+! 3 iday,month,iyear idayct
+! Given a calendar date (iday,month,iyear), compute the Julian Day
+! number (idayct) that starts at noon of the calendar date specified.
+!
+! 4 idayct iday,month,iyear
+! Given the Julian Day number (idayct) that starts at noon,
+! compute the corresponding calendar date (iday,month,iyear).
+!
+! 5 idayct iday,month,iyear
+! Given the Julian Day number (idayct) that starts at noon,
+! compute the corresponding day number for the year (iday)
+! and year (iyear). On return from calndr(), "month" will always
+! be set equal to 1 when ioptn=5.
+!
+! No inverse function is needed for ioptn=5 because it is
+! available through option 3. One simply calls calndr() with:
+! ioptn = 3,
+! iday = day number of the year instead of day of the month,
+! month = 1, and
+! iyear = whatever the desired year is.
+!
+!----------
+!
+! EXAMPLES
+! The first 6 examples are for the standard Gregorian calendar.
+! All the examples deal with 15 October 1582, which was the first day
+! of the Gregorian calendar. 15 October is the 288-th day of the year.
+! Julian Day number 2299161 began at noon on 15 October 1582.
+!
+! Find the day number during the year on 15 October 1582
+! ioptn = 1
+! call calndr (ioptn, 15, 10, 1582, idayct)
+! calndr() should return idayct=288
+!
+! Find the day of the month and month for day 288 in year 1582.
+! ioptn = 2
+! call calndr (ioptn, iday, month, 1582, 288)
+! calndr() should return iday=15 and month=10.
+!
+! Find the Julian Day number for 15 October 1582.
+! ioptn = 3
+! call calndr (ioptn, 15, 10, 1582, julian)
+! calndr() should return julian=2299161
+!
+! Find the Julian Day number for day 288 during 1582 AD.
+! When the input is day number of the year, one should specify month=1
+! ioptn = 3
+! call calndr (ioptn, 288, 1, 1582, julian)
+! calndr() should return dayct=2299161
+!
+! Find the date for Julian Day number 2299161.
+! ioptn = 4
+! call calndr (ioptn, iday, month, iyear, 2299161)
+! calndr() should return iday=15, month=10, and iyear=1582
+!
+! Find the day number during the year (iday) and year
+! for Julian Day number 2299161.
+! ioptn = 5
+! call calndr (ioptn, iday, month, iyear, 2299161)
+! calndr() should return iday=288, month=1, iyear=1582
+!
+! Given 15 October 1582 under the Gregorian calendar,
+! find the date (idayJ,imonthJ,iyearJ) under the Julian calendar.
+! To do this, we call calndr() twice, using the Julian Day number
+! as the intermediate value.
+! call calndr ( 3, 15, 10, 1582, julian)
+! call calndr (-4, idayJ, monthJ, iyearJ, julian)
+! The first call to calndr() should return julian=2299161, and
+! the second should return idayJ=5, monthJ=10, iyearJ=1582
+!
+!----------
+!
+! BASIC CALENDAR INFORMATION
+!
+! The Julian calendar was instituted by Julius Caesar in 45 BC.
+! Every fourth year is a leap year in which February has 29 days.
+! That is, the Julian calendar assumes that the year is exactly
+! 365.25 days long. Actually, the year is not quite this long.
+! The modern Gregorian calendar remedies this by omitting leap years
+! in years divisible by 100 except when the year is divisible by 400.
+! Thus, 1700, 1800, and 1900 are leap years under the Julian calendar
+! but not under the Gregorian calendar. The years 1600 and 2000 are
+! leap years under both the Julian and the Gregorian calendars.
+! Other years divisible by 4 are leap years under both calendars,
+! such as 1992, 1996, 2004, 2008, 2012, etc. For BC years, we recall
+! that year 0 was omitted, so 1 BC, 5 BC, 9 BC, 13 BC, etc., and 401 BC,
+! 801 BC, 1201 BC, etc., are leap years under both calendars, while
+! 101 BC, 201 BC, 301 BC, 501 BC, 601 BC, 701 BC, 901 BC, 1001 BC,
+! 1101 BC, etc., are leap years under the Julian calendar but not
+! the Gregorian calendar.
+!
+! The Gregorian calendar is named after Pope Gregory XIII. He declared
+! that the last day of the old Julian calendar would be Thursday,
+! 4 October 1582 and that the following day, Friday, would be reckoned
+! under the new calendar as 15 October 1582. The jump of 10 days was
+! included to make 21 March closer to the spring equinox.
+!
+! Only a few Catholic countries (Italy, Poland, Portugal, and Spain)
+! switched to the Gregorian calendar on the day after 4 October 1582.
+! It took other countries months to centuries to change to the
+! Gregorian calendar. For example, England's first day under the
+! Gregorian calendar was 14 September 1752. The same date applied to
+! the entire British empire, including America. Japan, Russia, and many
+! eastern European countries did not change to the Gregorian calendar
+! until the 20th century. The last country to change was Turkey,
+! which began using the Gregorian calendar on 1 January 1927.
+!
+! Therefore, between the years 1582 and 1926 AD, you must know
+! the country in which an event was dated to interpret the date
+! correctly. In Sweden, there was even a year (1712) when February
+! had 30 days. Consult a book on calendars for more details
+! about when various countries changed their calendars.
+!
+! DAY NUMBER DURING THE YEAR
+! The day number during the year is simply a counter equal to 1 on
+! 1 January, 32 on 1 February, etc., thorugh 365 or 366 on 31 December,
+! depending on whether the year is a leap year. Sometimes this is
+! called the Julian Day, but that term is better reserved for the
+! day counter explained below.
+!
+! JULIAN DAY NUMBER
+! The Julian Day numbering system was designed by Joseph Scaliger
+! in 1582 to remove ambiguity caused by varying calendar systems.
+! The name "Julian Day" was chosen to honor Scaliger's father,
+! Julius Caesar Scaliger (1484-1558), an Italian scholar and physician
+! who lived in France. Because Julian Day numbering was especially
+! designed for astronomers, Julian Days begin at noon so that the day
+! counter does not change in the middle of an astronmer's observing
+! period. Julian Day 0 began at noon on 1 January 4713 BC under the
+! Julian calendar. A modern reference point is that 23 May 1968
+! (Gregorian calendar) was Julian Day 2,440,000.
+!
+! JULIAN DAY NUMBER EXAMPLES
+!
+! The table below shows a few Julian Day numbers and their corresponding
+! dates, depending on which calendar is used. A negative 'iyear' refers
+! to BC (Before Christ).
+!
+! Julian Day under calendar:
+! iday month iyear Gregorian Julian
+! 24 11 -4714 0 -38
+! 1 1 -4713 38 0
+! 1 1 1 1721426 1721424
+! 4 10 1582 2299150 2299160
+! 15 10 1582 2299161 2299171
+! 1 3 1600 2305508 2305518
+! 23 5 1968 2440000 2440013
+! 5 7 1998 2451000 2451013
+! 1 3 2000 2451605 2451618
+! 1 1 2001 2451911 2451924
+!
+! From this table, we can see that the 10 day difference between the
+! two calendars in 1582 grew to 13 days by 1 March 1900, since 1900 was
+! a leap year under the Julian calendar but not under the Gregorian
+! calendar. The gap will widen to 14 days after 1 March 2100 for the
+! same reason.
+!
+!----------
+!
+! PORTABILITY
+!
+! This subroutine is written in standard FORTRAN 90.
+! It calls no external functions or subroutines and should run
+! without problem on any computer having a 32-bit word or longer.
+!
+!----------
+!
+! ALGORITHM
+!
+! The goal in coding calndr() was clear, clean code, not efficiency.
+! Calendar calculations usually take a trivial fraction of the time
+! in any program in which dates conversions are involved.
+! Data analysis usually takes the most time.
+!
+! Standard algorithms are followed in this subroutine. Internal to
+! this subroutine, we use a year counter "jyear" such that
+! jyear=iyear when iyear is positive
+! =iyear+1 when iyear is negative.
+! Thus, jyear does not experience a 1 year jump like iyear does
+! when going from BC to AD. Specifically, jyear=0 when iyear=-1,
+! i.e., when the year is 1 BC.
+!
+! For simplicity in dealing with February, inside this subroutine,
+! we let the year begin on 1 March so that the adjustable month,
+! February is the last month of the year.
+! It is clear that the calendar used to work this way because the
+! months September, October, November, and December refer to
+! 7, 8, 9, and 10. For consistency, jyear is incremented on 1 March
+! rather than on 1 January. Of course, everything is adjusted back to
+! standard practice of years beginning on 1 January before answers
+! are returned to the routine that calls calndr().
+!
+! Lastly, we use a trick to calculate the number of days from 1 March
+! until the end of the month that precedes the specified month.
+! That number of days is int(30.6001*(month+1))-122,
+! where 30.6001 is used to avoid the possibility of round-off and
+! truncation error. For example, if 30.6 were used instead,
+! 30.6*5 should be 153, but round-off error could make it 152.99999,
+! which would then truncated to 152, causing an error of 1 day.
+!
+! Algorithm reference:
+! Dershowitz, Nachum and Edward M. Reingold, 1990: Calendrical
+! Calculations. Software-Practice and Experience, vol. 20, number 9
+! (September 1990), pp. 899-928.
+!
+! Copyright (C) 1999 Jon Ahlquist.
+! Issued under the second GNU General Public License.
+! See www.gnu.org for details.
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+! If you find any errors, please notify:
+! Jon Ahlquist <ahlquist at met.fsu.edu>
+! Dept of Meteorology
+! Florida State University
+! Tallahassee, FL 32306-4520
+! 15 March 1999.
+!
+!-----
+
+! converted to Fortran90 by Dimitri Komatitsch,
+! University of Pau, France, January 2008.
+
+! Declare internal variables.
+ integer jdref, jmonth, jyear, leap, n1yr, n4yr, n100yr, n400yr, ndays, ndy400, ndy100, nyrs, yr400, yrref
+!
+! Explanation of all internal variables.
+! jdref Julian Day on which 1 March begins in the reference year.
+! jmonth Month counter which equals month+1 if month .gt. 2
+! or month+13 if month .le. 2.
+! jyear Year index, jyear=iyear if iyear .gt. 0, jyear=iyear+1
+! if iyear .lt. 0. Thus, jyear does not skip year 0
+! like iyear does between BC and AD years.
+! leap =1 if the year is a leap year, =0 if not.
+! n1yr Number of complete individual years between iyear and
+! the reference year after all 4, 100,
+! and 400 year periods have been removed.
+! n4yr Number of complete 4 year cycles between iyear and
+! the reference year after all 100 and 400 year periods
+! have been removed.
+! n100yr Number of complete 100 year periods between iyear and
+! the reference year after all 400 year periods
+! have been removed.
+! n400yr Number of complete 400 year periods between iyear and
+! the reference year.
+! ndays Number of days since 1 March during iyear. (In intermediate
+! steps, it holds other day counts as well.)
+! ndy400 Number of days in 400 years. Under the Gregorian calendar,
+! this is 400*365 + 100 - 3 = 146097. Under the Julian
+! calendar, this is 400*365 + 100 = 146100.
+! ndy100 Number of days in 100 years, Under the Gregorian calendar,
+! this is 100*365 + 24 = 36524. Under the Julian calendar,
+! this is 100*365 + 25 = 36525.
+! nyrs Number of years from the beginning of yr400
+! to the beginning of jyear. (Used for option +/-3).
+! yr400 The largest multiple of 400 years that is .le. jyear.
+!
+!
+!----------------------------------------------------------------
+! Do preparation work.
+!
+! Look for out-of-range option values.
+ if ((ioptn == 0) .or. (abs(ioptn) >= 6)) then
+ write(*,*)'For calndr(), you specified ioptn = ', ioptn
+ write(*,*) 'Allowable values are 1 to 5 for the Gregorian calendar'
+ write(*,*) 'and -1 to -5 for the Julian calendar.'
+ stop
+ endif
+!
+! Options 1-3 have "iyear" as an input value.
+! Internally, we use variable "jyear" that does not have a jump
+! from -1 (for 1 BC) to +1 (for 1 AD).
+ if (abs(ioptn) <= 3) then
+ if (iyear > 0) then
+ jyear = iyear
+ elseif (iyear == 0) then
+ write(*,*) 'For calndr(), you specified the nonexistent year 0'
+ stop
+ else
+ jyear = iyear + 1
+ endif
+!
+! Set "leap" equal to 0 if "jyear" is not a leap year
+! and equal to 1 if it is a leap year.
+ leap = 0
+ if ((jyear/4)*4 == jyear) then
+ leap = 1
+ endif
+ if ((ioptn > 0) .and. &
+ ((jyear/100)*100 == jyear) .and. &
+ ((jyear/400)*400 /= jyear) ) then
+ leap = 0
+ endif
+ endif
+!
+! Options 3-5 involve Julian Day numbers, which need a reference year
+! and the Julian Days that began at noon on 1 March of the reference
+! year under the Gregorian and Julian calendars. Any year for which
+! "jyear" is divisible by 400 can be used as a reference year.
+! We chose 1600 AD as the reference year because it is the closest
+! multiple of 400 to the institution of the Gregorian calendar, making
+! it relatively easy to compute the Julian Day for 1 March 1600
+! given that, on 15 October 1582 under the Gregorian calendar,
+! the Julian Day was 2299161. Similarly, we need to do the same
+! calculation for the Julian calendar. We can compute this Julian
+! Day knwoing that on 4 October 1582 under the Julian calendar,
+! the Julian Day number was 2299160. The details of these calculations
+! is next.
+! From 15 October until 1 March, the number of days is the remainder
+! of October plus the days in November, December, January, and February:
+! 17+30+31+31+28 = 137, so 1 March 1583 under the Gregorian calendar
+! was Julian Day 2,299,298. Because of the 10 day jump ahead at the
+! switch from the Julian calendar to the Gregorian calendar, 1 March
+! 1583 under the Julian calendar was Julian Day 2,299,308. Making use
+! of the rules for the two calendar systems, 1 March 1600 was Julian
+! Day 2,299,298 + (1600-1583)*365 + 5 (due to leap years) =
+! 2,305,508 under the Gregorian calendar and day 2,305,518 under the
+! Julian calendar.
+! We also set the number of days in 400 years and 100 years.
+! For reference, 400 years is 146097 days under the Gregorian calendar
+! and 146100 days under the Julian calendar. 100 years is 36524 days
+! under the Gregorian calendar and 36525 days under the Julian calendar.
+ if (abs(ioptn) >= 3) then
+!
+! Julian calendar values.
+ yrref = 1600
+ jdref = 2305518
+! = Julian Day reference value for the day that begins
+! at noon on 1 March of the reference year "yrref".
+ ndy400 = 400*365 + 100
+ ndy100 = 100*365 + 25
+!
+! Adjust for Gregorian calendar values.
+ if (ioptn > 0) then
+ jdref = jdref - 10
+ ndy400 = ndy400 - 3
+ ndy100 = ndy100 - 1
+ endif
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -1 and +1:
+! Given a calendar date (iday,month,iyear), compute the day number
+! of the year (idayct), where 1 January is day number 1 and 31 December
+! is day number 365 or 366, depending on whether it is a leap year.
+ if (abs(ioptn) == 1) then
+!
+! Compute the day number during the year.
+ if (month <= 2) then
+ idayct = iday + (month-1)*31
+ else
+ idayct = iday + int(30.6001 * (month+1)) - 63 + leap
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -2 and +2:
+! Given the day number of the year (idayct) and the year (iyear),
+! compute the day of the month (iday) and the month (month).
+ elseif (abs(ioptn) == 2) then
+!
+ if (idayct < 60+leap) then
+ month = (idayct-1)/31
+ iday = idayct - month*31
+ month = month + 1
+ else
+ ndays = idayct - (60+leap)
+! = number of days past 1 March of the current year.
+ jmonth = (10*(ndays+31))/306 + 3
+! = month counter, =4 for March, =5 for April, etc.
+ iday = (ndays+123) - int(30.6001*jmonth)
+ month = jmonth - 1
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -3 and +3:
+! Given a calendar date (iday,month,iyear), compute the Julian Day
+! number (idayct) that starts at noon.
+ elseif (abs(ioptn) == 3) then
+!
+! Shift to a system where the year starts on 1 March, so January
+! and February belong to the preceding year.
+! Define jmonth=4 for March, =5 for April, ..., =15 for February.
+ if (month <= 2) then
+ jyear = jyear - 1
+ jmonth = month + 13
+ else
+ jmonth = month + 1
+ endif
+!
+! Find the closest multiple of 400 years that is .le. jyear.
+ yr400 = (jyear/400)*400
+! = multiple of 400 years at or less than jyear.
+ if (jyear < yr400) then
+ yr400 = yr400 - 400
+ endif
+!
+ n400yr = (yr400 - yrref)/400
+! = number of 400-year periods from yrref to yr400.
+ nyrs = jyear - yr400
+! = number of years from the beginning of yr400
+! to the beginning of jyear.
+!
+! Compute the Julian Day number.
+ idayct = iday + int(30.6001*jmonth) - 123 + 365*nyrs + nyrs/4 &
+ + jdref + n400yr*ndy400
+!
+! If we are using the Gregorian calendar, we must not count
+! every 100-th year as a leap year. nyrs is less than 400 years,
+! so we do not need to consider the leap year that would occur if
+! nyrs were divisible by 400, i.e., we do not add nyrs/400.
+ if (ioptn > 0) then
+ idayct = idayct - nyrs/100
+ endif
+!
+!----------------------------------------------------------------
+! OPTIONS -5, -4, +4, and +5:
+! Given the Julian Day number (idayct) that starts at noon,
+! compute the corresponding calendar date (iday,month,iyear)
+! (abs(ioptn)=4) or day number during the year (abs(ioptn)=5).
+ else
+!
+! Create a new reference date which begins on the nearest
+! 400-year cycle less than or equal to the Julian Day for 1 March
+! in the year in which the given Julian Day number (idayct) occurs.
+ ndays = idayct - jdref
+ n400yr = ndays / ndy400
+! = integral number of 400-year periods separating
+! idayct and the reference date, jdref.
+ jdref = jdref + n400yr*ndy400
+ if (jdref > idayct) then
+ n400yr = n400yr - 1
+ jdref = jdref - ndy400
+ endif
+!
+ ndays = idayct - jdref
+! = number from the reference date to idayct.
+!
+ n100yr = min(ndays/ndy100, 3)
+! = number of complete 100-year periods
+! from the reference year to the current year.
+! The min() function is necessary to avoid n100yr=4
+! on 29 February of the last year in the 400-year cycle.
+!
+ ndays = ndays - n100yr*ndy100
+! = remainder after removing an integral number of
+! 100-year periods.
+!
+ n4yr = ndays / 1461
+! = number of complete 4-year periods in the current century.
+! 4 years consists of 4*365 + 1 = 1461 days.
+!
+ ndays = ndays - n4yr*1461
+! = remainder after removing an integral number
+! of 4-year periods.
+!
+ n1yr = min(ndays/365, 3)
+! = number of complete years since the last leap year.
+! The min() function is necessary to avoid n1yr=4
+! when the date is 29 February on a leap year,
+! in which case ndays=1460, and 1460/365 = 4.
+!
+ ndays = ndays - 365*n1yr
+! = number of days so far in the current year,
+! where ndays=0 on 1 March.
+!
+ iyear = n1yr + 4*n4yr + 100*n100yr + 400*n400yr + yrref
+! = year, as counted in the standard way,
+! but relative to 1 March.
+!
+! At this point, we need to separate ioptn=abs(4), which seeks a
+! calendar date, and ioptn=abs(5), which seeks the day number during
+! the year. First compute the calendar date if desired (abs(ioptn)=4).
+ if (abs(ioptn) == 4) then
+ jmonth = (10*(ndays+31))/306 + 3
+! = offset month counter. jmonth=4 for March, =13 for
+! December, =14 for January, =15 for February.
+ iday = (ndays+123) - int(30.6001*jmonth)
+! = day of the month, starting with 1 on the first day
+! of the month.
+!
+! Now adjust for the fact that the year actually begins
+! on 1 January.
+ if (jmonth <= 13) then
+ month = jmonth - 1
+ else
+ month = jmonth - 13
+ iyear = iyear + 1
+ endif
+!
+! This code handles abs(ioptn)=5, finding the day number during the year.
+ else
+! ioptn=5 always returns month=1, which we set now.
+ month = 1
+!
+! We need to determine whether this is a leap year.
+ leap = 0
+ if ((jyear/4)*4 == jyear) then
+ leap = 1
+ endif
+ if ((ioptn > 0) .and. &
+ ((jyear/100)*100 == jyear) .and. &
+ ((jyear/400)*400 /= jyear) ) then
+ leap = 0
+ endif
+!
+! Now find the day number "iday".
+! ndays is the number of days since the most recent 1 March,
+! so ndays=0 on 1 March.
+ if (ndays <=305) then
+ iday = ndays + 60 + leap
+ else
+ iday = ndays - 305
+ iyear = iyear + 1
+ endif
+ endif
+!
+! Adjust the year if it is .le. 0, and hence BC (Before Christ).
+ if (iyear <= 0) then
+ iyear = iyear - 1
+ endif
+!
+! End the code for the last option, ioptn.
+ endif
+
+ end subroutine calndr
+
Copied: seismo/2D/SPECFEM2D/trunk/src/check_quality_external_mesh.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/check_quality_external_mesh.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/check_quality_external_mesh.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/check_quality_external_mesh.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,689 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! read an external 2D mesh file and display statistics about mesh quality;
+! and create an OpenDX file showing a given range of elements or a single element
+
+! Dimitri Komatitsch, University of Toulouse, France, January 2011.
+! (adapted from the version that is available in our 3D code, SPECFEM3D)
+
+!! DK DK
+!! DK DK this routine could be improved by computing the mean in addition to min and max of ratios
+!! DK DK
+
+ program check_quality_external_mesh
+
+ implicit none
+
+ include "constants.h"
+
+ integer, parameter :: NGNOD = 4 ! quadrangles
+
+ integer :: NPOIN ! number of nodes
+ integer :: NSPEC ! number of elements
+
+ double precision, dimension(:), allocatable :: x,y,z
+
+ integer, dimension(:,:), allocatable :: ibool
+
+ integer :: i,ispec,iformat,ispec_min_edge_length,ispec_max_edge_length, &
+ ispec_begin,ispec_end,ispec_to_output,ispec_equiangle_skewness_max
+
+! for quality of mesh
+ double precision :: equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio
+ double precision :: equiangle_skewness_min,edge_aspect_ratio_min,diagonal_aspect_ratio_min
+ double precision :: equiangle_skewness_max,edge_aspect_ratio_max,diagonal_aspect_ratio_max
+ double precision :: skewness_AVS_DX_min,skewness_AVS_DX_max,distance_min,distance_max
+ double precision :: distmin,distmax
+
+! for histogram
+ integer, parameter :: NCLASS = 20
+ integer classes_skewness(0:NCLASS-1)
+ integer :: iclass
+ double precision :: current_percent,total_percent
+
+! to export elements that have a certain skewness range to OpenDX
+ integer :: ntotspecAVS_DX
+ logical :: USE_OPENDX
+
+ character(len=100) interfacesfile,title
+
+ ! flag to save the last frame for kernels calculation purpose and type of simulation
+ logical :: SAVE_FORWARD
+ integer :: SIMULATION_TYPE
+
+ ! parameters for external mesh
+ logical :: read_external_mesh
+ character(len=256) :: mesh_file, nodes_coords_file
+
+ ! ignore variable name field (junk) at the beginning of each input line
+ !logical, parameter :: IGNORE_JUNK = .true.
+
+ integer :: NPOIN_unique_needed
+ integer, dimension(:), allocatable :: ibool_reduced
+ logical, dimension(:), allocatable :: mask_ibool
+
+ if(NGNOD /= 4) stop 'NGNOD must be 4'
+
+ ! ***
+ ! *** read the parameter file
+ ! ***
+
+ print *,'Reading the parameter file ... '
+ print *
+
+ open(unit=IIN,file='DATA/Par_file',status='old')
+
+ ! read and ignore file names and path for output
+ call read_value_string(IIN,IGNORE_JUNK,title)
+ call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
+
+ ! read and ignore type of simulation
+ call read_value_integer(IIN,IGNORE_JUNK,SIMULATION_TYPE)
+ call read_value_logical(IIN,IGNORE_JUNK,SAVE_FORWARD)
+
+ ! read info about external mesh
+ call read_value_logical(IIN,IGNORE_JUNK,read_external_mesh)
+ if(.not. read_external_mesh) stop 'this program is designed for read_external_mesh = .true.'
+ call read_value_string(IIN,IGNORE_JUNK,mesh_file)
+ call read_value_string(IIN,IGNORE_JUNK,nodes_coords_file)
+
+ print *
+ print *,'1 = output elements above a certain skewness threshold in OpenDX format'
+ print *,'2 = output a given element in OpenDX format'
+ print *,'3 = do not output any OpenDX file'
+ print *
+ print *,'enter value:'
+ read(5,*) iformat
+
+ if(iformat < 1 .or. iformat > 3) stop 'exiting...'
+
+ if(iformat == 1 .or. iformat == 2) then
+ USE_OPENDX = .true.
+ else
+ USE_OPENDX = .false.
+ endif
+
+! read the nodes
+ print *
+ print *,'start reading the external node file: ',nodes_coords_file(1:len_trim(nodes_coords_file))
+ open(unit=10,file=nodes_coords_file,status='unknown',action='read')
+
+! read the header
+ read(10,*) NPOIN
+
+! read the mesh
+ print *,'start reading the external mesh file: ',mesh_file(1:len_trim(mesh_file))
+ open(unit=11,file=mesh_file,status='unknown',action='read')
+
+! read the header
+ read(11,*) NSPEC
+
+ allocate(x(NPOIN))
+ allocate(y(NPOIN))
+ allocate(z(NPOIN))
+
+ allocate(ibool(NGNOD,NSPEC))
+
+ if(USE_OPENDX) then
+
+ if(iformat == 1) then
+
+! read range of skewness used for elements
+ print *
+ print *,'enter minimum skewness for OpenDX (between 0. and 0.99):'
+ read(5,*) skewness_AVS_DX_min
+ if(skewness_AVS_DX_min < 0.d0) skewness_AVS_DX_min = 0.d0
+ if(skewness_AVS_DX_min > 0.99999d0) skewness_AVS_DX_min = 0.99999d0
+
+!!!!!!!! print *,'enter maximum skewness for OpenDX (between 0. and 1.):'
+!!!!!!!!!!!!! read(5,*) skewness_AVS_DX_max
+ skewness_AVS_DX_max = 0.99999d0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if(skewness_AVS_DX_max < 0.d0) skewness_AVS_DX_max = 0.d0
+ if(skewness_AVS_DX_max > 0.99999d0) skewness_AVS_DX_max = 0.99999d0
+
+ if(skewness_AVS_DX_min > skewness_AVS_DX_max) stop 'incorrect skewness range'
+
+ else
+ print *,'enter the element number to output in OpenDX format between 1 and ',NSPEC
+ read(5,*) ispec_to_output
+ if(ispec_to_output < 1 .or. ispec_to_output > NSPEC) stop 'incorrect element number to output'
+ endif
+
+ endif
+
+! read the points
+ print *,'NPOIN = ',NPOIN
+ do i = 1,NPOIN
+ read(10,*) x(i),y(i)
+! the 2D mesh is flat, therefore the third coordinate is zero
+ z(i) = 0
+ enddo
+ close(10)
+
+! read the elements
+ print *,'NSPEC = ',NSPEC
+ do i = 1,NSPEC
+ read(11,*) ibool(1,i),ibool(2,i),ibool(3,i),ibool(4,i)
+ enddo
+ close(11)
+
+ print *,'done reading the external files'
+ print *
+
+ print *,'start computing the minimum and maximum edge size'
+
+! ************* compute min and max of skewness and ratios ******************
+
+! erase minimum and maximum of quality numbers
+ equiangle_skewness_min = + HUGEVAL
+ edge_aspect_ratio_min = + HUGEVAL
+ diagonal_aspect_ratio_min = + HUGEVAL
+ distance_min = + HUGEVAL
+
+ equiangle_skewness_max = - HUGEVAL
+ edge_aspect_ratio_max = - HUGEVAL
+ diagonal_aspect_ratio_max = - HUGEVAL
+ distance_max = - HUGEVAL
+
+ ispec_min_edge_length = -1
+ ispec_max_edge_length = -1
+
+! loop on all the elements
+ do ispec = 1,NSPEC
+
+ if(mod(ispec,100000) == 0) print *,'processed ',ispec,' elements out of ',NSPEC
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! store element number in which the edge of minimum or maximum length is located
+ if(distmin < distance_min) ispec_min_edge_length = ispec
+ if(distmax > distance_max) ispec_max_edge_length = ispec
+
+! compute minimum and maximum of quality numbers
+ equiangle_skewness_min = min(equiangle_skewness_min,equiangle_skewness)
+ edge_aspect_ratio_min = min(edge_aspect_ratio_min,edge_aspect_ratio)
+ diagonal_aspect_ratio_min = min(diagonal_aspect_ratio_min,diagonal_aspect_ratio)
+ distance_min = min(distance_min,distmin)
+
+ if(equiangle_skewness > equiangle_skewness_max) ispec_equiangle_skewness_max = ispec
+ equiangle_skewness_max = max(equiangle_skewness_max,equiangle_skewness)
+ edge_aspect_ratio_max = max(edge_aspect_ratio_max,edge_aspect_ratio)
+ diagonal_aspect_ratio_max = max(diagonal_aspect_ratio_max,diagonal_aspect_ratio)
+ distance_max = max(distance_max,distmax)
+
+ enddo
+ print *,'done processing ',NSPEC,' elements out of ',NSPEC
+
+ print *
+ print *,'------------'
+ print *,'mesh quality parameter definitions:'
+ print *
+ print *,'equiangle skewness: 0. perfect, 1. bad'
+ print *,'skewness max deviation angle: 0. perfect, 90. bad'
+ print *,'edge aspect ratio: 1. perfect, above 1. gives stretching factor'
+ print *,'diagonal aspect ratio: 1. perfect, above 1. gives stretching factor'
+ print *,'------------'
+
+ print *
+ print *,'minimum length of an edge in the whole mesh (m) = ',distance_min,' in element ',ispec_min_edge_length
+ print *
+ print *,'maximum length of an edge in the whole mesh (m) = ',distance_max,' in element ',ispec_max_edge_length
+ print *
+ print *,'max equiangle skewness = ',equiangle_skewness_max
+ print *,'in element ',ispec_equiangle_skewness_max
+! print *,'min equiangle skewness = ',equiangle_skewness_min
+ print *
+ print *,'max deviation angle from a right angle (90 degrees) is therefore = ',90.*equiangle_skewness_max
+ print *
+ print *,'worst angle in the mesh is therefore either ',90.*(1. - equiangle_skewness_max)
+ print *,'or ',180. - 90.*(1. - equiangle_skewness_max),' degrees'
+ print *
+ print *,'max edge aspect ratio = ',edge_aspect_ratio_max
+! print *,'min edge aspect ratio = ',edge_aspect_ratio_min
+ print *
+ print *,'max diagonal aspect ratio = ',diagonal_aspect_ratio_max
+! print *,'min diagonal aspect ratio = ',diagonal_aspect_ratio_min
+ print *
+
+! create statistics about mesh quality
+ print *,'creating histogram and statistics of mesh quality'
+
+! erase histogram of skewness
+ classes_skewness(:) = 0
+
+! loop on all the elements
+ do ispec = 1,NSPEC
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! store skewness in histogram
+ iclass = int(equiangle_skewness * dble(NCLASS))
+ if(iclass < 0) iclass = 0
+ if(iclass > NCLASS-1) iclass = NCLASS-1
+ classes_skewness(iclass) = classes_skewness(iclass) + 1
+
+ enddo
+
+! create histogram of skewness and save in Gnuplot file
+ print *
+ print *,'histogram of skewness (0. good - 1. bad):'
+ print *
+ total_percent = 0.
+ open(unit=14,file='mesh_quality_histogram.txt',status='unknown')
+ do iclass = 0,NCLASS-1
+ current_percent = 100.*dble(classes_skewness(iclass))/dble(NSPEC)
+ total_percent = total_percent + current_percent
+ print *,real(iclass/dble(NCLASS)),' - ',real((iclass+1)/dble(NCLASS)),classes_skewness(iclass),' ',sngl(current_percent),' %'
+ write(14,*) 0.5*(real(iclass/dble(NCLASS)) + real((iclass+1)/dble(NCLASS))),' ',sngl(current_percent)
+ enddo
+ close(14)
+
+! create script for Gnuplot histogram file
+ open(unit=14,file='plot_mesh_quality_histogram.gnu',status='unknown')
+ write(14,*) 'set term x11'
+ write(14,*) '#set term gif'
+ write(14,*) '#set output "mesh_quality_histogram.gif"'
+ write(14,*)
+ write(14,*) 'set xrange [0:1]'
+ write(14,*) 'set xtics 0,0.1,1'
+ write(14,*) 'set boxwidth ',1./real(NCLASS)
+ write(14,*) 'set xlabel "Skewness range"'
+ write(14,*) 'set ylabel "Percentage of elements (%)"'
+ write(14,*) 'plot "mesh_quality_histogram.txt" with boxes'
+ write(14,*) 'pause -1 "hit any key..."'
+ close(14)
+
+ print *
+ print *,'total number of elements = ',NSPEC
+ print *
+
+! display warning if maximum skewness is too high
+ if(equiangle_skewness_max >= 0.75d0) then
+ print *
+ print *,'*********************************************'
+ print *,'*********************************************'
+ print *,' WARNING, mesh is bad (max skewness >= 0.75)'
+ print *,'*********************************************'
+ print *,'*********************************************'
+ print *
+ endif
+
+ if(total_percent < 99.9d0 .or. total_percent > 100.1d0) then
+ print *,'total percentage = ',total_percent,' %'
+ stop 'total percentage should be 100%'
+ endif
+
+! ************* create OpenDX file with elements in a certain range of skewness
+
+ if(USE_OPENDX) then
+
+ print *
+ if(iformat == 1) then
+ print *,'creating OpenDX file with subset of elements in skewness range'
+ print *,'between ',skewness_AVS_DX_min,' and ',skewness_AVS_DX_max
+ else
+ print *,'creating OpenDX file with element #',ispec_to_output
+ endif
+ print *
+
+! ************* count number of elements in skewness range *************
+
+! erase number of elements belonging to skewness range for AVS_DX
+ ntotspecAVS_DX = 0
+
+! loop on all the elements
+ if(iformat == 1) then
+
+ do ispec = 1,NSPEC
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! check if element belongs to requested skewness range
+ if(equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max) &
+ ntotspecAVS_DX = ntotspecAVS_DX + 1
+
+ enddo
+
+ else
+! outputing a single element
+ ntotspecAVS_DX = 1
+ endif
+
+ if(ntotspecAVS_DX == 0) then
+ stop 'no elements in skewness range, no file created'
+ else if(iformat == 1) then
+ print *
+ print *,'there are ',ntotspecAVS_DX,' elements in AVS or DX skewness range ',skewness_AVS_DX_min,skewness_AVS_DX_max
+ print *
+ endif
+
+ open(unit=11,file='DX_mesh_quality.dx',status='unknown')
+
+! generate the subset of points that are needed
+
+! count the number of unique points
+ NPOIN_unique_needed = 0
+ allocate(mask_ibool(NPOIN))
+ mask_ibool(:) = .false.
+
+! loop on all the elements
+ if(iformat == 1) then
+ ispec_begin = 1
+ ispec_end = NSPEC
+ else
+ ispec_begin = ispec_to_output
+ ispec_end = ispec_to_output
+ endif
+
+ do ispec = ispec_begin,ispec_end
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! check if element needs to be output
+ if(iformat == 2 .or. (iformat == 1 .and. &
+ equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
+! create point for first corner of the element
+ if(.not. mask_ibool(ibool(1,ispec))) then
+ mask_ibool(ibool(1,ispec)) = .true.
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for second corner of the element
+ if(.not. mask_ibool(ibool(2,ispec))) then
+ mask_ibool(ibool(2,ispec)) = .true.
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for third corner of the element
+ if(.not. mask_ibool(ibool(3,ispec))) then
+ mask_ibool(ibool(3,ispec)) = .true.
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for fourth corner of the element
+ if(.not. mask_ibool(ibool(4,ispec))) then
+ mask_ibool(ibool(4,ispec)) = .true.
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+ endif
+
+ enddo
+
+
+! ************* generate points ******************
+
+! write OpenDX header
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',NPOIN_unique_needed,' data follows'
+
+ allocate(ibool_reduced(NPOIN))
+
+! count the number of unique points
+ NPOIN_unique_needed = 0
+ mask_ibool(:) = .false.
+
+! loop on all the elements
+ if(iformat == 1) then
+ ispec_begin = 1
+ ispec_end = NSPEC
+ else
+ ispec_begin = ispec_to_output
+ ispec_end = ispec_to_output
+ endif
+
+ do ispec = ispec_begin,ispec_end
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! check if element needs to be output
+ if(iformat == 2 .or. (iformat == 1 .and. &
+ equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
+! create point for first corner of the element
+ if(.not. mask_ibool(ibool(1,ispec))) then
+ mask_ibool(ibool(1,ispec)) = .true.
+ ibool_reduced(ibool(1,ispec)) = NPOIN_unique_needed
+ write(11,*) sngl(x(ibool(1,ispec))),sngl(y(ibool(1,ispec))),sngl(z(ibool(1,ispec)))
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for second corner of the element
+ if(.not. mask_ibool(ibool(2,ispec))) then
+ mask_ibool(ibool(2,ispec)) = .true.
+ ibool_reduced(ibool(2,ispec)) = NPOIN_unique_needed
+ write(11,*) sngl(x(ibool(2,ispec))),sngl(y(ibool(2,ispec))),sngl(z(ibool(2,ispec)))
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for third corner of the element
+ if(.not. mask_ibool(ibool(3,ispec))) then
+ mask_ibool(ibool(3,ispec)) = .true.
+ ibool_reduced(ibool(3,ispec)) = NPOIN_unique_needed
+ write(11,*) sngl(x(ibool(3,ispec))),sngl(y(ibool(3,ispec))),sngl(z(ibool(3,ispec)))
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+! create point for fourth corner of the element
+ if(.not. mask_ibool(ibool(4,ispec))) then
+ mask_ibool(ibool(4,ispec)) = .true.
+ ibool_reduced(ibool(4,ispec)) = NPOIN_unique_needed
+ write(11,*) sngl(x(ibool(4,ispec))),sngl(y(ibool(4,ispec))),sngl(z(ibool(4,ispec)))
+ NPOIN_unique_needed = NPOIN_unique_needed + 1
+ endif
+
+ endif
+
+ enddo
+
+ deallocate(mask_ibool)
+
+! ************* generate elements ******************
+
+ write(11,*) 'object 2 class array type int rank 1 shape ',NGNOD,' items ',ntotspecAVS_DX,' data follows'
+
+! loop on all the elements
+ if(iformat == 1) then
+ ispec_begin = 1
+ ispec_end = NSPEC
+ else
+ ispec_begin = ispec_to_output
+ ispec_end = ispec_to_output
+ endif
+
+ do ispec = ispec_begin,ispec_end
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! check if element needs to be output
+ if(iformat == 2 .or. (iformat == 1 .and. &
+ equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) then
+! point order in OpenDX in 2D is 1,4,2,3 *not* 1,2,3,4 as in AVS
+! point order in OpenDX in 3D is 4,1,8,5,3,2,7,6, *not* 1,2,3,4,5,6,7,8 as in AVS
+! in the case of OpenDX, node numbers start at zero
+ write(11,"(i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9,1x,i9)") &
+ ibool_reduced(ibool(1,ispec)), ibool_reduced(ibool(4,ispec)), &
+ ibool_reduced(ibool(2,ispec)), ibool_reduced(ibool(3,ispec))
+ if(iformat == 1) print *,'element ',ispec,' belongs to the range and has skewness = ',sngl(equiangle_skewness)
+ endif
+
+ enddo
+
+! ************* generate element data values ******************
+
+! output OpenDX header for data
+ write(11,*) 'attribute "element type" string "quads"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
+
+! loop on all the elements
+ do ispec = ispec_begin,ispec_end
+
+ call create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+! check if element needs to be output
+ if(iformat == 2 .or. (iformat == 1 .and. &
+ equiangle_skewness >= skewness_AVS_DX_min .and. equiangle_skewness <= skewness_AVS_DX_max)) &
+ write(11,*) sngl(equiangle_skewness)
+
+ enddo
+
+! define OpenDX field
+ write(11,*) 'attribute "dep" string "connections"'
+ write(11,*) 'object "irregular positions irregular connections" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+
+! close OpenDX file
+ close(11)
+
+ endif
+
+ end program check_quality_external_mesh
+
+!
+!=====================================================================
+!
+
+! create mesh quality data for a given 2D spectral element
+
+ subroutine create_mesh_quality_data_2D(x,y,z,ibool,ispec,NSPEC,NPOIN,NGNOD, &
+ equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio,distmin,distmax)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: icorner,ispec,NSPEC,NPOIN,NGNOD,i
+
+ double precision, dimension(NPOIN) :: x,y,z
+
+ integer, dimension(NGNOD,NSPEC) :: ibool
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm
+
+ double precision vectorA_x,vectorA_y,vectorA_z
+ double precision vectorB_x,vectorB_y,vectorB_z
+ double precision norm_A,norm_B,angle_vectors
+ double precision distmin,distmax,dist,dist1,dist2
+ double precision equiangle_skewness,edge_aspect_ratio,diagonal_aspect_ratio
+
+! topology of faces of cube for skewness
+! only one face in 2D
+ integer faces_topo(6)
+
+! store the corners of this element for the skewness routine
+ do i = 1,NGNOD
+ xelm(i) = x(ibool(i,ispec))
+ yelm(i) = y(ibool(i,ispec))
+ zelm(i) = z(ibool(i,ispec))
+ enddo
+
+! define topology of faces of cube for skewness
+
+! only one face in 2D
+ faces_topo(1) = 1
+ faces_topo(2) = 2
+ faces_topo(3) = 3
+ faces_topo(4) = 4
+
+! define wraparound for angles for skewness calculation
+ faces_topo(5) = faces_topo(1)
+ faces_topo(6) = faces_topo(2)
+
+! compute equiangle skewness (as defined in Fluent/Gambit manual)
+! and compute edge aspect ratio using the corners of the element
+ distmin = + HUGEVAL
+ distmax = - HUGEVAL
+ equiangle_skewness = - HUGEVAL
+
+ do icorner = 1,4
+
+! first vector of angle
+ vectorA_x = xelm(faces_topo(icorner)) - xelm(faces_topo(icorner+1))
+ vectorA_y = yelm(faces_topo(icorner)) - yelm(faces_topo(icorner+1))
+ vectorA_z = zelm(faces_topo(icorner)) - zelm(faces_topo(icorner+1))
+
+! second vector of angle
+ vectorB_x = xelm(faces_topo(icorner+2)) - xelm(faces_topo(icorner+1))
+ vectorB_y = yelm(faces_topo(icorner+2)) - yelm(faces_topo(icorner+1))
+ vectorB_z = zelm(faces_topo(icorner+2)) - zelm(faces_topo(icorner+1))
+
+! norm of vectors A and B
+ norm_A = sqrt(vectorA_x**2 + vectorA_y**2 + vectorA_z**2)
+ norm_B = sqrt(vectorB_x**2 + vectorB_y**2 + vectorB_z**2)
+
+! angle formed by the two vectors
+ angle_vectors = dacos((vectorA_x*vectorB_x + vectorA_y*vectorB_y + vectorA_z*vectorB_z) / (norm_A * norm_B))
+
+! compute equiangle skewness
+ equiangle_skewness = max(equiangle_skewness,dabs(2.d0 * angle_vectors - PI) / PI)
+
+! compute min and max size of an edge
+ dist = sqrt(vectorA_x**2 + vectorA_y**2 + vectorA_z**2)
+
+ distmin = min(distmin,dist)
+ distmax = max(distmax,dist)
+
+ enddo
+
+! compute edge aspect ratio
+ edge_aspect_ratio = distmax / distmin
+
+! compute diagonal aspect ratio
+ dist1 = sqrt((xelm(1) - xelm(3))**2 + (yelm(1) - yelm(3))**2 + (zelm(1) - zelm(3))**2)
+ dist2 = sqrt((xelm(2) - xelm(4))**2 + (yelm(2) - yelm(4))**2 + (zelm(2) - zelm(4))**2)
+ diagonal_aspect_ratio = max(dist1,dist2) / min(dist1,dist2)
+
+ end subroutine create_mesh_quality_data_2D
+
Copied: seismo/2D/SPECFEM2D/trunk/src/check_stability.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/check_stability.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/check_stability.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/check_stability.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,305 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine check_stability(myrank,time,it,NSTEP, &
+ npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ any_elastic_glob,any_elastic,displ_elastic, &
+ any_poroelastic_glob,any_poroelastic, &
+ displs_poroelastic,displw_poroelastic, &
+ any_acoustic_glob,any_acoustic,potential_acoustic, &
+ year_start,month_start,time_start)
+
+! checks simulation stability and outputs timerun infos
+
+ implicit none
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: myrank,it,NSTEP
+
+ double precision :: time
+
+ logical :: any_elastic_glob,any_elastic
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
+
+ logical :: any_poroelastic_glob,any_poroelastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
+
+ logical :: any_acoustic_glob,any_acoustic
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
+
+ double precision :: time_start
+ integer :: year_start,month_start
+
+ ! local parameters
+ double precision displnorm_all,displnorm_all_glob
+ ! timer to count elapsed time
+ double precision :: time_end
+ integer :: year_end,month_end
+ double precision :: tCPU,t_remain,t_total
+ integer :: ihours,iminutes,iseconds,int_tCPU, &
+ ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
+ ihours_total,iminutes_total,iseconds_total,int_t_total
+ ! to determine date and time at which the run will finish
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ character(len=3), dimension(12) :: month_name
+ character(len=3), dimension(0:6) :: weekday_name
+ data month_name /'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/
+ data weekday_name /'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'/
+ integer :: year,mon,day,hr,minutes,timestamp,julian_day_number,day_of_week
+ integer, external :: idaywk
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+ ! user output
+ if (myrank == 0) then
+ write(IOUT,*)
+ if(time >= 1.d-3 .and. time < 1000.d0) then
+ write(IOUT,"('Time step number ',i7,' t = ',f9.4,' s out of ',i7)") it,time,NSTEP
+ else
+ write(IOUT,"('Time step number ',i7,' t = ',1pe12.6,' s out of ',i7)") it,time,NSTEP
+ endif
+ write(IOUT,*) 'We have done ',sngl(100.d0*dble(it-1)/dble(NSTEP-1)),'% of the total'
+ endif
+
+
+ ! elastic wavefield
+ if(any_elastic_glob) then
+ if(any_elastic) then
+ displnorm_all = maxval(sqrt(displ_elastic(1,:)**2 &
+ + displ_elastic(2,:)**2 &
+ + displ_elastic(3,:)**2))
+ else
+ displnorm_all = 0.d0
+ endif
+
+ displnorm_all_glob = displnorm_all
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+#endif
+
+ if (myrank == 0) &
+ write(IOUT,*) 'Max norm of vector field in solid (elastic) = ',displnorm_all_glob
+
+ ! check stability of the code in solid, exit if unstable
+ ! negative values can occur with some compilers when the unstable value is greater
+ ! than the greatest possible floating-point number of the machine
+ if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
+ call exit_MPI('code became unstable and blew up in solid (elastic)')
+
+ endif
+
+ ! poroelastic wavefield
+ if(any_poroelastic_glob) then
+ if(any_poroelastic) then
+ displnorm_all = maxval(sqrt(displs_poroelastic(1,:)**2 &
+ + displs_poroelastic(2,:)**2))
+ else
+ displnorm_all = 0.d0
+ endif
+
+ displnorm_all_glob = displnorm_all
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+#endif
+
+ if (myrank == 0) &
+ write(IOUT,*) 'Max norm of vector field in solid (poroelastic) = ',displnorm_all_glob
+
+ ! check stability of the code in solid, exit if unstable
+ ! negative values can occur with some compilers when the unstable value is greater
+ ! than the greatest possible floating-point number of the machine
+ if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
+ call exit_MPI('code became unstable and blew up in solid (poroelastic)')
+
+ if(any_poroelastic) then
+ displnorm_all = maxval(sqrt(displw_poroelastic(1,:)**2 &
+ + displw_poroelastic(2,:)**2))
+ else
+ displnorm_all = 0.d0
+ endif
+
+ displnorm_all_glob = displnorm_all
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+#endif
+
+ if (myrank == 0) &
+ write(IOUT,*) 'Max norm of vector field in fluid (poroelastic) = ',displnorm_all_glob
+
+ ! check stability of the code in solid, exit if unstable
+ ! negative values can occur with some compilers when the unstable value is greater
+ ! than the greatest possible floating-point number of the machine
+ if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
+ call exit_MPI('code became unstable and blew up in fluid (poroelastic)')
+
+ endif
+
+
+ ! acoustic wavefield
+ if(any_acoustic_glob) then
+ if(any_acoustic) then
+ displnorm_all = maxval(abs(potential_acoustic(:)))
+ else
+ displnorm_all = 0.d0
+ endif
+
+ displnorm_all_glob = displnorm_all
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+#endif
+
+ if (myrank == 0) &
+ write(IOUT,*) 'Max absolute value of scalar field in fluid (acoustic) = ',displnorm_all_glob
+
+ ! check stability of the code in fluid, exit if unstable
+ ! negative values can occur with some compilers when the unstable value is greater
+ ! than the greatest possible floating-point number of the machine
+ if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
+ call exit_MPI('code became unstable and blew up in fluid (acoustic)')
+
+ endif
+
+ ! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+ ! time_values(1): year
+ ! time_values(2): month of the year
+ ! time_values(3): day of the month
+ ! time_values(5): hour of the day
+ ! time_values(6): minutes of the hour
+ ! time_values(7): seconds of the minute
+ ! time_values(8): milliseconds of the second
+ ! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+ month_end = time_values(2)
+ year_end = time_values(1)
+
+ ! elapsed time since beginning of the simulation
+ if (myrank == 0) then
+ if(month_end == month_start .and. year_end == year_start) then
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(IOUT,*) 'Elapsed time in seconds = ',tCPU
+ write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+
+ ! compute estimated remaining simulation time
+ t_remain = (NSTEP - it) * (tCPU/dble(it))
+ int_t_remain = int(t_remain)
+ ihours_remain = int_t_remain / 3600
+ iminutes_remain = (int_t_remain - 3600*ihours_remain) / 60
+ iseconds_remain = int_t_remain - 3600*ihours_remain - 60*iminutes_remain
+ write(IOUT,*) 'Time steps remaining = ',NSTEP - it
+ write(IOUT,*) 'Estimated remaining time in seconds = ',t_remain
+ write(IOUT,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_remain,iminutes_remain,iseconds_remain
+
+ ! compute estimated total simulation time
+ t_total = t_remain + tCPU
+ int_t_total = int(t_total)
+ ihours_total = int_t_total / 3600
+ iminutes_total = (int_t_total - 3600*ihours_total) / 60
+ iseconds_total = int_t_total - 3600*ihours_total - 60*iminutes_total
+ write(IOUT,*) 'Estimated total run time in seconds = ',t_total
+ write(IOUT,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_total,iminutes_total,iseconds_total
+
+ if(it < NSTEP) then
+ ! compute date and time at which the run should finish
+ ! (useful for long runs); for simplicity only minutes
+ ! are considered, seconds are ignored; in any case the prediction is not
+ ! accurate down to seconds because of system and network fluctuations
+ year = time_values(1)
+ mon = time_values(2)
+ day = time_values(3)
+ hr = time_values(5)
+ minutes = time_values(6)
+
+ ! get timestamp in minutes of current date and time
+ call convtime(timestamp,year,mon,day,hr,minutes)
+
+ ! add remaining minutes
+ timestamp = timestamp + nint(t_remain / 60.d0)
+
+ ! get date and time of that future timestamp in minutes
+ call invtime(timestamp,year,mon,day,hr,minutes)
+
+ ! convert to Julian day to get day of the week
+ call calndr(day,mon,year,julian_day_number)
+ day_of_week = idaywk(julian_day_number)
+
+ write(IOUT,"(' The run will finish approximately on: ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
+ weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
+
+ endif
+ write(IOUT,*)
+ else
+ write(IOUT,*) 'The calendar has crossed the end of the month during the simulation,'
+ write(IOUT,*) 'cannot produce accurate CPU time estimates any more.'
+ write(IOUT,*)
+ endif
+ endif
+
+ if (myrank == 0) write(IOUT,*)
+
+ end subroutine check_stability
+
Copied: seismo/2D/SPECFEM2D/trunk/src/checkgrid.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/checkgrid.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/checkgrid.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/checkgrid.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,3102 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine checkgrid(vpext,vsext,rhoext,density,poroelastcoef, &
+ porosity,tortuosity,permeability,ibool,kmato, &
+ coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
+ assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat, &
+ f0,initialfield,time_function_type, &
+ coorg,xinterp,zinterp,shapeint,knods,simulation_title, &
+ npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,all_anisotropic, &
+ myrank,nproc,NSOURCES,poroelastic, &
+ freq0,Q0,TURN_VISCATTENUATION_ON)
+
+! check the mesh, stability and number of points per wavelength
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+! option to display only part of the mesh and not the whole mesh,
+! for instance to analyze Cuthill-McKee mesh partitioning etc.
+ integer :: UPPER_LIMIT_DISPLAY
+
+ integer :: npoin,nspec,numat
+ integer, dimension(nspec) :: kmato
+ logical, dimension(nspec) :: poroelastic
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
+
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(3,numat) :: permeability
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
+
+ double precision coord(NDIM,npoin)
+
+ integer :: NSOURCES
+ integer, dimension(NSOURCES) :: time_function_type
+ double precision, dimension(NSOURCES) :: f0
+
+ integer :: pointsdisp,npgeo,ngnod
+
+ integer :: knods(ngnod,nspec)
+
+ double precision :: xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
+ double precision :: shapeint(ngnod,pointsdisp,pointsdisp)
+
+ double precision :: coorg(NDIM,npgeo)
+
+! title of the plot
+ character(len=60) :: simulation_title
+
+ double precision :: vpImin,vpImax
+ double precision :: vpIImin,vpIImax
+ double precision :: deltat
+
+ logical :: assign_external_model,initialfield,any_elastic,any_poroelastic,all_anisotropic, &
+ TURN_VISCATTENUATION_ON
+
+ integer :: myrank,nproc
+
+ ! local parameters
+ double precision vpIImax_local,vpIImin_local
+ double precision vsmin,vsmax,densmin,densmax,vpImax_local,vpImin_local,vsmin_local
+ double precision kappa_s,kappa_f,kappa_fr,mu_s,mu_fr,denst_s,denst_f,denst,phi,tort,cpIloc,cpIIloc,csloc
+ double precision D_biot,H_biot,C_biot,M_biot,cpIsquare,cpIIsquare,cssquare
+ double precision f0min,f0max,freq0,Q0,w_c,eta_f,perm
+ double precision lambdaplus2mu,mu
+ double precision distance_min,distance_max,distance_min_local,distance_max_local
+ double precision courant_stability_number_max,lambdaPImin,lambdaPImax,lambdaPIImin,lambdaPIImax, &
+ lambdaSmin,lambdaSmax
+ double precision distance_1,distance_2,distance_3,distance_4
+
+! for the stability condition
+! maximum polynomial degree for which we can compute the stability condition
+ integer, parameter :: NGLLX_MAX_STABILITY = 15
+ double precision :: percent_GLL(NGLLX_MAX_STABILITY)
+
+! color palette
+ integer, parameter :: NUM_COLORS = 236
+ double precision, dimension(NUM_COLORS) :: red,green,blue
+
+ double precision :: xmax,zmax,height,usoffset,sizex,sizez,courant_stability_number
+ double precision :: x1,z1,x2,z2,ratio_page,xmin,zmin,lambdaS_local,lambdaPI_local
+
+#ifdef USE_MPI
+ integer :: icol
+ double precision :: vpImin_glob,vpImax_glob,vsmin_glob,vsmax_glob,densmin_glob,densmax_glob
+ double precision :: vpIImin_glob,vpIImax_glob
+ double precision :: distance_min_glob,distance_max_glob
+ double precision :: courant_stability_max_glob,lambdaPImin_glob,lambdaPImax_glob,&
+ lambdaPIImin_glob,lambdaPIImax_glob,lambdaSmin_glob,lambdaSmax_glob
+ double precision :: xmin_glob, xmax_glob, zmin_glob, zmax_glob
+#endif
+
+ logical :: any_elastic_glob,any_poroelastic_glob
+ double precision, dimension(2,nspec*5) :: coorg_send
+ double precision, dimension(:,:), allocatable :: coorg_recv
+ integer, dimension(nspec) :: RGB_send
+ integer, dimension(:), allocatable :: RGB_recv
+ real, dimension(nspec) :: greyscale_send
+ real, dimension(:), allocatable :: greyscale_recv
+ integer :: nspec_recv
+ integer :: num_ispec
+ integer :: iproc
+ integer :: ier
+ integer :: i,j,ispec,material
+ integer :: is,ir,in,nnum
+
+#ifdef USE_MPI
+ integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
+#endif
+
+ ! check
+ if(UPPER_LIMIT_DISPLAY > nspec) &
+ call exit_MPI('cannot have UPPER_LIMIT_DISPLAY > nspec in checkgrid.F90')
+
+#ifndef USE_MPI
+ allocate(coorg_recv(1,1))
+ allocate(RGB_recv(1))
+ allocate(greyscale_recv(1))
+ nspec_recv = 0
+ ier = 0
+ iproc = nproc
+ deallocate(coorg_recv)
+ deallocate(RGB_recv)
+ deallocate(greyscale_recv)
+#endif
+
+
+! define percentage of smallest distance between GLL points for NGLLX points
+! percentages were computed by calling the GLL points routine for each degree
+ call checkgrid_setup_GLLper(percent_GLL,NGLLX_MAX_STABILITY)
+
+! define color palette in random order
+ call checkgrid_setup_colorp(red,green,blue,NUM_COLORS)
+
+!---- compute parameters for the spectral elements
+
+ vpImin = HUGEVAL
+ vpImax = -HUGEVAL
+
+ if(any_elastic .or. any_poroelastic) then
+ vsmin = HUGEVAL
+ vsmax = -HUGEVAL
+ else
+ vsmin = 0
+ vsmax = 0
+ endif
+
+ if(any_poroelastic) then
+ vpIImin = HUGEVAL
+ vpIImax = -HUGEVAL
+ else
+ vpIImin = 0
+ vpIImax = 0
+ endif
+
+ densmin = HUGEVAL
+ densmax = -HUGEVAL
+
+ distance_min = HUGEVAL
+ distance_max = -HUGEVAL
+
+ courant_stability_number_max = -HUGEVAL
+
+ lambdaPImin = HUGEVAL
+ lambdaPImax = -HUGEVAL
+
+ if(any_elastic .or. any_poroelastic) then
+ lambdaSmin = HUGEVAL
+ lambdaSmax = -HUGEVAL
+ else
+ lambdaSmin = 0
+ lambdaSmax = 0
+ endif
+
+ if(any_poroelastic) then
+ lambdaPIImin = HUGEVAL
+ lambdaPIImax = -HUGEVAL
+ else
+ lambdaPIImin = 0
+ lambdaPIImax = 0
+ endif
+
+ do ispec=1,nspec
+
+ material = kmato(ispec)
+
+ if(poroelastic(ispec)) then
+
+ ! poroelastic material
+
+ phi = porosity(material)
+ tort = tortuosity(material)
+ perm = permeability(1,material)
+ ! solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+ denst = denst_s
+ ! fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+ eta_f = poroelastcoef(2,2,material)
+ ! frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ ! Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
+ tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIloc = sqrt(cpIsquare)
+ cpIIloc = sqrt(cpIIsquare)
+ csloc = sqrt(cssquare)
+ else
+ mu = poroelastcoef(2,1,material)
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
+
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ cpIIloc = 0.d0
+ csloc = sqrt(mu/denst)
+ endif
+
+ vpImax_local = -HUGEVAL
+ vpImin_local = HUGEVAL
+ vpIImax_local = -HUGEVAL
+ vpIImin_local = HUGEVAL
+ vsmin_local = HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cpIloc = vpext(i,j,ispec)
+ csloc = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ endif
+
+!--- compute min and max of velocity and density models
+ vpImin = min(vpImin,cpIloc)
+ vpImax = max(vpImax,cpIloc)
+
+! ignore acoustic and elastic regions with cpII = 0
+ if(cpIIloc > 0.0001d0) vpIImin = min(vpIImin,cpIIloc)
+ vpIImax = max(vpIImax,cpIIloc)
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) vsmin = min(vsmin,csloc)
+ vsmax = max(vsmax,csloc)
+
+ densmin = min(densmin,denst)
+ densmax = max(densmax,denst)
+
+ vpImax_local = max(vpImax_local,vpImax)
+ vpImin_local = min(vpImin_local,vpImin)
+ vpIImax_local = max(vpIImax_local,vpIImax)
+ vpIImin_local = min(vpIImin_local,vpIImin)
+ vsmin_local = min(vsmin_local,vsmin)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ distance_min = min(distance_min,distance_min_local)
+ distance_max = max(distance_max,distance_max_local)
+
+ courant_stability_number_max = max(courant_stability_number_max, &
+ vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX)))
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) then
+ lambdaSmin = min(lambdaSmin,vsmin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaSmax = max(lambdaSmax,vsmin_local / (distance_max_local / (NGLLX - 1)))
+ endif
+
+ lambdaPImin = min(lambdaPImin,vpImin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPImax = max(lambdaPImax,vpImin_local / (distance_max_local / (NGLLX - 1)))
+
+ if(cpIIloc > 0.0001d0) then
+ lambdaPIImin = min(lambdaPIImin,vpIImin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPIImax = max(lambdaPIImax,vpIImin_local / (distance_max_local / (NGLLX - 1)))
+ endif
+
+ enddo
+
+ any_elastic_glob = any_elastic
+ any_poroelastic_glob = any_poroelastic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (vpImin, vpImin_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpImax, vpImax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpIImin, vpIImin_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpIImax, vpIImax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vsmin, vsmin_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vsmax, vsmax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (densmin, densmin_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (densmax, densmax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (distance_min, distance_min_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (distance_max, distance_max_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (courant_stability_number_max, courant_stability_max_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPImin, lambdaPImin_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPImax, lambdaPImax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPIImin, lambdaPIImin_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPIImax, lambdaPIImax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaSmin, lambdaSmin_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaSmax, lambdaSmax_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (any_elastic, any_elastic_glob, 1, MPI_LOGICAL, &
+ MPI_LOR, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, &
+ MPI_LOR, MPI_COMM_WORLD, ier)
+ vpImin = vpImin_glob
+ vpImax = vpImax_glob
+ vpIImin = vpIImin_glob
+ vpIImax = vpIImax_glob
+ vsmin = vsmin_glob
+ vsmax = vsmax_glob
+ densmin = densmin_glob
+ densmax = densmax_glob
+ distance_min = distance_min_glob
+ distance_max = distance_max_glob
+ courant_stability_number_max = courant_stability_max_glob
+ lambdaPImin = lambdaPImin_glob
+ lambdaPImax = lambdaPImax_glob
+ lambdaPIImin = lambdaPIImin_glob
+ lambdaPIImax = lambdaPIImax_glob
+ lambdaSmin = lambdaSmin_glob
+ lambdaSmax = lambdaSmax_glob
+
+#endif
+
+ if ( myrank == 0 ) then
+ if(.not. all_anisotropic) then
+ write(IOUT,*)
+ write(IOUT,*) '********'
+ write(IOUT,*) 'Model: P (or PI) velocity min,max = ',vpImin,vpImax
+ write(IOUT,*) 'Model: PII velocity min,max = ',vpIImin,vpIImax
+ write(IOUT,*) 'Model: S velocity min,max = ',vsmin,vsmax
+ write(IOUT,*) 'Model: density min,max = ',densmin,densmax
+ write(IOUT,*) '********'
+ write(IOUT,*)
+
+ write(IOUT,*)
+ write(IOUT,*) '*********************************************'
+ write(IOUT,*) '*** Verification of simulation parameters ***'
+ write(IOUT,*) '*********************************************'
+ write(IOUT,*)
+ write(IOUT,*) '*** Max grid size = ',distance_max
+ write(IOUT,*) '*** Min grid size = ',distance_min
+ write(IOUT,*) '*** Max/min ratio = ',distance_max/distance_min
+ write(IOUT,*)
+ write(IOUT,*) '*** Max stability for P wave velocity = ',courant_stability_number_max
+ write(IOUT,*)
+ end if
+
+! only if time source is not a Dirac or Heaviside (otherwise maximum frequency of spectrum undefined)
+! and if source is not an initial field, for the same reason
+ if(.not. initialfield) then
+ f0max = -HUGEVAL
+ f0min = HUGEVAL
+! write(IOUT,*) ' USER_T0 = ',USER_T0
+
+ do i = 1,NSOURCES
+
+ ! excludes Dirac and Heaviside sources
+ if(time_function_type(i) /= 4 .and. time_function_type(i) /= 5) then
+! write(IOUT,*) ' Onset time = ',t0+tshift_src(i)
+! write(IOUT,*) ' Fundamental period = ',1.d0/f0(i)
+! write(IOUT,*) ' Fundamental frequency = ',f0(i)
+! ! checks source onset time
+! if( t0+tshift_src(i) <= 1.d0/f0(i)) then
+! call exit_MPI('Onset time too small')
+! else
+! write(IOUT,*) ' --> onset time ok'
+! endif
+
+ ! sets min/max frequency
+ if(f0(i) > f0max) f0max = f0(i)
+ if(f0(i) < f0min) f0min = f0(i)
+
+ if( i == NSOURCES ) then
+ write(IOUT,*) '----'
+ write(IOUT,*) ' Nb pts / lambdaPImin_fmax max = ',lambdaPImax/(2.5d0*f0min)
+ write(IOUT,*) ' Nb pts / lambdaPImin_fmax min = ',lambdaPImin/(2.5d0*f0max)
+ write(IOUT,*) '----'
+ write(IOUT,*) ' Nb pts / lambdaPIImin_fmax max = ',lambdaPIImax/(2.5d0*f0min)
+ write(IOUT,*) ' Nb pts / lambdaPIImin_fmax min = ',lambdaPIImin/(2.5d0*f0max)
+ write(IOUT,*) '----'
+ write(IOUT,*) ' Nb pts / lambdaSmin_fmax max = ',lambdaSmax/(2.5d0*f0min)
+ write(IOUT,*) ' Nb pts / lambdaSmin_fmax min = ',lambdaSmin/(2.5d0*f0max)
+ write(IOUT,*) '----'
+ endif
+
+ endif
+ enddo
+ endif
+ endif
+
+!
+!--------------------------------------------------------------------------------
+!
+
+! A4 or US letter paper
+ if(US_LETTER) then
+ usoffset = 1.75d0
+ sizex = 27.94d0
+ sizez = 21.59d0
+ else
+ usoffset = 0.d0
+ sizex = 29.7d0
+ sizez = 21.d0
+ endif
+
+! height of domain numbers in centimeters
+ height = 0.25d0
+
+! get minimum and maximum values of mesh coordinates
+ xmin = minval(coord(1,:))
+ zmin = minval(coord(2,:))
+ xmax = maxval(coord(1,:))
+ zmax = maxval(coord(2,:))
+
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (xmin, xmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (xmax, xmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (zmin, zmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (zmax, zmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ xmin = xmin_glob
+ xmax = xmax_glob
+ zmin = zmin_glob
+ zmax = zmax_glob
+
+#endif
+
+! ratio of physical page size/size of the domain meshed
+ ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
+
+
+ if (myrank == 0) then
+
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with stability condition'
+
+!
+!---- open PostScript file
+!
+ open(unit=24,file='OUTPUT_FILES/mesh_stability.ps',status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+ !
+ !--- write captions of PostScript figure
+ !
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Z axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(Mesh stability condition \(red = bad\)) show'
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+ !
+ !---- draw the spectral element mesh
+ !
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ num_ispec = 0
+ endif
+
+ do ispec = 1, nspec
+ if ( myrank == 0 ) then
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ endif
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ if ( myrank == 0 ) then
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+ else
+ coorg_send(1,(ispec-1)*5+1) = x1
+ coorg_send(2,(ispec-1)*5+1) = z1
+ endif
+
+ ! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+2) = x2
+ coorg_send(2,(ispec-1)*5+2) = z2
+ endif
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+3) = x2
+ coorg_send(2,(ispec-1)*5+3) = z2
+ endif
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+4) = x2
+ coorg_send(2,(ispec-1)*5+4) = z2
+ endif
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ write(24,*) 'CO'
+ else
+ coorg_send(1,(ispec-1)*5+5) = x2
+ coorg_send(2,(ispec-1)*5+5) = z2
+ endif
+
+ material = kmato(ispec)
+
+ if(poroelastic(ispec)) then
+
+ ! poroelastic material
+
+ phi=porosity(material)
+ tort=tortuosity(material)
+ perm=permeability(1,material)
+ ! solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+ denst = denst_s
+ ! fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+ eta_f = poroelastcoef(2,2,material)
+ ! frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ ! Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
+ tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIloc = sqrt(cpIsquare)
+ else
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
+
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ endif
+
+ vpImax_local = -HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ !--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cpIloc = vpext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ endif
+
+ vpImax_local = max(vpImax_local,cpIloc)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ distance_min = min(distance_min,distance_min_local)
+ distance_max = max(distance_max,distance_max_local)
+
+ courant_stability_number = vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX))
+
+! display bad elements that are above 80% of the threshold
+ if(courant_stability_number >= 0.80 * courant_stability_number_max) then
+ if ( myrank == 0 ) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ else
+ RGB_send(ispec) = 1
+ endif
+ else
+! do not color the elements if below the threshold
+ if ( myrank == 0 ) then
+ write(24,*) 'ST'
+ else
+ RGB_send(ispec) = 0
+ endif
+ endif
+
+ enddo ! end of loop on all the spectral elements
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ allocate(coorg_recv(2,nspec_recv*5))
+ allocate(RGB_recv(nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ call MPI_RECV (RGB_recv(1), nspec_recv, MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ do ispec = 1, nspec_recv
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ write(24,*) 'mark'
+ write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
+ write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
+ write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
+ write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
+ write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
+ write(24,*) 'CO'
+ if ( RGB_recv(ispec) == 1) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ else
+ write(24,*) 'ST'
+ endif
+ enddo
+ deallocate(coorg_recv)
+ deallocate(RGB_recv)
+
+ enddo
+
+ else
+ call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (coorg_send, nspec*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (RGB_send, nspec, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ write(IOUT,*) 'End of creation of PostScript file with stability condition'
+ endif
+
+!
+!--------------------------------------------------------------------------------
+!
+
+ if (myrank == 0) then
+
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with mesh dispersion'
+
+!
+!---- open PostScript file
+!
+ if(any_elastic_glob .or. any_poroelastic) then
+ open(unit=24,file='OUTPUT_FILES/mesh_S_wave_dispersion.ps',status='unknown')
+ else
+ open(unit=24,file='OUTPUT_FILES/mesh_P_wave_dispersion.ps',status='unknown')
+ endif
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Z axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ if(any_elastic_glob) then
+ write(24,*) '(Mesh elastic S-wave dispersion \(red = good, blue = bad\)) show'
+ else
+ write(24,*) '(Mesh acoustic P-wave dispersion \(red = good, blue = bad\)) show'
+ endif
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ num_ispec = 0
+ endif
+
+ do ispec = 1, nspec
+ if ( myrank == 0 ) then
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ endif
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ if ( myrank == 0 ) then
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+ else
+ coorg_send(1,(ispec-1)*5+1) = x1
+ coorg_send(2,(ispec-1)*5+1) = z1
+ endif
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+2) = x2
+ coorg_send(2,(ispec-1)*5+2) = z2
+ endif
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+3) = x2
+ coorg_send(2,(ispec-1)*5+3) = z2
+ endif
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+4) = x2
+ coorg_send(2,(ispec-1)*5+4) = z2
+ endif
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ write(24,*) 'CO'
+ else
+ coorg_send(1,(ispec-1)*5+5) = x2
+ coorg_send(2,(ispec-1)*5+5) = z2
+ endif
+
+ material = kmato(ispec)
+
+ if(poroelastic(ispec)) then
+ phi = porosity(material)
+ tort = tortuosity(material)
+ perm = permeability(1,material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+ denst = denst_s
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+ eta_f = poroelastcoef(2,2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+!Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
+ tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIloc = sqrt(cpIsquare)
+ csloc = sqrt(cssquare)
+ else
+ mu = poroelastcoef(2,1,material)
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
+
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+ endif
+
+ vpImax_local = -HUGEVAL
+ vpImin_local = HUGEVAL
+ vsmin_local = HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cpIloc = vpext(i,j,ispec)
+ csloc = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ endif
+
+ vpImax_local = max(vpImax_local,cpIloc)
+ vpImin_local = min(vpImin_local,cpIloc)
+ vsmin_local = min(vsmin_local,csloc)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ distance_min = min(distance_min,distance_min_local)
+ distance_max = max(distance_max,distance_max_local)
+
+! display mesh dispersion for S waves if there is at least one elastic element in the mesh
+ if(any_elastic_glob .or. any_poroelastic_glob) then
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) then
+
+ lambdaS_local = vsmin_local / (distance_max_local / (NGLLX - 1))
+
+! display very good elements that are above 80% of the threshold in red
+ if(lambdaS_local >= 0.80 * lambdaSmax) then
+ if ( myrank == 0 ) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ else
+ RGB_send(ispec) = 1
+ endif
+
+! display bad elements that are below 120% of the threshold in blue
+ else if(lambdaS_local <= 1.20 * lambdaSmin) then
+ if ( myrank == 0 ) then
+ write(24,*) '0 0 1 RG GF 0 setgray ST'
+ else
+ RGB_send(ispec) = 3
+ endif
+
+ else
+! do not color the elements if not close to the threshold
+ if ( myrank == 0 ) then
+ write(24,*) 'ST'
+ else
+ RGB_send(ispec) = 0
+ endif
+ endif
+
+ else
+! do not color the elements if S-wave velocity undefined
+ if ( myrank == 0 ) then
+ write(24,*) 'ST'
+ else
+ RGB_send(ispec) = 0
+ endif
+ endif
+
+! display mesh dispersion for P waves if there is no elastic element in the mesh
+ else
+
+ lambdaPI_local = vpImin_local / (distance_max_local / (NGLLX - 1))
+
+! display very good elements that are above 80% of the threshold in red
+ if(lambdaPI_local >= 0.80 * lambdaPImax) then
+ if ( myrank == 0 ) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ else
+ RGB_send(ispec) = 1
+ endif
+
+! display bad elements that are below 120% of the threshold in blue
+ else if(lambdaPI_local <= 1.20 * lambdaPImin) then
+ if ( myrank == 0 ) then
+ write(24,*) '0 0 1 RG GF 0 setgray ST'
+ else
+ RGB_send(ispec) = 3
+ endif
+
+ else
+! do not color the elements if not close to the threshold
+ if ( myrank == 0 ) then
+ write(24,*) 'ST'
+ else
+ RGB_send(ispec) = 0
+ endif
+ endif
+
+ endif
+
+ enddo ! end of loop on all the spectral elements
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ allocate(coorg_recv(2,nspec_recv*5))
+ allocate(RGB_recv(nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ call MPI_RECV (RGB_recv(1), nspec_recv, MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ do ispec = 1, nspec_recv
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ write(24,*) 'mark'
+ write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
+ write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
+ write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
+ write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
+ write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
+ write(24,*) 'CO'
+ if ( RGB_recv(ispec) == 1) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ endif
+ if ( RGB_recv(ispec) == 3) then
+ write(24,*) '0 0 1 RG GF 0 setgray ST'
+ endif
+ if ( RGB_recv(ispec) == 0) then
+ write(24,*) 'ST'
+ endif
+
+ enddo
+ deallocate(coorg_recv)
+ deallocate(RGB_recv)
+
+ enddo
+
+ else
+ call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (coorg_send, nspec*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (RGB_send, nspec, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+
+ endif
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ write(IOUT,*) 'End of creation of PostScript file with mesh dispersion'
+
+ endif
+
+!
+!--------------------------------------------------------------------------------
+!
+
+ if (myrank == 0) then
+
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with velocity model'
+
+!
+!---- open PostScript file
+!
+ open(unit=24,file='OUTPUT_FILES/P_velocity_model.ps',status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Z axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(P-velocity model \(dark = fast, light = slow\)) show'
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ num_ispec = 0
+endif
+
+ do ispec = 1, UPPER_LIMIT_DISPLAY
+ if ( myrank == 0 ) then
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ endif
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ if ( myrank == 0 ) then
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+ else
+ coorg_send(1,(ispec-1)*5+1) = x1
+ coorg_send(2,(ispec-1)*5+1) = z1
+ endif
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+2) = x2
+ coorg_send(2,(ispec-1)*5+2) = z2
+ endif
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+3) = x2
+ coorg_send(2,(ispec-1)*5+3) = z2
+ endif
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+4) = x2
+ coorg_send(2,(ispec-1)*5+4) = z2
+ endif
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ write(24,*) 'CO'
+ else
+ coorg_send(1,(ispec-1)*5+5) = x2
+ coorg_send(2,(ispec-1)*5+5) = z2
+ endif
+
+ if((vpImax-vpImin)/vpImin > 0.02d0) then
+ if(assign_external_model) then
+! use lower-left corner
+ x1 = (vpext(1,1,ispec)-vpImin) / (vpImax-vpImin)
+ else
+ material = kmato(ispec)
+ if(poroelastic(ispec)) then
+ phi = porosity(material)
+ tort = tortuosity(material)
+ perm = permeability(1,material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+ eta_f = poroelastcoef(2,2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+!Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mu_fr,phi, &
+ tort,denst_s,denst_f,eta_f,perm,f0(1),freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIloc = sqrt(cpIsquare)
+ else
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ endif
+ x1 = (cpIloc-vpImin)/(vpImax-vpImin)
+ endif
+ else
+ x1 = 0.5d0
+ endif
+
+! rescale to avoid very dark gray levels
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+! invert scale: white = vpmin, dark gray = vpmax
+ x1 = 1.d0 - x1
+
+! display P-velocity model using gray levels
+ if ( myrank == 0 ) then
+ write(24,*) sngl(x1),' setgray GF 0 setgray ST'
+ else
+ greyscale_send(ispec) = sngl(x1)
+ endif
+ enddo ! end of loop on all the spectral elements
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ allocate(coorg_recv(2,nspec_recv*5))
+ allocate(greyscale_recv(nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ call MPI_RECV (greyscale_recv(1), nspec_recv, MPI_REAL, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ do ispec = 1, nspec_recv
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ write(24,*) 'mark'
+ write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
+ write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
+ write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
+ write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
+ write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
+ write(24,*) 'CO'
+ write(24,*) greyscale_recv(ispec), ' setgray GF 0 setgray ST'
+
+ enddo
+ deallocate(coorg_recv)
+ deallocate(greyscale_recv)
+
+ enddo
+
+ else
+ call MPI_SEND (UPPER_LIMIT_DISPLAY, 1, MPI_INTEGER, &
+ 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (coorg_send, UPPER_LIMIT_DISPLAY*5*2, MPI_DOUBLE_PRECISION, &
+ 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (greyscale_send, UPPER_LIMIT_DISPLAY, MPI_INTEGER, &
+ 0, 42, MPI_COMM_WORLD, ier)
+ endif
+#endif
+
+ if (myrank == 0) then
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ write(IOUT,*) 'End of creation of PostScript file with velocity model'
+
+ endif
+
+ if (myrank == 0) then
+
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with mesh partitioning'
+
+!
+!---- open PostScript file
+!
+ open(unit=24,file='OUTPUT_FILES/mesh_partitioning.ps',status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Z axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(Mesh partitioning) show'
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ num_ispec = 0
+ endif
+
+ do ispec = 1, UPPER_LIMIT_DISPLAY
+
+ if ( myrank == 0 ) then
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ endif
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ if ( myrank == 0 ) then
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+ else
+ coorg_send(1,(ispec-1)*5+1) = x1
+ coorg_send(2,(ispec-1)*5+1) = z1
+ endif
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+2) = x2
+ coorg_send(2,(ispec-1)*5+2) = z2
+ endif
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+3) = x2
+ coorg_send(2,(ispec-1)*5+3) = z2
+ endif
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ coorg_send(1,(ispec-1)*5+4) = x2
+ coorg_send(2,(ispec-1)*5+4) = z2
+ endif
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ write(24,*) 'CO'
+ else
+ coorg_send(1,(ispec-1)*5+5) = x2
+ coorg_send(2,(ispec-1)*5+5) = z2
+ endif
+
+ if ( myrank == 0 ) then
+ write(24,*) red(1), green(1), blue(1), 'RG GF 0 setgray ST'
+ endif
+
+ enddo ! end of loop on all the spectral elements
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+
+! use a different color for each material set
+ icol = mod(iproc, NUM_COLORS) + 1
+
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ allocate(coorg_recv(2,nspec_recv*5))
+ call MPI_RECV (coorg_recv(1,1), nspec_recv*5*2, MPI_DOUBLE_PRECISION, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ do ispec = 1, nspec_recv
+ num_ispec = num_ispec + 1
+ write(24,*) '% elem ',num_ispec
+ write(24,*) 'mark'
+ write(24,681) coorg_recv(1,(ispec-1)*5+1), coorg_recv(2,(ispec-1)*5+1)
+ write(24,681) coorg_recv(1,(ispec-1)*5+2), coorg_recv(2,(ispec-1)*5+2)
+ write(24,681) coorg_recv(1,(ispec-1)*5+3), coorg_recv(2,(ispec-1)*5+3)
+ write(24,681) coorg_recv(1,(ispec-1)*5+4), coorg_recv(2,(ispec-1)*5+4)
+ write(24,681) coorg_recv(1,(ispec-1)*5+5), coorg_recv(2,(ispec-1)*5+5)
+ write(24,*) 'CO'
+
+ write(24,*) red(icol), green(icol), blue(icol), ' RG GF 0 setgray ST'
+
+ enddo
+ deallocate(coorg_recv)
+
+ enddo
+
+ else
+ call MPI_SEND (UPPER_LIMIT_DISPLAY, 1, MPI_INTEGER, &
+ 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (coorg_send, UPPER_LIMIT_DISPLAY*5*2, MPI_DOUBLE_PRECISION, &
+ 0, 42, MPI_COMM_WORLD, ier)
+
+ endif
+#endif
+
+ if (myrank == 0) then
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ write(IOUT,*) 'End of creation of PostScript file with partitioning'
+ write(IOUT,*)
+ endif
+
+ 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a100,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
+
+ 681 format(f6.2,1x,f6.2)
+
+ end subroutine checkgrid
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine checkgrid_setup_GLLper(percent_GLL,NGLLX_MAX_STABILITY)
+
+ implicit none
+ include "constants.h"
+
+ integer :: NGLLX_MAX_STABILITY
+ double precision :: percent_GLL(NGLLX_MAX_STABILITY)
+
+ if( NGLLX_MAX_STABILITY /= 15 ) call exit_MPI('check NGLLX_MAX_STABILITY in checkgrid.f90')
+
+! define percentage of smallest distance between GLL points for NGLLX points
+! percentages were computed by calling the GLL points routine for each degree
+
+ percent_GLL(2) = 100.d0
+ percent_GLL(3) = 50.d0
+ percent_GLL(4) = 27.639320225002102d0
+ percent_GLL(5) = 17.267316464601141d0
+ percent_GLL(6) = 11.747233803526763d0
+ percent_GLL(7) = 8.4888051860716516d0
+ percent_GLL(8) = 6.4129925745196719d0
+ percent_GLL(9) = 5.0121002294269914d0
+ percent_GLL(10) = 4.0233045916770571d0
+ percent_GLL(11) = 3.2999284795970416d0
+ percent_GLL(12) = 2.7550363888558858d0
+ percent_GLL(13) = 2.3345076678918053d0
+ percent_GLL(14) = 2.0032477366369594d0
+ percent_GLL(15) = 1.7377036748080721d0
+
+! convert to real percentage
+ percent_GLL(:) = percent_GLL(:) / 100.d0
+
+ if(NGLLX > NGLLX_MAX_STABILITY) then
+ call exit_MPI('cannot estimate the stability condition for that degree')
+ endif
+
+ end subroutine checkgrid_setup_GLLper
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine checkgrid_setup_colorp(red,green,blue,NUM_COLORS)
+
+! color palette
+
+ implicit none
+ integer :: NUM_COLORS
+ double precision, dimension(NUM_COLORS) :: red,green,blue
+
+ if( NUM_COLORS /= 236 ) call exit_MPI('check NUM_COLORS in checkgrid.f90')
+
+! red
+ red(1) = 1.00000000000000
+ green(1) = 0.000000000000000E+000
+ blue(1) = 0.000000000000000E+000
+
+! DodgerBlue2
+ red(2) = 0.109803921568627
+ green(2) = 0.525490196078431
+ blue(2) = 0.933333333333333
+
+! gold
+ red(3) = 1.00000000000000
+ green(3) = 0.840000000000000
+ blue(3) = 0.000000000000000E+000
+
+! springgreen
+ red(4) = 0.000000000000000E+000
+ green(4) = 1.00000000000000
+ blue(4) = 0.500000000000000
+
+! NavajoWhite
+ red(5) = 1.00000000000000
+ green(5) = 0.870588235294118
+ blue(5) = 0.678431372549020
+
+! SteelBlue3
+ red(6) = 0.309803921568627
+ green(6) = 0.580392156862745
+ blue(6) = 0.803921568627451
+
+! Ivory3
+ red(7) = 0.803921568627451
+ green(7) = 0.803921568627451
+ blue(7) = 0.756862745098039
+
+! SkyBlue4
+ red(8) = 0.290196078431373
+ green(8) = 0.439215686274510
+ blue(8) = 0.545098039215686
+
+! Snow
+ red(9) = 0.980392156862745
+ green(9) = 0.980392156862745
+ blue(9) = 0.980392156862745
+
+! SteelBlue
+ red(10) = 0.274509803921569
+ green(10) = 0.509803921568627
+ blue(10) = 0.705882352941177
+
+! Bisque3
+ red(11) = 0.803921568627451
+ green(11) = 0.717647058823529
+ blue(11) = 0.619607843137255
+
+! Salmon
+ red(12) = 0.980392156862745
+ green(12) = 0.501960784313725
+ blue(12) = 0.447058823529412
+
+! SlateBlue2
+ red(13) = 0.478431372549020
+ green(13) = 0.403921568627451
+ blue(13) = 0.933333333333333
+
+! NavajoWhite2
+ red(14) = 0.933333333333333
+ green(14) = 0.811764705882353
+ blue(14) = 0.631372549019608
+
+! MediumBlue
+ red(15) = 0.000000000000000E+000
+ green(15) = 0.000000000000000E+000
+ blue(15) = 0.803921568627451
+
+! LightCoral
+ red(16) = 0.941176470588235
+ green(16) = 0.501960784313725
+ blue(16) = 0.501960784313725
+
+! FloralWhite
+ red(17) = 1.00000000000000
+ green(17) = 0.980392156862745
+ blue(17) = 0.941176470588235
+
+! Cornsilk3
+ red(18) = 0.803921568627451
+ green(18) = 0.784313725490196
+ blue(18) = 0.694117647058824
+
+! GhostWhite
+ red(19) = 0.972549019607843
+ green(19) = 0.972549019607843
+ blue(19) = 1.00000000000000
+
+! blue
+ red(20) = 0.000000000000000E+000
+ green(20) = 0.000000000000000E+000
+ blue(20) = 1.00000000000000
+
+! Linen
+ red(21) = 0.980392156862745
+ green(21) = 0.941176470588235
+ blue(21) = 0.901960784313726
+
+! peachpuff
+ red(22) = 1.00000000000000
+ green(22) = 0.850000000000000
+ blue(22) = 0.730000000000000
+
+! Cornsilk1
+ red(23) = 1.00000000000000
+ green(23) = 0.972549019607843
+ blue(23) = 0.862745098039216
+
+! LightSalmon
+ red(24) = 1.00000000000000
+ green(24) = 0.627450980392157
+ blue(24) = 0.478431372549020
+
+! DeepSkyBlue1
+ red(25) = 0.000000000000000E+000
+ green(25) = 0.749019607843137
+ blue(25) = 1.00000000000000
+
+! LemonChiffon4
+ red(26) = 0.545098039215686
+ green(26) = 0.537254901960784
+ blue(26) = 0.439215686274510
+
+! PeachPuff1
+ red(27) = 1.00000000000000
+ green(27) = 0.854901960784314
+ blue(27) = 0.725490196078431
+
+! BlanchedAlmond
+ red(28) = 1.00000000000000
+ green(28) = 0.921568627450980
+ blue(28) = 0.803921568627451
+
+! SlateBlue3
+ red(29) = 0.411764705882353
+ green(29) = 0.349019607843137
+ blue(29) = 0.803921568627451
+
+! LightSkyBlue1
+ red(30) = 0.690196078431373
+ green(30) = 0.886274509803922
+ blue(30) = 1.00000000000000
+
+! DarkViolet
+ red(31) = 0.580392156862745
+ green(31) = 0.000000000000000E+000
+ blue(31) = 0.827450980392157
+
+! Azure3
+ red(32) = 0.756862745098039
+ green(32) = 0.803921568627451
+ blue(32) = 0.803921568627451
+
+! LavenderBlush3
+ red(33) = 0.803921568627451
+ green(33) = 0.756862745098039
+ blue(33) = 0.772549019607843
+
+! Honeydew1
+ red(34) = 0.941176470588235
+ green(34) = 1.00000000000000
+ blue(34) = 0.941176470588235
+
+! Ivory2
+ red(35) = 0.933333333333333
+ green(35) = 0.933333333333333
+ blue(35) = 0.878431372549020
+
+! RosyBrown
+ red(36) = 0.737254901960784
+ green(36) = 0.560784313725490
+ blue(36) = 0.560784313725490
+
+! Thistle
+ red(37) = 0.847058823529412
+ green(37) = 0.749019607843137
+ blue(37) = 0.847058823529412
+
+! Orange
+ red(38) = 1.00000000000000
+ green(38) = 0.647058823529412
+ blue(38) = 0.000000000000000E+000
+
+! DarkSeaGreen
+ red(39) = 0.560784313725490
+ green(39) = 0.737254901960784
+ blue(39) = 0.560784313725490
+
+! Moccasin
+ red(40) = 1.00000000000000
+ green(40) = 0.894117647058824
+ blue(40) = 0.709803921568627
+
+! DeepSkyBlue2
+ red(41) = 0.000000000000000E+000
+ green(41) = 0.698039215686274
+ blue(41) = 0.933333333333333
+
+! SlateGray4
+ red(42) = 0.423529411764706
+ green(42) = 0.482352941176471
+ blue(42) = 0.545098039215686
+
+! Beige
+ red(43) = 0.960784313725490
+ green(43) = 0.960784313725490
+ blue(43) = 0.862745098039216
+
+! Gold
+ red(44) = 1.00000000000000
+ green(44) = 0.843137254901961
+ blue(44) = 0.000000000000000E+000
+
+! SlateBlue
+ red(45) = 0.415686274509804
+ green(45) = 0.352941176470588
+ blue(45) = 0.803921568627451
+
+! SteelBlue1
+ red(46) = 0.388235294117647
+ green(46) = 0.721568627450980
+ blue(46) = 1.00000000000000
+
+! SaddleBrown
+ red(47) = 0.545098039215686
+ green(47) = 0.270588235294118
+ blue(47) = 7.450980392156863E-002
+
+! Pink
+ red(48) = 1.00000000000000
+ green(48) = 0.752941176470588
+ blue(48) = 0.796078431372549
+
+! Black
+ red(49) = 0.000000000000000E+000
+ green(49) = 0.000000000000000E+000
+ blue(49) = 0.000000000000000E+000
+
+! SlateGrey
+ red(50) = 0.439215686274510
+ green(50) = 0.501960784313725
+ blue(50) = 0.564705882352941
+
+! Ivory
+ red(51) = 1.00000000000000
+ green(51) = 1.00000000000000
+ blue(51) = 0.941176470588235
+
+! OliveDrab
+ red(52) = 0.419607843137255
+ green(52) = 0.556862745098039
+ blue(52) = 0.137254901960784
+
+! Ivory1
+ red(53) = 1.00000000000000
+ green(53) = 1.00000000000000
+ blue(53) = 0.941176470588235
+
+! SkyBlue
+ red(54) = 0.529411764705882
+ green(54) = 0.807843137254902
+ blue(54) = 0.921568627450980
+
+! MistyRose3
+ red(55) = 0.803921568627451
+ green(55) = 0.717647058823529
+ blue(55) = 0.709803921568627
+
+! LimeGreen
+ red(56) = 0.196078431372549
+ green(56) = 0.803921568627451
+ blue(56) = 0.196078431372549
+
+! Purple
+ red(57) = 0.627450980392157
+ green(57) = 0.125490196078431
+ blue(57) = 0.941176470588235
+
+! SkyBlue2
+ red(58) = 0.494117647058824
+ green(58) = 0.752941176470588
+ blue(58) = 0.933333333333333
+
+! Red
+ red(59) = 1.00000000000000
+ green(59) = 0.000000000000000E+000
+ blue(59) = 0.000000000000000E+000
+
+! DarkKhaki
+ red(60) = 0.741176470588235
+ green(60) = 0.717647058823529
+ blue(60) = 0.419607843137255
+
+! MediumTurquoise
+ red(61) = 0.282352941176471
+ green(61) = 0.819607843137255
+ blue(61) = 0.800000000000000
+
+! Grey
+ red(62) = 0.745098039215686
+ green(62) = 0.745098039215686
+ blue(62) = 0.745098039215686
+
+! Coral
+ red(63) = 1.00000000000000
+ green(63) = 0.498039215686275
+ blue(63) = 0.313725490196078
+
+! NavajoWhite4
+ red(64) = 0.545098039215686
+ green(64) = 0.474509803921569
+ blue(64) = 0.368627450980392
+
+! SlateBlue4
+ red(65) = 0.278431372549020
+ green(65) = 0.235294117647059
+ blue(65) = 0.545098039215686
+
+! RoyalBlue4
+ red(66) = 0.152941176470588
+ green(66) = 0.250980392156863
+ blue(66) = 0.545098039215686
+
+! YellowGreen
+ red(67) = 0.603921568627451
+ green(67) = 0.803921568627451
+ blue(67) = 0.196078431372549
+
+! DeepSkyBlue3
+ red(68) = 0.000000000000000E+000
+ green(68) = 0.603921568627451
+ blue(68) = 0.803921568627451
+
+! goldenrod
+ red(69) = 0.854901960784314
+ green(69) = 0.647058823529412
+ blue(69) = 0.125490196078431
+
+! AntiqueWhite4
+ red(70) = 0.545098039215686
+ green(70) = 0.513725490196078
+ blue(70) = 0.470588235294118
+
+! lemonchiffon
+ red(71) = 1.00000000000000
+ green(71) = 0.980000000000000
+ blue(71) = 0.800000000000000
+
+! GreenYellow
+ red(72) = 0.678431372549020
+ green(72) = 1.00000000000000
+ blue(72) = 0.184313725490196
+
+! LightSlateGray
+ red(73) = 0.466666666666667
+ green(73) = 0.533333333333333
+ blue(73) = 0.600000000000000
+
+! RoyalBlue
+ red(74) = 0.254901960784314
+ green(74) = 0.411764705882353
+ blue(74) = 0.882352941176471
+
+! DarkGreen
+ red(75) = 0.000000000000000E+000
+ green(75) = 0.392156862745098
+ blue(75) = 0.000000000000000E+000
+
+! NavajoWhite3
+ red(76) = 0.803921568627451
+ green(76) = 0.701960784313725
+ blue(76) = 0.545098039215686
+
+! Azure1
+ red(77) = 0.941176470588235
+ green(77) = 1.00000000000000
+ blue(77) = 1.00000000000000
+
+! PowderBlue
+ red(78) = 0.690196078431373
+ green(78) = 0.878431372549020
+ blue(78) = 0.901960784313726
+
+! slateblue
+ red(79) = 0.420000000000000
+ green(79) = 0.350000000000000
+ blue(79) = 0.800000000000000
+
+! MediumOrchid
+ red(80) = 0.729411764705882
+ green(80) = 0.333333333333333
+ blue(80) = 0.827450980392157
+
+! turquoise
+ red(81) = 0.250000000000000
+ green(81) = 0.880000000000000
+ blue(81) = 0.820000000000000
+
+! Snow1
+ red(82) = 1.00000000000000
+ green(82) = 0.980392156862745
+ blue(82) = 0.980392156862745
+
+! violet
+ red(83) = 0.930000000000000
+ green(83) = 0.510000000000000
+ blue(83) = 0.930000000000000
+
+! DeepPink
+ red(84) = 1.00000000000000
+ green(84) = 7.843137254901961E-002
+ blue(84) = 0.576470588235294
+
+! MistyRose4
+ red(85) = 0.545098039215686
+ green(85) = 0.490196078431373
+ blue(85) = 0.482352941176471
+
+! PeachPuff3
+ red(86) = 0.803921568627451
+ green(86) = 0.686274509803922
+ blue(86) = 0.584313725490196
+
+! MediumSeaGreen
+ red(87) = 0.235294117647059
+ green(87) = 0.701960784313725
+ blue(87) = 0.443137254901961
+
+! Honeydew4
+ red(88) = 0.513725490196078
+ green(88) = 0.545098039215686
+ blue(88) = 0.513725490196078
+
+! Tan
+ red(89) = 0.823529411764706
+ green(89) = 0.705882352941177
+ blue(89) = 0.549019607843137
+
+! DarkGoldenrod
+ red(90) = 0.721568627450980
+ green(90) = 0.525490196078431
+ blue(90) = 4.313725490196078E-002
+
+! Blue2
+ red(91) = 0.000000000000000E+000
+ green(91) = 0.000000000000000E+000
+ blue(91) = 0.933333333333333
+
+! Maroon
+ red(92) = 0.690196078431373
+ green(92) = 0.188235294117647
+ blue(92) = 0.376470588235294
+
+! LightSkyBlue3
+ red(93) = 0.552941176470588
+ green(93) = 0.713725490196078
+ blue(93) = 0.803921568627451
+
+! LemonChiffon2
+ red(94) = 0.933333333333333
+ green(94) = 0.913725490196078
+ blue(94) = 0.749019607843137
+
+! Snow3
+ red(95) = 0.803921568627451
+ green(95) = 0.788235294117647
+ blue(95) = 0.788235294117647
+
+! Ivory4
+ red(96) = 0.545098039215686
+ green(96) = 0.545098039215686
+ blue(96) = 0.513725490196078
+
+! AntiqueWhite3
+ red(97) = 0.803921568627451
+ green(97) = 0.752941176470588
+ blue(97) = 0.690196078431373
+
+! Bisque4
+ red(98) = 0.545098039215686
+ green(98) = 0.490196078431373
+ blue(98) = 0.419607843137255
+
+! Snow2
+ red(99) = 0.933333333333333
+ green(99) = 0.913725490196078
+ blue(99) = 0.913725490196078
+
+! SlateGray1
+ red(100) = 0.776470588235294
+ green(100) = 0.886274509803922
+ blue(100) = 1.00000000000000
+
+! Seashell2
+ red(101) = 0.933333333333333
+ green(101) = 0.898039215686275
+ blue(101) = 0.870588235294118
+
+! Aquamarine
+ red(102) = 0.498039215686275
+ green(102) = 1.00000000000000
+ blue(102) = 0.831372549019608
+
+! SlateGray2
+ red(103) = 0.725490196078431
+ green(103) = 0.827450980392157
+ blue(103) = 0.933333333333333
+
+! White
+ red(104) = 1.00000000000000
+ green(104) = 1.00000000000000
+ blue(104) = 1.00000000000000
+
+! LavenderBlush
+ red(105) = 1.00000000000000
+ green(105) = 0.941176470588235
+ blue(105) = 0.960784313725490
+
+! DodgerBlue3
+ red(106) = 9.411764705882353E-002
+ green(106) = 0.454901960784314
+ blue(106) = 0.803921568627451
+
+! RoyalBlue3
+ red(107) = 0.227450980392157
+ green(107) = 0.372549019607843
+ blue(107) = 0.803921568627451
+
+! LightYellow
+ red(108) = 1.00000000000000
+ green(108) = 1.00000000000000
+ blue(108) = 0.878431372549020
+
+! DeepSkyBlue
+ red(109) = 0.000000000000000E+000
+ green(109) = 0.749019607843137
+ blue(109) = 1.00000000000000
+
+! AntiqueWhite2
+ red(110) = 0.933333333333333
+ green(110) = 0.874509803921569
+ blue(110) = 0.800000000000000
+
+! CornflowerBlue
+ red(111) = 0.392156862745098
+ green(111) = 0.584313725490196
+ blue(111) = 0.929411764705882
+
+! PeachPuff4
+ red(112) = 0.545098039215686
+ green(112) = 0.466666666666667
+ blue(112) = 0.396078431372549
+
+! SpringGreen
+ red(113) = 0.000000000000000E+000
+ green(113) = 1.00000000000000
+ blue(113) = 0.498039215686275
+
+! Honeydew
+ red(114) = 0.941176470588235
+ green(114) = 1.00000000000000
+ blue(114) = 0.941176470588235
+
+! Honeydew2
+ red(115) = 0.878431372549020
+ green(115) = 0.933333333333333
+ blue(115) = 0.878431372549020
+
+! LightSeaGreen
+ red(116) = 0.125490196078431
+ green(116) = 0.698039215686274
+ blue(116) = 0.666666666666667
+
+! NavyBlue
+ red(117) = 0.000000000000000E+000
+ green(117) = 0.000000000000000E+000
+ blue(117) = 0.501960784313725
+
+! Azure4
+ red(118) = 0.513725490196078
+ green(118) = 0.545098039215686
+ blue(118) = 0.545098039215686
+
+! MediumAquamarine
+ red(119) = 0.400000000000000
+ green(119) = 0.803921568627451
+ blue(119) = 0.666666666666667
+
+! SkyBlue3
+ red(120) = 0.423529411764706
+ green(120) = 0.650980392156863
+ blue(120) = 0.803921568627451
+
+! LavenderBlush2
+ red(121) = 0.933333333333333
+ green(121) = 0.878431372549020
+ blue(121) = 0.898039215686275
+
+! Bisque1
+ red(122) = 1.00000000000000
+ green(122) = 0.894117647058824
+ blue(122) = 0.768627450980392
+
+! DarkOrange
+ red(123) = 1.00000000000000
+ green(123) = 0.549019607843137
+ blue(123) = 0.000000000000000E+000
+
+! LightSteelBlue
+ red(124) = 0.690196078431373
+ green(124) = 0.768627450980392
+ blue(124) = 0.870588235294118
+
+! SteelBlue2
+ red(125) = 0.360784313725490
+ green(125) = 0.674509803921569
+ blue(125) = 0.933333333333333
+
+! LemonChiffon3
+ red(126) = 0.803921568627451
+ green(126) = 0.788235294117647
+ blue(126) = 0.647058823529412
+
+! DarkSlateBlue
+ red(127) = 0.282352941176471
+ green(127) = 0.239215686274510
+ blue(127) = 0.545098039215686
+
+! Seashell
+ red(128) = 1.00000000000000
+ green(128) = 0.960784313725490
+ blue(128) = 0.933333333333333
+
+! Firebrick
+ red(129) = 0.698039215686274
+ green(129) = 0.133333333333333
+ blue(129) = 0.133333333333333
+
+! LightGray
+ red(130) = 0.827450980392157
+ green(130) = 0.827450980392157
+ blue(130) = 0.827450980392157
+
+! Blue
+ red(131) = 0.000000000000000E+000
+ green(131) = 0.000000000000000E+000
+ blue(131) = 1.00000000000000
+
+! Bisque2
+ red(132) = 0.933333333333333
+ green(132) = 0.835294117647059
+ blue(132) = 0.717647058823529
+
+! WhiteSmoke
+ red(133) = 0.960784313725490
+ green(133) = 0.960784313725490
+ blue(133) = 0.960784313725490
+
+! SeaGreen
+ red(134) = 0.180392156862745
+ green(134) = 0.545098039215686
+ blue(134) = 0.341176470588235
+
+! Burlywood
+ red(135) = 0.870588235294118
+ green(135) = 0.721568627450980
+ blue(135) = 0.529411764705882
+
+! RoyalBlue2
+ red(136) = 0.262745098039216
+ green(136) = 0.431372549019608
+ blue(136) = 0.933333333333333
+
+! RoyalBlue1
+ red(137) = 0.282352941176471
+ green(137) = 0.462745098039216
+ blue(137) = 1.00000000000000
+
+! SteelBlue4
+ red(138) = 0.211764705882353
+ green(138) = 0.392156862745098
+ blue(138) = 0.545098039215686
+
+! AliceBlue
+ red(139) = 0.941176470588235
+ green(139) = 0.972549019607843
+ blue(139) = 1.00000000000000
+
+! LightSlateBlue
+ red(140) = 0.517647058823529
+ green(140) = 0.439215686274510
+ blue(140) = 1.00000000000000
+
+! MistyRose1
+ red(141) = 1.00000000000000
+ green(141) = 0.894117647058824
+ blue(141) = 0.882352941176471
+
+! SandyBrown
+ red(142) = 0.956862745098039
+ green(142) = 0.643137254901961
+ blue(142) = 0.376470588235294
+
+! DarkOliveGreen
+ red(143) = 0.333333333333333
+ green(143) = 0.419607843137255
+ blue(143) = 0.184313725490196
+
+! Yellow
+ red(144) = 1.00000000000000
+ green(144) = 1.00000000000000
+ blue(144) = 0.000000000000000E+000
+
+! SlateGray3
+ red(145) = 0.623529411764706
+ green(145) = 0.713725490196078
+ blue(145) = 0.803921568627451
+
+! HotPink
+ red(146) = 1.00000000000000
+ green(146) = 0.411764705882353
+ blue(146) = 0.705882352941177
+
+! Violet
+ red(147) = 0.933333333333333
+ green(147) = 0.509803921568627
+ blue(147) = 0.933333333333333
+
+! LightSkyBlue
+ red(148) = 0.529411764705882
+ green(148) = 0.807843137254902
+ blue(148) = 0.980392156862745
+
+! Cornsilk2
+ red(149) = 0.933333333333333
+ green(149) = 0.909803921568627
+ blue(149) = 0.803921568627451
+
+! MidnightBlue
+ red(150) = 9.803921568627451E-002
+ green(150) = 9.803921568627451E-002
+ blue(150) = 0.439215686274510
+
+! AntiqueWhite
+ red(151) = 0.980392156862745
+ green(151) = 0.921568627450980
+ blue(151) = 0.843137254901961
+
+! PaleGreen
+ red(152) = 0.596078431372549
+ green(152) = 0.984313725490196
+ blue(152) = 0.596078431372549
+
+! MedSpringGreen
+ red(153) = 0.000000000000000E+000
+ green(153) = 0.980392156862745
+ blue(153) = 0.603921568627451
+
+! DodgerBlue1
+ red(154) = 0.117647058823529
+ green(154) = 0.564705882352941
+ blue(154) = 1.00000000000000
+
+! Blue3
+ red(155) = 0.000000000000000E+000
+ green(155) = 0.000000000000000E+000
+ blue(155) = 0.803921568627451
+
+! Cyan
+ red(156) = 0.000000000000000E+000
+ green(156) = 1.00000000000000
+ blue(156) = 1.00000000000000
+
+! LemonChiffon
+ red(157) = 1.00000000000000
+ green(157) = 0.980392156862745
+ blue(157) = 0.803921568627451
+
+! mediumorchid
+ red(158) = 0.730000000000000
+ green(158) = 0.330000000000000
+ blue(158) = 0.830000000000000
+
+! Turquoise
+ red(159) = 0.250980392156863
+ green(159) = 0.878431372549020
+ blue(159) = 0.815686274509804
+
+! IndianRed
+ red(160) = 0.803921568627451
+ green(160) = 0.360784313725490
+ blue(160) = 0.360784313725490
+
+! DodgerBlue
+ red(161) = 0.117647058823529
+ green(161) = 0.564705882352941
+ blue(161) = 1.00000000000000
+
+! Seashell3
+ red(162) = 0.803921568627451
+ green(162) = 0.772549019607843
+ blue(162) = 0.749019607843137
+
+! BlueViolet
+ red(163) = 0.541176470588235
+ green(163) = 0.168627450980392
+ blue(163) = 0.886274509803922
+
+! DeepSkyBlue4
+ red(164) = 0.000000000000000E+000
+ green(164) = 0.407843137254902
+ blue(164) = 0.545098039215686
+
+! PaleVioletRed
+ red(165) = 0.858823529411765
+ green(165) = 0.439215686274510
+ blue(165) = 0.576470588235294
+
+! Azure2
+ red(166) = 0.878431372549020
+ green(166) = 0.933333333333333
+ blue(166) = 0.933333333333333
+
+! greenyellow
+ red(167) = 0.680000000000000
+ green(167) = 1.00000000000000
+ blue(167) = 0.180000000000000
+
+! LightGoldenrod
+ red(168) = 0.933333333333333
+ green(168) = 0.866666666666667
+ blue(168) = 0.509803921568627
+
+! MistyRose
+ red(169) = 1.00000000000000
+ green(169) = 0.894117647058824
+ blue(169) = 0.882352941176471
+
+! LightSkyBlue4
+ red(170) = 0.376470588235294
+ green(170) = 0.482352941176471
+ blue(170) = 0.545098039215686
+
+! OrangeRed
+ red(171) = 1.00000000000000
+ green(171) = 0.270588235294118
+ blue(171) = 0.000000000000000E+000
+
+! DimGrey
+ red(172) = 0.411764705882353
+ green(172) = 0.411764705882353
+ blue(172) = 0.411764705882353
+
+! MediumVioletRed
+ red(173) = 0.780392156862745
+ green(173) = 8.235294117647059E-002
+ blue(173) = 0.521568627450980
+
+! DarkSlateGray
+ red(174) = 0.184313725490196
+ green(174) = 0.309803921568627
+ blue(174) = 0.309803921568627
+
+! yellow
+ red(175) = 1.00000000000000
+ green(175) = 1.00000000000000
+ blue(175) = 0.000000000000000E+000
+
+! Plum
+ red(176) = 0.866666666666667
+ green(176) = 0.627450980392157
+ blue(176) = 0.866666666666667
+
+! DarkTurquoise
+ red(177) = 0.000000000000000E+000
+ green(177) = 0.807843137254902
+ blue(177) = 0.819607843137255
+
+! DodgerBlue4
+ red(178) = 6.274509803921569E-002
+ green(178) = 0.305882352941176
+ blue(178) = 0.545098039215686
+
+! Cornsilk
+ red(179) = 1.00000000000000
+ green(179) = 0.972549019607843
+ blue(179) = 0.862745098039216
+
+! SkyBlue1
+ red(180) = 0.529411764705882
+ green(180) = 0.807843137254902
+ blue(180) = 1.00000000000000
+
+! Seashell1
+ red(181) = 1.00000000000000
+ green(181) = 0.960784313725490
+ blue(181) = 0.933333333333333
+
+! lavender
+ red(182) = 0.901960784313726
+ green(182) = 0.901960784313726
+ blue(182) = 0.980392156862745
+
+! Snow4
+ red(183) = 0.545098039215686
+ green(183) = 0.537254901960784
+ blue(183) = 0.537254901960784
+
+! Peru
+ red(184) = 0.803921568627451
+ green(184) = 0.521568627450980
+ blue(184) = 0.247058823529412
+
+! PeachPuff
+ red(185) = 1.00000000000000
+ green(185) = 0.854901960784314
+ blue(185) = 0.725490196078431
+
+! Green
+ red(186) = 0.000000000000000E+000
+ green(186) = 1.00000000000000
+ blue(186) = 0.000000000000000E+000
+
+! Blue1
+ red(187) = 0.000000000000000E+000
+ green(187) = 0.000000000000000E+000
+ blue(187) = 1.00000000000000
+
+! Seashell4
+ red(188) = 0.545098039215686
+ green(188) = 0.525490196078431
+ blue(188) = 0.509803921568627
+
+! dodgerblue
+ red(189) = 0.120000000000000
+ green(189) = 0.560000000000000
+ blue(189) = 1.00000000000000
+
+! MistyRose2
+ red(190) = 0.933333333333333
+ green(190) = 0.835294117647059
+ blue(190) = 0.823529411764706
+
+! Tomato
+ red(191) = 1.00000000000000
+ green(191) = 0.388235294117647
+ blue(191) = 0.278431372549020
+
+! Wheat
+ red(192) = 0.960784313725490
+ green(192) = 0.870588235294118
+ blue(192) = 0.701960784313725
+
+! LightBlue
+ red(193) = 0.678431372549020
+ green(193) = 0.847058823529412
+ blue(193) = 0.901960784313726
+
+! Chocolate
+ red(194) = 0.823529411764706
+ green(194) = 0.411764705882353
+ blue(194) = 0.117647058823529
+
+! Blue4
+ red(195) = 0.000000000000000E+000
+ green(195) = 0.000000000000000E+000
+ blue(195) = 0.545098039215686
+
+! LavenderBlush1
+ red(196) = 1.00000000000000
+ green(196) = 0.941176470588235
+ blue(196) = 0.960784313725490
+
+! Magenta
+ red(197) = 1.00000000000000
+ green(197) = 0.000000000000000E+000
+ blue(197) = 1.00000000000000
+
+! darkturquoise
+ red(198) = 0.000000000000000E+000
+ green(198) = 0.810000000000000
+ blue(198) = 0.820000000000000
+
+! blueviolet
+ red(199) = 0.540000000000000
+ green(199) = 0.170000000000000
+ blue(199) = 0.890000000000000
+
+! MintCream
+ red(200) = 0.960784313725490
+ green(200) = 1.00000000000000
+ blue(200) = 0.980392156862745
+
+! PaleGoldenrod
+ red(201) = 0.933333333333333
+ green(201) = 0.909803921568627
+ blue(201) = 0.666666666666667
+
+! MediumPurple
+ red(202) = 0.576470588235294
+ green(202) = 0.439215686274510
+ blue(202) = 0.858823529411765
+
+! PapayaWhip
+ red(203) = 1.00000000000000
+ green(203) = 0.937254901960784
+ blue(203) = 0.835294117647059
+
+! LavenderBlush4
+ red(204) = 0.545098039215686
+ green(204) = 0.513725490196078
+ blue(204) = 0.525490196078431
+
+! Cornsilk4
+ red(205) = 0.545098039215686
+ green(205) = 0.533333333333333
+ blue(205) = 0.470588235294118
+
+! LtGoldenrodYello
+ red(206) = 0.980392156862745
+ green(206) = 0.980392156862745
+ blue(206) = 0.823529411764706
+
+! limegreen
+ red(207) = 0.200000000000000
+ green(207) = 0.800000000000000
+ blue(207) = 0.200000000000000
+
+! LemonChiffon1
+ red(208) = 1.00000000000000
+ green(208) = 0.980392156862745
+ blue(208) = 0.803921568627451
+
+! DarkOrchid
+ red(209) = 0.600000000000000
+ green(209) = 0.196078431372549
+ blue(209) = 0.800000000000000
+
+! SlateBlue1
+ red(210) = 0.513725490196078
+ green(210) = 0.435294117647059
+ blue(210) = 1.00000000000000
+
+! chartreuse
+ red(211) = 0.500000000000000
+ green(211) = 1.00000000000000
+ blue(211) = 0.000000000000000E+000
+
+! PaleTurquoise
+ red(212) = 0.686274509803922
+ green(212) = 0.933333333333333
+ blue(212) = 0.933333333333333
+
+! NavajoWhite1
+ red(213) = 1.00000000000000
+ green(213) = 0.870588235294118
+ blue(213) = 0.678431372549020
+
+! LightSkyBlue2
+ red(214) = 0.643137254901961
+ green(214) = 0.827450980392157
+ blue(214) = 0.933333333333333
+
+! VioletRed
+ red(215) = 0.815686274509804
+ green(215) = 0.125490196078431
+ blue(215) = 0.564705882352941
+
+! mocassin
+ red(216) = 1.00000000000000
+ green(216) = 0.890000000000000
+ blue(216) = 0.710000000000000
+
+! OldLace
+ red(217) = 0.992156862745098
+ green(217) = 0.960784313725490
+ blue(217) = 0.901960784313726
+
+! deeppink
+ red(218) = 1.00000000000000
+ green(218) = 8.000000000000000E-002
+ blue(218) = 0.580000000000000
+
+! Honeydew3
+ red(219) = 0.756862745098039
+ green(219) = 0.803921568627451
+ blue(219) = 0.756862745098039
+
+! Gainsboro
+ red(220) = 0.862745098039216
+ green(220) = 0.862745098039216
+ blue(220) = 0.862745098039216
+
+! DarkSalmon
+ red(221) = 0.913725490196078
+ green(221) = 0.588235294117647
+ blue(221) = 0.478431372549020
+
+! AntiqueWhite1
+ red(222) = 1.00000000000000
+ green(222) = 0.937254901960784
+ blue(222) = 0.858823529411765
+
+! LightCyan
+ red(223) = 0.878431372549020
+ green(223) = 1.00000000000000
+ blue(223) = 1.00000000000000
+
+! ForestGreen
+ red(224) = 0.133333333333333
+ green(224) = 0.545098039215686
+ blue(224) = 0.133333333333333
+
+! Orchid
+ red(225) = 0.854901960784314
+ green(225) = 0.439215686274510
+ blue(225) = 0.839215686274510
+
+! PeachPuff2
+ red(226) = 0.933333333333333
+ green(226) = 0.796078431372549
+ blue(226) = 0.678431372549020
+
+! LightPink
+ red(227) = 1.00000000000000
+ green(227) = 0.713725490196078
+ blue(227) = 0.756862745098039
+
+! Sienna
+ red(228) = 0.627450980392157
+ green(228) = 0.321568627450980
+ blue(228) = 0.176470588235294
+
+! darkorchid
+ red(229) = 0.600000000000000
+ green(229) = 0.200000000000000
+ blue(229) = 0.800000000000000
+
+! MediumSlateBlue
+ red(230) = 0.482352941176471
+ green(230) = 0.407843137254902
+ blue(230) = 0.933333333333333
+
+! CadetBlue
+ red(231) = 0.372549019607843
+ green(231) = 0.619607843137255
+ blue(231) = 0.627450980392157
+
+! LawnGreen
+ red(232) = 0.486274509803922
+ green(232) = 0.988235294117647
+ blue(232) = 0.000000000000000E+000
+
+! Chartreuse
+ red(233) = 0.498039215686275
+ green(233) = 1.00000000000000
+ blue(233) = 0.000000000000000E+000
+
+! Brown
+ red(234) = 0.647058823529412
+ green(234) = 0.164705882352941
+ blue(234) = 0.164705882352941
+
+! Azure
+ red(235) = 0.941176470588235
+ green(235) = 1.00000000000000
+ blue(235) = 1.00000000000000
+
+! Bisque
+ red(236) = 1.00000000000000
+ green(236) = 0.894117647058824
+ blue(236) = 0.768627450980392
+
+ end subroutine checkgrid_setup_colorp
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_Bielak_conditions.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_Bielak_conditions.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_Bielak_conditions.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_Bielak_conditions.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,237 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! compute analytical initial plane wave for Bielak's conditions
+
+subroutine compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: iglob,npoin,it
+
+ double precision, intent(in) :: deltat
+
+ double precision, intent(out) :: dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert
+
+ double precision, dimension(NDIM,npoin), intent(in) :: coord
+
+ double precision :: time_veloc,time_traction,t,x,z
+
+ double precision, external :: ricker_Bielak_veloc
+
+ double precision x0_source, z0_source, angleforce, angleforce_refl
+ double precision c_inc, c_refl, time_offset, f0
+ double precision, dimension(NDIM) :: A_plane, B_plane, C_plane
+
+
+! get the coordinates of the mesh point
+ x = coord(1,iglob) - x0_source
+ z = z0_source - coord(2,iglob)
+
+! times for velocity and traction are staggered i.e. separated by deltat/2.d0
+ time_veloc = (it-1)*deltat + deltat/2.d0 + time_offset
+ time_traction = time_veloc + deltat/2.d0
+
+ t = time_traction
+
+!!$!SV30
+!!$
+!!$!analytical expression of the displacement for a SV 30 degrees and 0.3333 poisson ratio
+!!$! Ux = sqrt(3.d0)/2.d0 * rickertest(t - x/2.d0 + (9 - z) * sqrt(3.d0)/2.d0) &
+!!$! + sqrt(3.d0)/2.d0 * rickertest(t - x/2.d0 - (9 - z) * sqrt(3.d0)/2.d0) &
+!!$! + sqrt(3.d0) * rickertest(t - x/2.d0)
+!!$! Uz = - HALF * rickertest(t - x/2.d0 + (9 - z) * sqrt(3.d0)/2.d0) &
+!!$! + HALF * rickertest(t - x/2.d0 - (9 - z) * sqrt(3.d0)/2.d0)
+!!$
+!!$
+!!$! derivatives of analytical expression of horizontal and vertical displacements,
+!!$! computed using the "Mathematica" script in UTILS/deriv_ricker_spatial.m
+!!$ dxUx = (sqrt(3.d0)*a*((-8*t + 4*x)*exp(-a*(t - x/2.d0)**2) + &
+!!$ ((2*t - x)*(-2 + a*(-2*t + x)**2))*exp(-a*(t - x/2.d0)**2) + &
+!!$ (2*(-2*t + x - sqrt(3.d0)*(-9 + z)))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ ((1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (-2*t + x - sqrt(3.d0)*(-9 + z)))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (2*(-2*t + x + sqrt(3.d0)*(-9 + z)))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (-2*t + x + sqrt(3.d0)*(-9 + z)))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/4.d0
+!!$
+!!$ dzUx = (3*a*(((t + (-x + sqrt(3.d0)*(-9 + z))/2.d0)* &
+!!$ (1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) - &
+!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (t - x/2.d0 - (sqrt(3.d0)*(-9 + z))/2.d0))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (2*t - x + sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (-2*t + x + sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
+!!$
+!!$ dxUz = (a*((2*t - x - sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (-2*t + x - sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ ((1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (-2*t + x - sqrt(3.d0)*(-9 + z)))/2.d0*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) - &
+!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (-2*t + x + sqrt(3.d0)*(-9 + z)))/2.d0*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
+!!$
+!!$ dzUz = (sqrt(3.d0)*a*(((t + (-x + sqrt(3.d0)*(-9 + z))/2.d0)* &
+!!$ (1 - (a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/2.d0))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (2*t - x - sqrt(3.d0)*(-9 + z))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ ((1 - (a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/2.d0)* &
+!!$ (t - x/2.d0 - (sqrt(3.d0)*(-9 + z))/2.d0))*exp(-(a*(-2*t + x + sqrt(3.d0)*(-9 + z))**2)/4.d0) + &
+!!$ (2*t - x + sqrt(3.d0)*(-9 + z))*exp(-(a*(2*t - x + sqrt(3.d0)*(-9 + z))**2)/4.d0)))/2.d0
+
+! to ompute the derivative of the displacement, we take the velocity ricker expression and we multiply by
+! the derivative of the interior argument of ricker_Bielak_veloc
+
+ dxUx = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
+ + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
+ + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
+ * (-sin(angleforce_refl)/c_refl)
+
+ dzUx = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-cos(angleforce)/c_inc)&
+ + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (cos(angleforce)/c_inc)&
+ + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
+ * (cos(angleforce_refl)/c_refl)
+
+ dxUz = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
+ + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (-sin(angleforce)/c_inc)&
+ + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
+ * (-sin(angleforce_refl)/c_refl)
+
+ dzUz = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) * (-cos(angleforce)/c_inc)&
+ + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) * (cos(angleforce)/c_inc)&
+ + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)&
+ * (cos(angleforce_refl)/c_refl)
+
+ t = time_veloc
+
+!!$!SV30
+!!$! analytical expression of the two components of the velocity vector
+!!$ veloc_horiz = (sqrt(3.d0)/2.d0) * ricker_Bielak_veloc(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + (sqrt(3.d0)/2.d0) * ricker_Bielak_veloc(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + sqrt(3.d0) * ricker_Bielak_veloc(t - x/2.d0)
+!!$ veloc_vert = - HALF * ricker_Bielak_veloc(t - x/2.d0 + (9 - z) * (sqrt(3.d0)/2.d0)) &
+!!$ + HALF * ricker_Bielak_veloc(t - x/2.d0 - (9 - z) * (sqrt(3.d0)/2.d0))
+
+ veloc_horiz = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
+ + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
+ + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ veloc_vert = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
+ + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
+ + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+
+end subroutine compute_Bielak_conditions
+
+! ********
+
+! compute time variation of the source for analytical initial plane wave
+double precision function ricker_Bielak_integrale_displ(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: t,f0,a
+
+ a = pi*pi*f0*f0
+
+! Ricker
+ ricker_Bielak_integrale_displ = t*exp(-a*t**2)
+
+end function ricker_Bielak_integrale_displ
+
+! ********
+
+! compute time variation of the source for analytical initial plane wave
+double precision function ricker_Bielak_displ(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: t,f0,a
+
+ a = pi*pi*f0*f0
+
+! Ricker
+ ricker_Bielak_displ = (1 - 2*a*t**2)*exp(-a*t**2)
+
+end function ricker_Bielak_displ
+
+! *******
+
+! compute time variation of the source for analytical initial plane wave
+double precision function ricker_Bielak_veloc(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: t,f0,a
+
+ a = pi*pi*f0*f0
+
+! first time derivative of a Ricker
+ ricker_Bielak_veloc = - 2*a*t*(3 - 2*a*t**2)*exp(-a*t**2)
+
+end function ricker_Bielak_veloc
+
+! *******
+
+! compute time variation of the source for analytical initial plane wave
+double precision function ricker_Bielak_accel(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: t,f0,a
+
+ a = pi*pi*f0*f0
+
+! second time derivative of a Ricker
+ ricker_Bielak_accel = - 2*a*(3 - 12*a*t**2 + 4*a**2*t**4)* exp(-a*t**2)
+
+end function ricker_Bielak_accel
+
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_arrays_source.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_arrays_source.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_arrays_source.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,190 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
+ Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec_selected_source
+ integer nspec
+
+ double precision xi_source,gamma_source
+ double precision Mxx,Mzz,Mxz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
+
+ double precision xixd,xizd,gammaxd,gammazd
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+! source arrays
+ double precision, dimension(NGLLX,NGLLZ) :: G11,G13,G31,G33
+ double precision, dimension(NGLLX) :: hxis,hpxis
+ double precision, dimension(NGLLZ) :: hgammas,hpgammas
+
+ integer k,m
+ integer ir,iv
+
+! calculate G_ij for general source location
+! the source does not necessarily correspond to a Gauss-Lobatto point
+ do m=1,NGLLZ
+ do k=1,NGLLX
+
+ xixd = xix(k,m,ispec_selected_source)
+ xizd = xiz(k,m,ispec_selected_source)
+ gammaxd = gammax(k,m,ispec_selected_source)
+ gammazd = gammaz(k,m,ispec_selected_source)
+
+ G11(k,m) = Mxx*xixd+Mxz*xizd
+ G13(k,m) = Mxx*gammaxd+Mxz*gammazd
+ G31(k,m) = Mxz*xixd+Mzz*xizd
+ G33(k,m) = Mxz*gammaxd+Mzz*gammazd
+
+!!!! G21(k,m) = Mxy*xixd+Myz*xizd
+!!!! G23(k,m) = Mxy*gammaxd+Myz*gammazd
+
+ enddo
+ enddo
+
+! compute Lagrange polynomials at the source location
+ call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
+ call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
+
+! calculate source array
+ do m=1,NGLLZ
+ do k=1,NGLLX
+
+ sourcearray(:,k,m) = ZERO
+
+ do iv=1,NGLLZ
+ do ir=1,NGLLX
+
+ sourcearray(1,k,m) = sourcearray(1,k,m) + hxis(ir)*hgammas(iv) &
+ *(G11(ir,iv)*hpxis(k)*hgammas(m) &
+ +G13(ir,iv)*hxis(k)*hpgammas(m))
+
+! sourcearray(2,k,m) = sourcearray(2,k,m) + hxis(ir)*hgammas(iv) &
+! *(G21(ir,iv)*hpxis(k)*hgammas(m) &
+! +G23(ir,iv)*hxis(k)*hpgammas(m))
+
+ sourcearray(2,k,m) = sourcearray(2,k,m) + hxis(ir)*hgammas(iv) &
+ *(G31(ir,iv)*hpxis(k)*hgammas(m) &
+ +G33(ir,iv)*hxis(k)*hpgammas(m))
+
+ enddo
+ enddo
+
+ enddo
+ enddo
+
+ end subroutine compute_arrays_source
+
+! ------------------------------------------------------------------------------------------------------
+
+
+ subroutine compute_arrays_adj_source(adj_source_file,xi_receiver,gamma_receiver,adj_sourcearray, &
+ xigll,zigll,NSTEP)
+
+ implicit none
+
+ include 'constants.h'
+
+! input
+ integer NSTEP
+
+ double precision xi_receiver, gamma_receiver
+
+ character(len=*) adj_source_file
+
+! output
+ real(kind=CUSTOM_REAL), dimension(NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearray
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hgammar(NGLLZ), hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL) :: adj_src_s(NSTEP,3)
+
+ integer icomp, itime, i, k, ios
+ double precision :: junk
+ character(len=3) :: comp(3)
+ character(len=150) :: filename
+
+ call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
+
+ adj_sourcearray(:,:,:,:) = 0.
+
+ comp = (/"BHX","BHY","BHZ"/)
+
+ do icomp = 1,3
+
+ filename = 'OUTPUT_FILES/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit = IIN, file = trim(filename), iostat = ios)
+ if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')
+
+ do itime = 1, NSTEP
+ read(IIN,*) junk, adj_src_s(itime,icomp)
+ enddo
+ close(IIN)
+
+ enddo
+
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ adj_sourcearray(:,:,i,k) = hxir(i) * hgammar(k) * adj_src_s(:,:)
+ enddo
+ enddo
+
+
+end subroutine compute_arrays_adj_source
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_curl_one_element.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_curl_one_element.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_curl_one_element.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_curl_one_element.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,164 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_curl_one_element(curl_element,displ_elastic, &
+ displs_poroelastic,elastic,poroelastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
+ nspec,npoin_elastic,npoin_poroelastic,ispec)
+
+ ! compute curl in (poro)elastic elements (for rotational study)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,ispec
+
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ ! curl in this element
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
+
+ logical, dimension(nspec) :: elastic,poroelastic
+
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic
+
+ ! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ ! local variables
+ integer :: i,j,k
+
+ ! jacobian
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
+
+ ! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ real(kind=CUSTOM_REAL) :: duz_dxl,dux_dzl
+
+ if(elastic(ispec)) then
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+
+ ! store pressure
+ curl_element(i,j) = - 0.5d0 * (dux_dzl - duz_dxl)
+
+ enddo
+ enddo
+
+ elseif(poroelastic(ispec)) then
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+
+ ! store pressure
+ curl_element(i,j) = - 0.5d0 * (dux_dzl - duz_dxl)
+
+ enddo
+ enddo
+
+ else
+
+ call exit_MPI('no curl in acoustic')
+
+ endif ! end of test if acoustic or elastic element
+
+end subroutine compute_curl_one_element
+
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_energy.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_energy.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_energy.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_energy.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,403 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_energy(displ_elastic,veloc_elastic, &
+ displs_poroelastic,velocs_poroelastic, &
+ displw_poroelastic,velocw_poroelastic, &
+ xix,xiz,gammax,gammaz,jacobian,ibool, &
+ elastic,poroelastic,hprime_xx,hprime_zz, &
+ nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ assign_external_model,it,deltat,t0,kmato,poroelastcoef,density, &
+ porosity,tortuosity, &
+ vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext, &
+ anisotropic,anisotropy,wxgll,wzgll,numat, &
+ pressure_element,vector_field_element,e1,e11, &
+ potential_dot_acoustic,potential_dot_dot_acoustic, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS,p_sv)
+
+! compute kinetic and potential energy in the solid (acoustic elements are excluded)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,numat
+
+! vector field in an element
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
+
+! pressure in an element
+ integer :: N_SLS
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
+
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: &
+ potential_dot_acoustic,potential_dot_dot_acoustic
+
+ logical :: TURN_ATTENUATION_ON,p_sv
+
+ integer :: it
+ double precision :: t0,deltat
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ logical, dimension(nspec) :: elastic,poroelastic,anisotropic
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ integer, dimension(nspec) :: kmato
+ logical :: assign_external_model
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(6,numat) :: anisotropy
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext, &
+ c33ext,c35ext,c55ext
+
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic,veloc_elastic
+
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,velocs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displw_poroelastic,velocw_poroelastic
+
+! Gauss-Lobatto-Legendre points and weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local variables
+ integer :: i,j,k,ispec
+
+! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
+
+! jacobian
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+ real(kind=CUSTOM_REAL) :: kinetic_energy,potential_energy
+ real(kind=CUSTOM_REAL) :: cpl,csl,rhol,mul_relaxed,lambdal_relaxed, &
+ lambdalplus2mul_relaxed,kappal
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
+ real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
+
+ kinetic_energy = ZERO
+ potential_energy = ZERO
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ !---
+ !--- elastic spectral element
+ !---
+ if(elastic(ispec)) then
+
+ ! checks wave type
+ if( .not. p_sv ) then
+ call exit_MPI('output energy for SH waves not implemented yet')
+ endif
+
+ ! get relaxed elastic parameters of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
+
+ ! double loop over GLL points
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ !--- if external medium, get elastic parameters of current grid point
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ mul_relaxed = rhol*csl*csl
+ lambdal_relaxed = rhol*cpl*cpl - TWO*mul_relaxed
+ lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
+ endif
+
+ ! derivative along x and along z
+ dux_dxi = 0._CUSTOM_REAL
+ duz_dxi = 0._CUSTOM_REAL
+
+ dux_dgamma = 0._CUSTOM_REAL
+ duz_dgamma = 0._CUSTOM_REAL
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+ jacobianl = jacobian(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ ! compute kinetic energy
+ kinetic_energy = kinetic_energy &
+ + rhol*(veloc_elastic(1,ibool(i,j,ispec))**2 &
+ + veloc_elastic(3,ibool(i,j,ispec))**2) *wxgll(i)*wzgll(j)*jacobianl / TWO
+
+ ! compute potential energy
+ potential_energy = potential_energy &
+ + (lambdalplus2mul_relaxed*dux_dxl**2 &
+ + lambdalplus2mul_relaxed*duz_dzl**2 &
+ + two*lambdal_relaxed*dux_dxl*duz_dzl &
+ + mul_relaxed*(dux_dzl + duz_dxl)**2)*wxgll(i)*wzgll(j)*jacobianl / TWO
+
+ enddo
+ enddo
+
+ !---
+ !--- poroelastic spectral element
+ !---
+ elseif(poroelastic(ispec)) then
+
+ ! get relaxed elastic parameters of current spectral element
+ !for now replaced by solid, fluid, and frame parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ !solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+ !fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ !frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+ !Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
+ + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ !The RHS has the form : div T -phi/c div T_f + phi/ceta_fk^-1.partial t w
+ !where T = G:grad u_s + C div w I
+ !and T_f = C div u_s I + M div w I
+ !we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
+ mul_G = mul_fr
+ lambdal_G = H_biot - TWO*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+ ! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+ jacobianl = jacobian(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ ! compute potential energy
+ potential_energy = potential_energy &
+ + ( lambdalplus2mul_G*dux_dxl**2 &
+ + lambdalplus2mul_G*duz_dzl**2 &
+ + two*lambdal_G*dux_dxl*duz_dzl + mul_G*(dux_dzl + duz_dxl)**2 &
+ + two*C_biot*dwx_dxl*dux_dxl + two*C_biot*dwz_dzl*duz_dzl &
+ + two*C_biot*(dwx_dxl*duz_dzl + dwz_dzl*dux_dxl) &
+ + M_biot*dwx_dxl**2 + M_biot*dwz_dzl**2 &
+ + two*M_biot*dwx_dxl*dwz_dzl )*wxgll(i)*wzgll(j)*jacobianl / TWO
+
+ ! compute kinetic energy
+ if(phil > 0.0d0) then
+ kinetic_energy = kinetic_energy &
+ + ( rhol_bar*(velocs_poroelastic(1,ibool(i,j,ispec))**2 &
+ + velocs_poroelastic(2,ibool(i,j,ispec))**2) &
+ + rhol_f*tortl/phil*(velocw_poroelastic(1,ibool(i,j,ispec))**2 &
+ + velocw_poroelastic(2,ibool(i,j,ispec))**2) &
+ + rhol_f*(velocs_poroelastic(1,ibool(i,j,ispec))*velocw_poroelastic(1,ibool(i,j,ispec)) &
+ + velocs_poroelastic(2,ibool(i,j,ispec))*velocw_poroelastic(2,ibool(i,j,ispec))) &
+ )*wxgll(i)*wzgll(j)*jacobianl / TWO
+ else
+ kinetic_energy = kinetic_energy &
+ + rhol_s*(velocs_poroelastic(1,ibool(i,j,ispec))**2 &
+ + velocs_poroelastic(2,ibool(i,j,ispec))**2)*wxgll(i)*wzgll(j)*jacobianl / TWO
+ endif
+ enddo
+ enddo
+
+ !---
+ !--- acoustic spectral element
+ !---
+ else
+
+ ! for the definition of potential energy in an acoustic fluid, see for instance
+ ! equation (23) of M. Maess et al., Journal of Sound and Vibration 296 (2006) 264-276
+
+ ! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
+ ! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
+ ! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
+ ! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+ ! Displacement is then: u = grad(Chi) / rho
+ ! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
+ ! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+
+ ! compute pressure in this element
+ call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic, &
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
+ npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
+
+ ! compute velocity vector field in this element
+ call compute_vector_one_element(vector_field_element,potential_dot_acoustic, &
+ veloc_elastic,velocs_poroelastic, &
+ elastic,poroelastic,xix,xiz,gammax,gammaz, &
+ ibool,hprime_xx,hprime_zz, &
+ nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ ispec,numat,kmato,density,rhoext,assign_external_model)
+
+ ! get density of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
+
+ ! double loop over GLL points
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ !--- if external medium, get density of current grid point
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ jacobianl = jacobian(i,j,ispec)
+
+ ! compute kinetic energy
+ kinetic_energy = kinetic_energy &
+ + rhol*(vector_field_element(1,i,j)**2 &
+ + vector_field_element(2,i,j)**2) *wxgll(i)*wzgll(j)*jacobianl / TWO
+
+ ! compute potential energy
+ potential_energy = potential_energy &
+ + (pressure_element(i,j)**2)*wxgll(i)*wzgll(j)*jacobianl / (TWO * rhol * cpl**2)
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+ ! save kinetic, potential and total energy for this time step in external file
+ write(IOUT_ENERGY,*) real(dble(it-1)*deltat - t0,4),real(kinetic_energy,4), &
+ real(potential_energy,4),real(kinetic_energy + potential_energy,4)
+
+ end subroutine compute_energy
+
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_forces_acoustic.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_forces_acoustic.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_forces_acoustic.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,762 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_forces_acoustic(npoin,nspec,nelemabs,numat,it,NSTEP, &
+ anyabs,assign_external_model,ibool,kmato,numabs, &
+ elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,b_potential_dot_dot_acoustic,b_potential_acoustic, &
+ density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,rhoext,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll, &
+ ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
+ jbegin_left,jend_left,jbegin_right,jend_right,SIMULATION_TYPE,SAVE_FORWARD,b_absorb_acoustic_left,&
+ b_absorb_acoustic_right,b_absorb_acoustic_bottom,&
+ b_absorb_acoustic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top)
+
+! compute forces for the acoustic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP,SIMULATION_TYPE
+
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nelemabs) :: ib_left
+ integer, dimension(nelemabs) :: ib_right
+ integer, dimension(nelemabs) :: ib_bottom
+ integer, dimension(nelemabs) :: ib_top
+
+ logical :: anyabs,assign_external_model
+ logical :: SAVE_FORWARD
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+ integer, dimension(nelemabs) :: numabs,ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
+ jbegin_left,jend_left,jbegin_right,jend_right
+
+ logical, dimension(nspec) :: elastic,poroelastic
+ logical, dimension(4,nelemabs) :: codeabs
+
+ real(kind=CUSTOM_REAL), dimension(npoin) :: &
+ potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin) :: &
+ b_potential_dot_dot_acoustic,b_potential_acoustic
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
+
+ double precision, dimension(NGLLZ,nspec_xmin,NSTEP) :: b_absorb_acoustic_left
+ double precision, dimension(NGLLZ,nspec_xmax,NSTEP) :: b_absorb_acoustic_right
+ double precision, dimension(NGLLX,nspec_zmax,NSTEP) :: b_absorb_acoustic_top
+ double precision, dimension(NGLLX,nspec_zmin,NSTEP) :: b_absorb_acoustic_bottom
+
+! derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+! Gauss-Lobatto-Legendre weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+!---
+!--- local variables
+!---
+
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend
+
+! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,dux_dxl,dux_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_dux_dxl,b_dux_dzl
+ real(kind=CUSTOM_REAL) :: weight,xxi,zxi,xgamma,zgamma,jacobian1D
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2
+
+! Jacobian matrix and determinant
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the elastic medium
+ real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,kappal,cpl,rhol
+
+ integer :: ifirstelem,ilastelem
+
+ ifirstelem = 1
+ ilastelem = nspec
+
+! loop over spectral elements
+ do ispec = ifirstelem,ilastelem
+
+!---
+!--- acoustic spectral element
+!---
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+
+ rhol = density(1,kmato(ispec))
+
+! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x and along z
+ dux_dxi = ZERO
+ dux_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = ZERO
+ b_dux_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = b_dux_dxi + b_potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of potential
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+ endif
+
+ jacobianl = jacobian(i,j,ispec)
+
+! if external density model
+ if(assign_external_model) rhol = rhoext(i,j,ispec)
+
+! for acoustic medium
+! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl) / rhol
+ tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl) / rhol
+
+ if(SIMULATION_TYPE == 2) then
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(xixl*b_dux_dxl + xizl*b_dux_dzl) /rhol
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*b_dux_dxl + gammazl*b_dux_dzl) /rhol
+ endif
+
+ enddo
+ enddo
+
+!
+! second double-loop over GLL to compute all the terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+! along x direction and z direction
+! and assemble the contributions
+ do k = 1,NGLLX
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - &
+ (tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
+
+ if(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ (b_tempx1(k,j)*hprimewgll_xx(k,i) + b_tempx2(i,k)*hprimewgll_zz(k,j))
+ endif
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if acoustic element
+
+ enddo ! end of loop over all spectral elements
+
+!
+!--- absorbing boundaries
+!
+ if(anyabs) then
+
+ do ispecabs=1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+! get elastic parameters of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ rhol = density(1,kmato(ispec))
+
+ cpl = sqrt(kappal/rhol)
+
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
+ i = 1
+
+ jbegin = jbegin_left(ispecabs)
+ jend = jend_left(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+
+ weight = jacobian1D * wzgll(j)
+
+! Sommerfeld condition if acoustic
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob)*weight/cpl/rhol
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ b_absorb_acoustic_left(j,ib_left(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = &
+ b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_left(j,ib_left(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+
+ i = NGLLX
+
+ jbegin = jbegin_right(ispecabs)
+ jend = jend_right(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+
+ weight = jacobian1D * wzgll(j)
+
+! Sommerfeld condition if acoustic
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ b_absorb_acoustic_right(j,ib_right(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = &
+ b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_right(j,ib_right(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+
+ j = 1
+
+ ibegin = ibegin_bottom(ispecabs)
+ iend = iend_bottom(ispecabs)
+
+! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+
+ weight = jacobian1D * wxgll(i)
+
+! Sommerfeld condition if acoustic
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = &
+ b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+
+ j = NGLLZ
+
+ ibegin = ibegin_top(ispecabs)
+ iend = iend_top(ispecabs)
+
+! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+
+ weight = jacobian1D * wxgll(i)
+
+! Sommerfeld condition if acoustic
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ b_absorb_acoustic_top(i,ib_top(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = &
+ b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_top(i,ib_top(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ enddo
+
+ endif ! end of top absorbing boundary
+
+ enddo
+
+ endif ! end of absorbing boundaries
+
+ end subroutine compute_forces_acoustic
+
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine compute_forces_acoustic_2(npoin,nspec,nelemabs,numat,it,NSTEP, &
+ anyabs,assign_external_model,ibool,kmato,numabs, &
+ elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic, &
+ density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,rhoext,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll, &
+ ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
+ jbegin_left,jend_left,jbegin_right,jend_right, &
+ SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
+ b_absorb_acoustic_left,b_absorb_acoustic_right, &
+ b_absorb_acoustic_bottom,b_absorb_acoustic_top)
+
+! compute forces for the acoustic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP,SIMULATION_TYPE
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+ integer, dimension(nelemabs) :: numabs,ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
+ jbegin_left,jend_left,jbegin_right,jend_right
+
+ logical, dimension(nspec) :: elastic,poroelastic
+ logical, dimension(4,nelemabs) :: codeabs
+
+ real(kind=CUSTOM_REAL), dimension(npoin) :: &
+ potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
+
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
+
+ logical :: anyabs,assign_external_model
+ logical :: SAVE_FORWARD
+
+! derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+! Gauss-Lobatto-Legendre weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nelemabs) :: ib_left
+ integer, dimension(nelemabs) :: ib_right
+ integer, dimension(nelemabs) :: ib_bottom
+ integer, dimension(nelemabs) :: ib_top
+
+ double precision, dimension(NGLLZ,nspec_xmin,NSTEP) :: b_absorb_acoustic_left
+ double precision, dimension(NGLLZ,nspec_xmax,NSTEP) :: b_absorb_acoustic_right
+ double precision, dimension(NGLLX,nspec_zmax,NSTEP) :: b_absorb_acoustic_top
+ double precision, dimension(NGLLX,nspec_zmin,NSTEP) :: b_absorb_acoustic_bottom
+
+!---
+!--- local variables
+!---
+
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend
+
+! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,dux_dxl,dux_dzl
+ real(kind=CUSTOM_REAL) :: weight,xxi,zxi,xgamma,zgamma,jacobian1D
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2
+
+! Jacobian matrix and determinant
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the elastic medium
+ real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,kappal,cpl,rhol
+
+ integer :: ifirstelem,ilastelem
+
+ ifirstelem = 1
+ ilastelem = nspec
+
+! loop over spectral elements
+ do ispec = ifirstelem,ilastelem
+
+!---
+!--- acoustic spectral element
+!---
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+
+ rhol = density(1,kmato(ispec))
+
+ ! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ dux_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of potential
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+ jacobianl = jacobian(i,j,ispec)
+
+ ! if external density model
+ if(assign_external_model) rhol = rhoext(i,j,ispec)
+
+ ! for acoustic medium
+ ! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl) / rhol
+ tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl) / rhol
+ enddo
+ enddo
+
+!
+! second double-loop over GLL to compute all the terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ ! along x direction and z direction
+ ! and assemble the contributions
+ do k = 1,NGLLX
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - &
+ (tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if acoustic element
+
+ enddo ! end of loop over all spectral elements
+
+!
+!--- absorbing boundaries
+!
+ if(anyabs) then
+
+ do ispecabs=1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+ ! Sommerfeld condition if acoustic
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+
+ ! get elastic parameters of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ rhol = density(1,kmato(ispec))
+
+ cpl = sqrt(kappal/rhol)
+
+ !--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+ i = 1
+ jbegin = jbegin_left(ispecabs)
+ jend = jend_left(ispecabs)
+ do j = jbegin,jend
+ iglob = ibool(i,j,ispec)
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ weight = jacobian1D * wzgll(j)
+
+ if( SIMULATION_TYPE == 1 ) then
+ ! adds absorbing boundary contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ ! adds (previously) stored contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - b_absorb_acoustic_left(j,ib_left(ispecabs),NSTEP-it+1)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ ! saves contribution
+ b_absorb_acoustic_left(j,ib_left(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+ !--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+ i = NGLLX
+ jbegin = jbegin_right(ispecabs)
+ jend = jend_right(ispecabs)
+ do j = jbegin,jend
+ iglob = ibool(i,j,ispec)
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ weight = jacobian1D * wzgll(j)
+
+ if( SIMULATION_TYPE == 1 ) then
+ ! adds absorbing boundary contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - b_absorb_acoustic_right(j,ib_right(ispecabs),NSTEP-it+1)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ ! saves contribution
+ b_absorb_acoustic_right(j,ib_right(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ endif
+ enddo
+ endif ! end of right absorbing boundary
+
+ !--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+ j = 1
+ ibegin = ibegin_bottom(ispecabs)
+ iend = iend_bottom(ispecabs)
+ ! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+ do i = ibegin,iend
+ iglob = ibool(i,j,ispec)
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ weight = jacobian1D * wxgll(i)
+
+ if( SIMULATION_TYPE == 1 ) then
+ ! adds absorbing boundary contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),NSTEP-it+1)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ ! saves contribution
+ b_absorb_acoustic_bottom(i,ib_bottom(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ endif
+ enddo
+ endif ! end of bottom absorbing boundary
+
+ !--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+ j = NGLLZ
+ ibegin = ibegin_top(ispecabs)
+ iend = iend_top(ispecabs)
+ ! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+ do i = ibegin,iend
+ iglob = ibool(i,j,ispec)
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ weight = jacobian1D * wxgll(i)
+
+ if( SIMULATION_TYPE == 1 ) then
+ ! adds absorbing boundary contribution
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(SIMULATION_TYPE == 2) then
+ potential_dot_dot_acoustic(iglob) = &
+ potential_dot_dot_acoustic(iglob) &
+ - b_absorb_acoustic_top(i,ib_top(ispecabs),NSTEP-it+1)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ ! saves contribution
+ b_absorb_acoustic_top(i,ib_top(ispecabs),it) = &
+ potential_dot_acoustic(iglob)*weight/cpl/rhol
+ endif
+ enddo
+ endif ! end of top absorbing boundary
+
+ endif ! acoustic ispec
+ enddo
+ endif ! end of absorbing boundaries
+
+ end subroutine compute_forces_acoustic_2
+
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_fluid.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_forces_poro_fluid.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_fluid.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_fluid.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,940 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.3
+! ------------------------------
+!
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_forces_poro_fluid(npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
+ accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
+ b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,source_time_function,sourcearray,adj_sourcearrays,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu2,N_SLS, &
+ rx_viscous,rz_viscous,theta_e,theta_s,&
+ b_viscodampx,b_viscodampz,&
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
+ jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ C_k,M_k,NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD,&
+ b_absorb_poro_w_left,b_absorb_poro_w_right,b_absorb_poro_w_bottom,b_absorb_poro_w_top,&
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,f0,freq0,Q0)
+
+! compute forces for the fluid poroelastic part
+
+ implicit none
+
+ include "constants.h"
+ integer :: NSOURCES, i_source
+ integer, dimension(NSOURCES) ::ispec_selected_source,source_type,is_proc_source
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP
+ integer :: nrec,SIMULATION_TYPE,myrank
+ integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nelemabs) :: ib_left
+ integer, dimension(nelemabs) :: ib_right
+ integer, dimension(nelemabs) :: ib_bottom
+ integer, dimension(nelemabs) :: ib_top
+
+ logical :: anyabs,initialfield,TURN_ATTENUATION_ON
+ logical :: SAVE_FORWARD
+
+ double precision ::deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+ integer, dimension(nelemabs) :: numabs,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro
+
+ logical, dimension(nspec) :: poroelastic
+ logical, dimension(4,nelemabs) :: codeabs
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: accelw_poroelastic,velocw_poroelastic,displw_poroelastic,&
+ displs_poroelastic,velocs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(3,numat) :: permeability
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
+ real(kind=CUSTOM_REAL), dimension(npoin) :: C_k,M_k
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_poro_w_left
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_poro_w_right
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmax,NSTEP) :: b_absorb_poro_w_top
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmin,NSTEP) :: b_absorb_poro_w_bottom
+ real(kind=CUSTOM_REAL), dimension(npoin) :: b_viscodampx,b_viscodampz
+
+ integer :: N_SLS
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e11,e13
+ double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu2,phi_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu2
+ real(kind=CUSTOM_REAL) :: e11_sum,e13_sum
+ integer :: i_sls
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: &
+ dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
+
+! viscous attenuation
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: rx_viscous
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: rz_viscous
+ double precision :: theta_e,theta_s
+ logical TURN_VISCATTENUATION_ON
+ double precision, dimension(3):: bl_unrelaxed,bl_relaxed
+
+! derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+! Gauss-Lobatto-Legendre weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+!
+ double precision :: f0,freq0,Q0,w_c
+
+
+!---
+!--- local variables
+!---
+
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend,irec,irec_local
+
+! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
+ real(kind=CUSTOM_REAL) :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xz,sigma_zz
+ real(kind=CUSTOM_REAL) :: sigmap
+ real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xz,b_sigma_zz
+ real(kind=CUSTOM_REAL) :: b_sigmap
+ real(kind=CUSTOM_REAL) :: nx,nz,vx,vz,vn,vxf,vzf,vnf,rho_vpI,rho_vpII,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1p,tempx2p,tempz1p,tempz2p
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempz1,b_tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1p,b_tempx2p,b_tempz1p,b_tempz2p
+
+
+! Jacobian matrix and determinant
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the poroelastic medium
+ real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
+ real(kind=CUSTOM_REAL) :: etal_f,kappal_f,rhol_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl,viscodampx,viscodampz
+ real(kind=CUSTOM_REAL) :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
+ real(kind=CUSTOM_REAL) :: cpIsquare,cpIIsquare,cssquare,cpIl,cpIIl,csl
+
+! for attenuation
+ real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
+
+! compute Grad(displs_poroelastic) at time step n for attenuation
+ if(TURN_ATTENUATION_ON) call compute_gradient_attenuation(displs_poroelastic,dux_dxl_n,duz_dxl_n, &
+ dux_dzl_n,duz_dzl_n,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+!---
+!--- poroelastic spectral element
+!---
+
+ if(poroelastic(ispec)) then
+
+! get poroelastic properties of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) -4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
+ kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+!The RHS has the form : div T_f -rho_f/rho_bar div T - eta_fk^-1.partial t w
+!where T = G:grad u_s + C_biot div w I
+!and T_f = C_biot div u_s I + M_biot div w I
+ mul_G = mul_fr
+ lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+
+ b_dwx_dxi = ZERO
+ b_dwz_dxi = ZERO
+
+ b_dwx_dgamma = ZERO
+ b_dwz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+
+ b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
+ b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
+
+ b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
+ b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
+ endif
+
+! compute stress tensor (include attenuation if needed)
+
+ if(TURN_ATTENUATION_ON) then
+! Dissipation only controlled by frame share attenuation in poroelastic (see Morency & Tromp, GJI 2008).
+! attenuation is implemented following the memory variable formulation of
+! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993). More details can be found in
+! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_G + mul_G) - mul_G * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_G * Mu_nu2(i,j,ispec)
+ lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
+
+! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
+ sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
+! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
+ e11_sum = 0._CUSTOM_REAL
+ e13_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_SLS
+ e11_sum = e11_sum + e11(i,j,ispec,i_sls)
+ e13_sum = e13_sum + e13(i,j,ispec,i_sls)
+ enddo
+
+ sigma_xx = sigma_xx + TWO * mul_G * e11_sum
+ sigma_xz = sigma_xz + mul_G * e13_sum
+ sigma_zz = sigma_zz - TWO * mul_G * e11_sum
+
+ else
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_G*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+
+ b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
+ endif
+ endif
+
+! kernels calculation
+ if(SIMULATION_TYPE == 2) then
+ iglob = ibool(i,j,ispec)
+ C_k(iglob) = ((dux_dxl + duz_dzl) * (b_dwx_dxl + b_dwz_dzl) + &
+ (dwx_dxl + dwz_dzl) * (b_dux_dxl + b_duz_dzl)) * C_biot
+ M_k(iglob) = (dwx_dxl + dwz_dzl) * (b_dwx_dxl + b_dwz_dzl) * M_biot
+ endif
+
+ jacobianl = jacobian(i,j,ispec)
+
+! weak formulation term based on stress tensor (non-symmetric form)
+! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
+ tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
+
+ tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
+ tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
+
+ tempx1p(i,j) = wzgll(j)*jacobianl*sigmap*xixl
+ tempz1p(i,j) = wzgll(j)*jacobianl*sigmap*xizl
+
+ tempx2p(i,j) = wxgll(i)*jacobianl*sigmap*gammaxl
+ tempz2p(i,j) = wxgll(i)*jacobianl*sigmap*gammazl
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
+ b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
+
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
+ b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
+
+ b_tempx1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xixl
+ b_tempz1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xizl
+
+ b_tempx2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammaxl
+ b_tempz2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammazl
+ endif
+
+ enddo
+ enddo
+
+!
+! second double-loop over GLL to compute all the terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+! along x direction and z direction
+! and assemble the contributions
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) + ( (rhol_f/rhol_bar*tempx1(k,j) - tempx1p(k,j)) &
+ *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*tempx2(i,k) - tempx2p(i,k))*hprimewgll_zz(k,j) )
+
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + ( (rhol_f/rhol_bar*tempz1(k,j) - tempz1p(k,j)) &
+ *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*tempz2(i,k) - tempz2p(i,k))*hprimewgll_zz(k,j) )
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) + ( (rhol_f/rhol_bar*b_tempx1(k,j) - b_tempx1p(k,j)) &
+ *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*b_tempx2(i,k) - b_tempx2p(i,k))*hprimewgll_zz(k,j) )
+
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + ( (rhol_f/rhol_bar*b_tempz1(k,j) - b_tempz1p(k,j)) &
+ *hprimewgll_xx(k,i) + (rhol_f/rhol_bar*b_tempz2(i,k) - b_tempz2p(i,k))*hprimewgll_zz(k,j) )
+ endif
+
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if poroelastic element
+
+ enddo ! end of loop over all spectral elements
+
+!
+!---- viscous damping
+!
+! add - eta_f k^-1 dot(w)
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ etal_f = poroelastcoef(2,2,kmato(ispec))
+
+ if(poroelastic(ispec) .and. etal_f > 0.d0) then
+
+ permlxx = permeability(1,kmato(ispec))
+ permlxz = permeability(2,kmato(ispec))
+ permlzz = permeability(3,kmato(ispec))
+
+! calcul of the inverse of k
+ detk = permlxx*permlzz - permlxz*permlxz
+
+ if(detk /= ZERO) then
+ invpermlxx = permlzz/detk
+ invpermlxz = -permlxz/detk
+ invpermlzz = permlxx/detk
+ else
+ stop 'Permeability matrix is not invertible'
+ endif
+
+! relaxed viscous coef
+ bl_relaxed(1) = etal_f*invpermlxx
+ bl_relaxed(2) = etal_f*invpermlxz
+ bl_relaxed(3) = etal_f*invpermlzz
+
+ if(TURN_VISCATTENUATION_ON) then
+ bl_unrelaxed(1) = etal_f*invpermlxx*theta_e/theta_s
+ bl_unrelaxed(2) = etal_f*invpermlxz*theta_e/theta_s
+ bl_unrelaxed(3) = etal_f*invpermlzz*theta_e/theta_s
+ endif
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ if(TURN_VISCATTENUATION_ON) then
+! compute the viscous damping term with the unrelaxed viscous coef and add memory variable
+ viscodampx = velocw_poroelastic(1,iglob)*bl_unrelaxed(1) + velocw_poroelastic(2,iglob)*bl_unrelaxed(2)&
+ - rx_viscous(i,j,ispec)
+ viscodampz = velocw_poroelastic(1,iglob)*bl_unrelaxed(2) + velocw_poroelastic(2,iglob)*bl_unrelaxed(3)&
+ - rz_viscous(i,j,ispec)
+ else
+! no viscous attenuation
+ viscodampx = velocw_poroelastic(1,iglob)*bl_relaxed(1) + velocw_poroelastic(2,iglob)*bl_relaxed(2)
+ viscodampz = velocw_poroelastic(1,iglob)*bl_relaxed(2) + velocw_poroelastic(2,iglob)*bl_relaxed(3)
+ endif
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
+ viscodampx
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
+ viscodampz
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_viscodampx(iglob) = wxgll(i)*wzgll(j)*jacobian(i,j,ispec) * viscodampx
+ b_viscodampz(iglob) = wxgll(i)*wzgll(j)*jacobian(i,j,ispec) * viscodampz
+ elseif(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - b_viscodampx(iglob)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - b_viscodampz(iglob)
+ endif
+
+ enddo
+ enddo
+
+ endif ! end of test if poroelastic element
+
+ enddo ! end of loop over all spectral elements
+
+
+!
+!--- absorbing boundaries
+!
+ if(anyabs) then
+
+ do ispecabs=1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+ if (poroelastic(ispec)) then
+! get poroelastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ permlxx = permeability(1,kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ etal_f = poroelastcoef(2,2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
+ tortl,rhol_s,rhol_f,etal_f,permlxx,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIl = sqrt(cpIsquare)
+ cpIIl = sqrt(cpIIsquare)
+ csl = sqrt(cssquare)
+
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
+ i = 1
+
+ jbegin = jbegin_left_poro(ispecabs)
+ jend = jend_left_poro(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+ rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
+ rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
+ rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
+ tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_w_left(1,j,ib_left(ispecabs),it) = tx*weight
+ b_absorb_poro_w_left(2,j,ib_left(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_left(1,j,ib_left(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_left(2,j,ib_left(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+
+ i = NGLLX
+
+ jbegin = jbegin_right_poro(ispecabs)
+ jend = jend_right_poro(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+
+ rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
+ rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
+ rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
+ tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_w_right(1,j,ib_right(ispecabs),it) = tx*weight
+ b_absorb_poro_w_right(2,j,ib_right(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_right(1,j,ib_right(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_right(2,j,ib_right(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+
+ j = 1
+
+ ibegin = ibegin_bottom_poro(ispecabs)
+ iend = iend_bottom_poro(ispecabs)
+
+! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+
+ rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
+ rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
+ rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
+ tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_w_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
+ b_absorb_poro_w_bottom(2,i,ib_bottom(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+
+ j = NGLLZ
+
+ ibegin = ibegin_top_poro(ispecabs)
+ iend = iend_top_poro(ispecabs)
+
+! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+
+ rho_vpI = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIl
+ rho_vpII = (rhol_f*tortl*rhol_bar - phil*rhol_f*rhol_f)/(phil*rhol_bar)*cpIIl
+ rho_vs = rhol_f/rhol_bar*(rhol_bar-rhol_f*phil/tortl)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpII*vnf*nx - rho_vs*(vx-vn*nx)
+ tz = rho_vpII*vnf*nz - rho_vs*(vz-vn*nz)
+
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - tx*weight
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_w_top(1,i,ib_top(ispecabs),it) = tx*weight
+ b_absorb_poro_w_top(2,i,ib_top(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ b_absorb_poro_w_top(1,i,ib_top(ispecabs),NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ b_absorb_poro_w_top(2,i,ib_top(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of top absorbing boundary
+
+ endif ! if poroelastic(ispec)
+ enddo
+
+ endif ! end of absorbing boundaries
+
+
+! --- add the source
+ if(.not. initialfield) then
+ do i_source=1,NSOURCES
+! if this processor carries the source and the source element is poroelastic
+ if (is_proc_source(i_source) == 1 .and. poroelastic(ispec_selected_source(i_source))) then
+
+ phil = porosity(kmato(ispec_selected_source(i_source)))
+ rhol_s = density(1,kmato(ispec_selected_source(i_source)))
+ rhol_f = density(2,kmato(ispec_selected_source(i_source)))
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+
+! moment tensor
+ if(source_type(i_source) == 2) then
+
+! add source array
+ if(SIMULATION_TYPE == 1) then ! forward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ accelw_poroelastic(:,iglob) = accelw_poroelastic(:,iglob) + &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
+ enddo
+ enddo
+ else ! backward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ b_accelw_poroelastic(:,iglob) = b_accelw_poroelastic(:,iglob) + &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sourcearray(i_source,:,i,j)*source_time_function(i_source,NSTEP-it+1)
+ enddo
+ enddo
+ endif !endif SIMULATION_TYPE == 1
+
+ endif !if(source_type(i_source) == 2)
+
+ endif ! if this processor carries the source and the source element is poroelastic
+ enddo
+
+ if(SIMULATION_TYPE == 2) then ! adjoint wavefield
+ irec_local = 0
+ do irec = 1,nrec
+! add the source (only if this proc carries the source)
+ if(myrank == which_proc_receiver(irec)) then
+
+ irec_local = irec_local + 1
+ if(poroelastic(ispec_selected_rec(irec))) then
+ phil = porosity(kmato(ispec_selected_rec(irec)))
+ rhol_s = density(1,kmato(ispec_selected_rec(irec)))
+ rhol_f = density(2,kmato(ispec_selected_rec(irec)))
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - &
+ rhol_f/rhol_bar*adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - &
+ rhol_f/rhol_bar*adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
+ enddo
+ enddo
+ endif ! if element is poroelastic
+
+ endif ! if this processor carries the adjoint source and the source element is poroelastic
+ enddo ! irec = 1,nrec
+ endif ! SIMULATION_TYPE == 2 adjoint wavefield
+
+ endif ! if not using an initial field
+
+! implement attenuation
+ if(TURN_ATTENUATION_ON) then
+
+! compute Grad(displs_poroelastic) at time step n+1 for attenuation
+ call compute_gradient_attenuation(displs_poroelastic,dux_dxl_np1,duz_dxl_np1, &
+ dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
+
+! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ if (poroelastic(ispec)) then
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
+ theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
+
+! loop on all the standard linear solids
+ do i_sls = 1,N_SLS
+
+! evolution e1 ! no need since we are just considering shear attenuation
+! Un = e1(i,j,ispec,i_sls)
+! tauinv = - inv_tau_sigma_nu1(i,j,ispec,i_sls)
+! tauinvsquare = tauinv * tauinv
+! tauinvcube = tauinvsquare * tauinv
+! tauinvUn = tauinv * Un
+! Sn = theta_n * phi_nu1(i,j,ispec,i_sls)
+! Snp1 = theta_np1 * phi_nu1(i,j,ispec,i_sls)
+! Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+! twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+! fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+! deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+! e1(i,j,ispec,i_sls) = Unp1
+
+! evolution e11
+ Un = e11(i,j,ispec,i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i,j,ispec,i_sls)
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e11(i,j,ispec,i_sls) = Unp1
+
+! evolution e13
+ Un = e13(i,j,ispec,i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e13(i,j,ispec,i_sls) = Unp1
+
+ enddo
+
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif ! end of test on attenuation
+
+ end subroutine compute_forces_poro_fluid
+
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_solid.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_forces_poro_solid.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_solid.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_forces_poro_solid.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,957 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.3
+! ------------------------------
+!
+! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_forces_poro_solid(npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
+ accels_poroelastic,velocs_poroelastic,velocw_poroelastic,displs_poroelastic,displw_poroelastic,&
+ b_accels_poroelastic,b_displs_poroelastic,b_displw_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,source_time_function,sourcearray,adj_sourcearrays,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu2,N_SLS, &
+ rx_viscous,rz_viscous,theta_e,theta_s,&
+ b_viscodampx,b_viscodampz,&
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
+ jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ mufr_k,B_k,NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD,&
+ b_absorb_poro_s_left,b_absorb_poro_s_right,b_absorb_poro_s_bottom,b_absorb_poro_s_top,&
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,f0,freq0,Q0)
+
+! compute forces for the solid poroelastic part
+
+ implicit none
+
+ include "constants.h"
+ integer :: NSOURCES, i_source
+ integer, dimension(NSOURCES) :: ispec_selected_source,source_type,is_proc_source
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP
+ integer :: nrec,SIMULATION_TYPE,myrank
+ integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nelemabs) :: ib_left
+ integer, dimension(nelemabs) :: ib_right
+ integer, dimension(nelemabs) :: ib_bottom
+ integer, dimension(nelemabs) :: ib_top
+
+ logical :: anyabs,initialfield,TURN_ATTENUATION_ON
+ logical :: SAVE_FORWARD
+
+ double precision :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+ integer, dimension(nelemabs) :: numabs,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro
+
+ logical, dimension(nspec) :: poroelastic
+ logical, dimension(4,nelemabs) :: codeabs
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: accels_poroelastic,velocs_poroelastic,displs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: velocw_poroelastic,displw_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accels_poroelastic,b_displs_poroelastic,b_displw_poroelastic
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(3,numat) :: permeability
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
+ real(kind=CUSTOM_REAL), dimension(npoin) :: mufr_k,B_k
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_poro_s_left
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_poro_s_right
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmax,NSTEP) :: b_absorb_poro_s_top
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmin,NSTEP) :: b_absorb_poro_s_bottom
+ real(kind=CUSTOM_REAL), dimension(npoin) :: b_viscodampx,b_viscodampz
+
+ integer :: N_SLS
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e11,e13
+ double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu2,phi_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu2
+ real(kind=CUSTOM_REAL) :: e11_sum,e13_sum
+ integer :: i_sls
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: &
+ dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
+
+! viscous attenuation (poroelastic media)
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: rx_viscous
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: rz_viscous
+ double precision :: theta_e,theta_s
+ logical TURN_VISCATTENUATION_ON
+ double precision, dimension(3):: bl_unrelaxed,bl_relaxed
+
+! derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+! Gauss-Lobatto-Legendre weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+!
+ double precision :: f0,freq0,Q0,w_c
+
+!---
+!--- local variables
+!---
+
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend,irec,irec_local
+
+! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
+ real(kind=CUSTOM_REAL) :: dsxx,dsxz,dszz
+ real(kind=CUSTOM_REAL) :: b_dsxx,b_dsxz,b_dszz
+ real(kind=CUSTOM_REAL) :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
+ real(kind=CUSTOM_REAL) :: dwxx,dwxz,dwzz
+ real(kind=CUSTOM_REAL) :: b_dwxx,b_dwxz,b_dwzz
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xz,sigma_zz
+ real(kind=CUSTOM_REAL) :: sigmap
+ real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xz,b_sigma_zz
+ real(kind=CUSTOM_REAL) :: b_sigmap
+ real(kind=CUSTOM_REAL) :: nx,nz,vx,vz,vn,vxf,vzf,vnf,rho_vpI,rho_vpII,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1p,tempx2p,tempz1p,tempz2p
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempz1,b_tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1p,b_tempx2p,b_tempz1p,b_tempz2p
+
+! Jacobian matrix and determinant
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the poroelastic medium
+ real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
+ real(kind=CUSTOM_REAL) :: etal_f,kappal_f,rhol_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl,viscodampx,viscodampz
+ real(kind=CUSTOM_REAL) :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
+ real(kind=CUSTOM_REAL) :: cpIsquare,cpIIsquare,cssquare,cpIl,cpIIl,csl
+
+! for attenuation
+ real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
+
+! compute Grad(displs_poroelastic) at time step n for attenuation
+ if(TURN_ATTENUATION_ON) call compute_gradient_attenuation(displs_poroelastic,dux_dxl_n,duz_dxl_n, &
+ dux_dzl_n,duz_dzl_n,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+!---
+!--- poroelastic spectral element
+!---
+
+ if(poroelastic(ispec)) then
+
+! get poroelastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
+ kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+!The RHS has the form : div T -phi/c div T_f + phi/ceta_fk^-1.partial t w
+!where T = G:grad u_s + C_biot div w I
+!and T_f = C_biot div u_s I + M_biot div w I
+ mul_G = mul_fr
+ lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+
+ b_dwx_dxi = ZERO
+ b_dwz_dxi = ZERO
+
+ b_dwx_dgamma = ZERO
+ b_dwz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+
+ b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
+ b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
+
+ b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
+ b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
+ endif
+
+! compute stress tensor (include attenuation or anisotropy if needed)
+
+ if(TURN_ATTENUATION_ON) then
+! Dissipation only controlled by frame share attenuation in poroelastic (see Morency & Tromp, GJI 2008).
+! attenuation is implemented following the memory variable formulation of
+! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993). More details can be found in
+! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_G + mul_G) - mul_G * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_G * Mu_nu2(i,j,ispec)
+ lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
+
+! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
+ sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
+! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
+ e11_sum = 0._CUSTOM_REAL
+ e13_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_SLS
+ e11_sum = e11_sum + e11(i,j,ispec,i_sls)
+ e13_sum = e13_sum + e13(i,j,ispec,i_sls)
+ enddo
+
+ sigma_xx = sigma_xx + TWO * mul_G * e11_sum
+ sigma_xz = sigma_xz + mul_G * e13_sum
+ sigma_zz = sigma_zz - TWO * mul_G * e11_sum
+
+ else
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_G*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+
+ b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
+ endif
+ endif
+
+! kernels calculation
+ if(SIMULATION_TYPE == 2) then
+ iglob = ibool(i,j,ispec)
+ dsxx = dux_dxl
+ dsxz = HALF * (duz_dxl + dux_dzl)
+ dszz = duz_dzl
+
+ dwxx = dwx_dxl
+ dwxz = HALF * (dwz_dxl + dwx_dzl)
+ dwzz = dwz_dzl
+
+ b_dsxx = b_dux_dxl
+ b_dsxz = HALF * (b_duz_dxl + b_dux_dzl)
+ b_dszz = b_duz_dzl
+
+ b_dwxx = b_dwx_dxl
+ b_dwxz = HALF * (b_dwz_dxl + b_dwx_dzl)
+ b_dwzz = b_dwz_dzl
+
+ B_k(iglob) = (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl) * (H_biot - FOUR_THIRDS * mul_fr)
+ mufr_k(iglob) = (dsxx * b_dsxx + dszz * b_dszz + &
+ 2._CUSTOM_REAL * dsxz * b_dsxz - &
+ 1._CUSTOM_REAL/3._CUSTOM_REAL * (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl) ) * mul_fr
+ endif
+
+ jacobianl = jacobian(i,j,ispec)
+
+! weak formulation term based on stress tensor (non-symmetric form)
+! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
+ tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
+
+ tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
+ tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
+
+ tempx1p(i,j) = wzgll(j)*jacobianl*sigmap*xixl
+ tempz1p(i,j) = wzgll(j)*jacobianl*sigmap*xizl
+
+ tempx2p(i,j) = wxgll(i)*jacobianl*sigmap*gammaxl
+ tempz2p(i,j) = wxgll(i)*jacobianl*sigmap*gammazl
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
+ b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
+
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
+ b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
+
+ b_tempx1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xixl
+ b_tempz1p(i,j) = wzgll(j)*jacobianl*b_sigmap*xizl
+
+ b_tempx2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammaxl
+ b_tempz2p(i,j) = wxgll(i)*jacobianl*b_sigmap*gammazl
+ endif
+
+ enddo
+ enddo
+
+!
+! second double-loop over GLL to compute all the terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+! along x direction and z direction
+! and assemble the contributions
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - ( (tempx1(k,j) - phil/tortl*tempx1p(k,j)) &
+ *hprimewgll_xx(k,i) + (tempx2(i,k) - phil/tortl*tempx2p(i,k))*hprimewgll_zz(k,j) )
+
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - ( (tempz1(k,j) - phil/tortl*tempz1p(k,j)) &
+ *hprimewgll_xx(k,i) + (tempz2(i,k) - phil/tortl*tempz2p(i,k))*hprimewgll_zz(k,j) )
+
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - ( (b_tempx1(k,j) - phil/tortl*b_tempx1p(k,j)) &
+ *hprimewgll_xx(k,i) + (b_tempx2(i,k) - phil/tortl*b_tempx2p(i,k))*hprimewgll_zz(k,j) )
+
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - ( (b_tempz1(k,j) - phil/tortl*b_tempz1p(k,j)) &
+ *hprimewgll_xx(k,i) + (b_tempz2(i,k) - phil/tortl*b_tempz2p(i,k))*hprimewgll_zz(k,j) )
+ endif
+
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if poroelastic element
+
+ enddo ! end of loop over all spectral elements
+
+!
+!---- viscous damping
+!
+! add + phi/tort eta_f k^-1 dot(w)
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ etal_f = poroelastcoef(2,2,kmato(ispec))
+
+ if(poroelastic(ispec) .and. etal_f >0.d0) then
+
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ permlxx = permeability(1,kmato(ispec))
+ permlxz = permeability(2,kmato(ispec))
+ permlzz = permeability(3,kmato(ispec))
+
+! calcul of the inverse of k
+ detk = permlxx*permlzz - permlxz*permlxz
+
+ if(detk /= ZERO) then
+ invpermlxx = permlzz/detk
+ invpermlxz = -permlxz/detk
+ invpermlzz = permlxx/detk
+ else
+ stop 'Permeability matrix is not invertible'
+ endif
+
+! relaxed viscous coef
+ bl_relaxed(1) = etal_f*invpermlxx
+ bl_relaxed(2) = etal_f*invpermlxz
+ bl_relaxed(3) = etal_f*invpermlzz
+
+ if(TURN_VISCATTENUATION_ON) then
+ bl_unrelaxed(1) = etal_f*invpermlxx*theta_e/theta_s
+ bl_unrelaxed(2) = etal_f*invpermlxz*theta_e/theta_s
+ bl_unrelaxed(3) = etal_f*invpermlzz*theta_e/theta_s
+ endif
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ if(TURN_VISCATTENUATION_ON) then
+! compute the viscous damping term with the unrelaxed viscous coef and add memory variable
+ viscodampx = velocw_poroelastic(1,iglob)*bl_unrelaxed(1) + velocw_poroelastic(2,iglob)*bl_unrelaxed(2)&
+ - rx_viscous(i,j,ispec)
+ viscodampz = velocw_poroelastic(1,iglob)*bl_unrelaxed(2) + velocw_poroelastic(2,iglob)*bl_unrelaxed(3)&
+ - rz_viscous(i,j,ispec)
+ else
+! no viscous attenuation
+ viscodampx = velocw_poroelastic(1,iglob)*bl_relaxed(1) + velocw_poroelastic(2,iglob)*bl_relaxed(2)
+ viscodampz = velocw_poroelastic(1,iglob)*bl_relaxed(2) + velocw_poroelastic(2,iglob)*bl_relaxed(3)
+ endif
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + phil/tortl*wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
+ viscodampx
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + phil/tortl*wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*&
+ viscodampz
+
+! if SIMULATION_TYPE == 1 .and. SAVE_FORWARD then b_viscodamp is saved in compute_forces_poro_fluid.f90
+ if(SIMULATION_TYPE == 2) then ! kernels calculation
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + phil/tortl*b_viscodampx(iglob)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + phil/tortl*b_viscodampz(iglob)
+ endif
+
+ enddo
+ enddo
+
+ endif ! end of test if poroelastic element
+
+ enddo ! end of loop over all spectral elements
+
+
+!
+!--- absorbing boundaries
+!
+ if(anyabs) then
+
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+ if (poroelastic(ispec)) then
+
+! get poroelastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ permlxx = permeability(1,kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ etal_f = poroelastcoef(2,2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
+ tortl,rhol_s,rhol_f,etal_f,permlxx,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ cpIl = sqrt(cpIsquare)
+ cpIIl = sqrt(cpIIsquare)
+ csl = sqrt(cssquare)
+
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
+ i = 1
+
+ jbegin = jbegin_left_poro(ispecabs)
+ jend = jend_left_poro(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+
+
+ weight = jacobian1D * wzgll(j)
+
+ rho_vpI = (rhol_bar - phil/tortl*rhol_f)*cpIl
+ rho_vpII = (rhol_bar - phil/tortl*rhol_f)*cpIIl
+ rho_vs = (rhol_bar - phil/tortl*rhol_f)*csl
+
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
+ tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_s_left(1,j,ib_left(ispecabs),it) = tx*weight
+ b_absorb_poro_s_left(2,j,ib_left(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_left(1,j,ib_left(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_left(2,j,ib_left(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+
+ i = NGLLX
+
+ jbegin = jbegin_right_poro(ispecabs)
+ jend = jend_right_poro(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+
+ rho_vpI = (rhol_bar - phil/tortl*rhol_f)*cpIl
+ rho_vpII = (rhol_bar - phil/tortl*rhol_f)*cpIIl
+ rho_vs = (rhol_bar - phil/tortl*rhol_f)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
+ tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_s_right(1,j,ib_right(ispecabs),it) = tx*weight
+ b_absorb_poro_s_right(2,j,ib_right(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_right(1,j,ib_right(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_right(2,j,ib_right(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+
+ j = 1
+
+ ibegin = ibegin_bottom_poro(ispecabs)
+ iend = iend_bottom_poro(ispecabs)
+
+! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+
+ rho_vpI = (rhol_bar - phil/tortl*rhol_f)*cpIl
+ rho_vpII = (rhol_bar - phil/tortl*rhol_f)*cpIIl
+ rho_vs = (rhol_bar - phil/tortl*rhol_f)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
+ tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_s_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
+ b_absorb_poro_s_bottom(2,i,ib_bottom(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+
+ j = NGLLZ
+
+ ibegin = ibegin_top_poro(ispecabs)
+ iend = iend_top_poro(ispecabs)
+
+! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+
+ rho_vpI = (rhol_bar - phil/tortl*rhol_f)*cpIl
+ rho_vpII = (rhol_bar - phil/tortl*rhol_f)*cpIIl
+ rho_vs = (rhol_bar - phil/tortl*rhol_f)*csl
+
+ if(poroelastic(ispec)) then
+ vx = velocs_poroelastic(1,iglob)
+ vz = velocs_poroelastic(2,iglob)
+ vxf = velocw_poroelastic(1,iglob)
+ vzf = velocw_poroelastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+ vnf = nx*vxf+nz*vzf
+
+ tx = rho_vpI*vn*nx + rho_vs*(vx-vn*nx)
+ tz = rho_vpI*vn*nz + rho_vs*(vz-vn*nz)
+
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - tx*weight
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) - tz*weight
+
+ if(SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_poro_s_top(1,i,ib_top(ispecabs),it) = tx*weight
+ b_absorb_poro_s_top(2,i,ib_top(ispecabs),it) = tz*weight
+ elseif(SIMULATION_TYPE == 2) then
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - &
+ b_absorb_poro_s_top(1,i,ib_top(ispecabs),NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) - &
+ b_absorb_poro_s_top(2,i,ib_top(ispecabs),NSTEP-it+1)
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of top absorbing boundary
+
+ endif ! if poroelastic(ispec)
+
+ enddo
+
+ endif ! end of absorbing boundaries
+
+
+! --- add the source
+ if(.not. initialfield) then
+ do i_source=1,NSOURCES
+
+! if this processor carries the source and the source element is poroelastic
+ if (is_proc_source(i_source) == 1 .and. poroelastic(ispec_selected_source(i_source))) then
+
+ phil = porosity(kmato(ispec_selected_source(i_source)))
+ tortl = tortuosity(kmato(ispec_selected_source(i_source)))
+
+! moment tensor
+ if(source_type(i_source) == 2) then
+
+! add source array
+ if(SIMULATION_TYPE == 1) then ! forward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ accels_poroelastic(:,iglob) = accels_poroelastic(:,iglob) + &
+ (1._CUSTOM_REAL - phil/tortl)*sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
+ enddo
+ enddo
+ else ! backward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ b_accels_poroelastic(:,iglob) = b_accels_poroelastic(:,iglob) + &
+ (1._CUSTOM_REAL - phil/tortl)*sourcearray(i_source,:,i,j)*source_time_function(i_source,NSTEP-it+1)
+ enddo
+ enddo
+ endif !endif SIMULATION_TYPE == 1
+
+ endif !if(source_type(i_source) == 2)
+
+ endif ! if this processor carries the source and the source element is poroelastic
+ enddo
+
+ if(SIMULATION_TYPE == 2) then ! adjoint wavefield
+ irec_local = 0
+ do irec = 1,nrec
+! add the source (only if this proc carries the source)
+ if(myrank == which_proc_receiver(irec)) then
+
+ irec_local = irec_local + 1
+ if(poroelastic(ispec_selected_rec(irec))) then
+! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
+ enddo
+ enddo
+ endif ! if element is poroelastic
+
+ endif ! if this processor carries the adjoint source and the source element is poroelastic
+ enddo ! irec = 1,nrec
+ endif ! SIMULATION_TYPE == 2 adjoint wavefield
+
+ endif ! if not using an initial field
+
+! implement attenuation
+ if(TURN_ATTENUATION_ON) then
+
+! compute Grad(displs_poroelastic) at time step n+1 for attenuation
+ call compute_gradient_attenuation(displs_poroelastic,dux_dxl_np1,duz_dxl_np1, &
+ dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,poroelastic,hprime_xx,hprime_zz,nspec,npoin)
+
+! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ if (poroelastic(ispec)) then
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
+ theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
+
+! loop on all the standard linear solids
+ do i_sls = 1,N_SLS
+
+! evolution e1 ! no need since we are just considering shear attenuation
+! Un = e1(i,j,ispec,i_sls)
+! tauinv = - inv_tau_sigma_nu1(i,j,ispec,i_sls)
+! tauinvsquare = tauinv * tauinv
+! tauinvcube = tauinvsquare * tauinv
+! tauinvUn = tauinv * Un
+! Sn = theta_n * phi_nu1(i,j,ispec,i_sls)
+! Snp1 = theta_np1 * phi_nu1(i,j,ispec,i_sls)
+! Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+! twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+! fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+! deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+! e1(i,j,ispec,i_sls) = Unp1
+
+! evolution e11
+ Un = e11(i,j,ispec,i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i,j,ispec,i_sls)
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e11(i,j,ispec,i_sls) = Unp1
+
+! evolution e13
+ Un = e13(i,j,ispec,i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e13(i,j,ispec,i_sls) = Unp1
+
+ enddo
+
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif ! end of test on attenuation
+
+
+ end subroutine compute_forces_poro_solid
+
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_forces_viscoelastic.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_forces_viscoelastic.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_forces_viscoelastic.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_forces_viscoelastic.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,988 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+subroutine compute_forces_viscoelastic(p_sv,npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver, &
+ source_type,it,NSTEP,anyabs,assign_external_model, &
+ initialfield,TURN_ATTENUATION_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
+ accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic, &
+ density,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy, &
+ source_time_function,sourcearray,adj_sourcearrays,e1,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
+ deltat,coord,add_Bielak_conditions, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset,f0, &
+ v0x_left,v0z_left,v0x_right,v0z_right,v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot,&
+ nleft,nright,nbot,over_critical_angle,NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD,b_absorb_elastic_left,&
+ b_absorb_elastic_right,b_absorb_elastic_bottom,b_absorb_elastic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,mu_k,kappa_k)
+
+ ! compute forces for the elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ logical :: p_sv
+ integer :: NSOURCES, i_source
+ integer :: npoin,nspec,myrank,nelemabs,numat,it,NSTEP
+ integer, dimension(NSOURCES) :: ispec_selected_source,is_proc_source,source_type
+
+ integer :: nrec,SIMULATION_TYPE
+ integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nelemabs) :: ib_left
+ integer, dimension(nelemabs) :: ib_right
+ integer, dimension(nelemabs) :: ib_bottom
+ integer, dimension(nelemabs) :: ib_top
+
+ logical :: anyabs,assign_external_model,initialfield,TURN_ATTENUATION_ON,add_Bielak_conditions
+
+ logical :: SAVE_FORWARD
+
+ double precision :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+ double precision, dimension(NSOURCES) :: angleforce
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+ integer, dimension(nelemabs) :: numabs
+
+ logical, dimension(nspec) :: elastic,anisotropic
+ logical, dimension(4,nelemabs) :: codeabs
+
+ real(kind=CUSTOM_REAL), dimension(3,npoin) :: accel_elastic,veloc_elastic,displ_elastic
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(6,numat) :: anisotropy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
+
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NSTEP) :: source_time_function
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
+
+ real(kind=CUSTOM_REAL), dimension(3,npoin) :: b_accel_elastic,b_displ_elastic
+ real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,3,NGLLX,NGLLZ) :: adj_sourcearrays
+ real(kind=CUSTOM_REAL), dimension(npoin) :: mu_k,kappa_k
+ real(kind=CUSTOM_REAL), dimension(3,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_elastic_left
+ real(kind=CUSTOM_REAL), dimension(3,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_elastic_right
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,nspec_zmax,NSTEP) :: b_absorb_elastic_top
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,nspec_zmin,NSTEP) :: b_absorb_elastic_bottom
+
+ integer :: N_SLS
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11,e13
+ double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
+ real(kind=CUSTOM_REAL) :: e1_sum,e11_sum,e13_sum
+ integer :: i_sls
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: &
+ dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
+
+ ! derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+ ! Gauss-Lobatto-Legendre weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+
+ !---
+ !--- local variables
+ !---
+
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,irec,irec_local
+
+ ! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duy_dxi,duy_dgamma,duz_dxi,duz_dgamma
+ real(kind=CUSTOM_REAL) :: dux_dxl,duy_dxl,duz_dxl,dux_dzl,duy_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duy_dxi,b_duy_dgamma,b_duz_dxi,b_duz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duy_dxl,b_duz_dxl,b_dux_dzl,b_duy_dzl,b_duz_dzl
+ real(kind=CUSTOM_REAL) :: dsxx,dsxz,dszz
+ real(kind=CUSTOM_REAL) :: b_dsxx,b_dsxz,b_dszz
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xy,sigma_xz,sigma_zy,sigma_zz
+ real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xy,b_sigma_xz,b_sigma_zy,b_sigma_zz
+ real(kind=CUSTOM_REAL) :: nx,nz,vx,vy,vz,vn,rho_vp,rho_vs,tx,ty,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempy1,tempy2,tempz1,tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempy1,b_tempy2,b_tempz1,b_tempz2
+
+ ! Jacobian matrix and determinant
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+ ! material properties of the elastic medium
+ real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal,cpl,csl,rhol, &
+ lambdal_unrelaxed,mul_unrelaxed,lambdalplus2mul_unrelaxed
+
+ ! for attenuation
+ real(kind=CUSTOM_REAL) :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
+
+ ! for anisotropy
+ double precision :: c11,c15,c13,c33,c35,c55
+
+ ! for analytical initial plane wave for Bielak's conditions
+ double precision :: veloc_horiz,veloc_vert,dxUx,dzUx,dxUz,dzUz,traction_x_t0,traction_z_t0,deltat
+ double precision, dimension(NDIM,npoin), intent(in) :: coord
+ double precision x0_source, z0_source, angleforce_refl, c_inc, c_refl, time_offset, f0
+ double precision, dimension(NDIM) :: A_plane, B_plane, C_plane
+ !over critical angle
+ logical :: over_critical_angle
+ integer :: nleft, nright, nbot
+ double precision, dimension(nleft) :: v0x_left,v0z_left,t0x_left,t0z_left
+ double precision, dimension(nright) :: v0x_right,v0z_right,t0x_right,t0z_right
+ double precision, dimension(nbot) :: v0x_bot,v0z_bot,t0x_bot,t0z_bot
+ integer count_left,count_right,count_bottom
+
+ integer :: ifirstelem,ilastelem
+
+ ! compute Grad(displ_elastic) at time step n for attenuation
+ if(TURN_ATTENUATION_ON) then
+ call compute_gradient_attenuation(displ_elastic,dux_dxl_n,duz_dxl_n, &
+ dux_dzl_n,duz_dzl_n,xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
+ endif
+
+ ifirstelem = 1
+ ilastelem = nspec
+
+ ! loop over spectral elements
+ do ispec = ifirstelem,ilastelem
+
+ tempx1(:,:) = ZERO
+ tempy1(:,:) = ZERO
+ tempz1(:,:) = ZERO
+ tempx2(:,:) = ZERO
+ tempy2(:,:) = ZERO
+ tempz2(:,:) = ZERO
+ if(SIMULATION_TYPE ==2)then
+ b_tempx1(:,:) = ZERO
+ b_tempy1(:,:) = ZERO
+ b_tempz1(:,:) = ZERO
+ b_tempx2(:,:) = ZERO
+ b_tempy2(:,:) = ZERO
+ b_tempz2(:,:) = ZERO
+ endif
+
+ !---
+ !--- elastic spectral element
+ !---
+ if(elastic(ispec)) then
+
+ ! get relaxed elastic parameters of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec))
+
+ ! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ !--- if external medium, get elastic parameters of current grid point
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ mul_relaxed = rhol*csl*csl
+ lambdal_relaxed = rhol*cpl*cpl - TWO*mul_relaxed
+ lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
+ endif
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duy_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duy_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
+ b_dux_dxi = ZERO
+ b_duy_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duy_dgamma = ZERO
+ b_duz_dgamma = ZERO
+ endif
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duy_dxi = duy_dxi + displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duy_dgamma = duy_dgamma + displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
+ b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_duy_dxi = b_duy_dxi + b_displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_duy_dgamma = b_duy_dgamma + b_displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duy_dxl = duy_dxi*xixl + duy_dgamma*gammaxl
+ duy_dzl = duy_dxi*xizl + duy_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duy_dxl = b_duy_dxi*xixl + b_duy_dgamma*gammaxl
+ b_duy_dzl = b_duy_dxi*xizl + b_duy_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+ endif
+
+ ! compute stress tensor (include attenuation or anisotropy if needed)
+
+ if(TURN_ATTENUATION_ON) then
+
+ ! attenuation is implemented following the memory variable formulation of
+ ! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+ ! vol. 58(1), p. 110-120 (1993). More details can be found in
+ ! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+ ! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+ ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(i,j,ispec) - mul_relaxed * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_relaxed * Mu_nu2(i,j,ispec)
+ lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
+
+ ! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
+ sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
+ sigma_xz = mul_unrelaxed*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
+
+ ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
+ ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
+ e1_sum = 0._CUSTOM_REAL
+ e11_sum = 0._CUSTOM_REAL
+ e13_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_SLS
+ e1_sum = e1_sum + e1(i,j,ispec,i_sls)
+ e11_sum = e11_sum + e11(i,j,ispec,i_sls)
+ e13_sum = e13_sum + e13(i,j,ispec,i_sls)
+ enddo
+
+ sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum + TWO * mul_relaxed * e11_sum
+ sigma_xz = sigma_xz + mul_relaxed * e13_sum
+ sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum - TWO * mul_relaxed * e11_sum
+
+ else
+
+ ! no attenuation
+ sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
+ sigma_xy = mul_relaxed*duy_dxl
+ sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
+ sigma_zy = mul_relaxed*duy_dzl
+ sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
+ b_sigma_xx = lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
+ b_sigma_xy = mul_relaxed*b_duy_dxl
+ b_sigma_xz = mul_relaxed*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zy = mul_relaxed*b_duy_dzl
+ b_sigma_zz = lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
+ endif
+
+ endif
+
+ ! full anisotropy
+ if(anisotropic(ispec)) then
+ if(assign_external_model) then
+ c11 = c11ext(i,j,ispec)
+ c13 = c13ext(i,j,ispec)
+ c15 = c15ext(i,j,ispec)
+ c33 = c33ext(i,j,ispec)
+ c35 = c35ext(i,j,ispec)
+ c55 = c55ext(i,j,ispec)
+ else
+ c11 = anisotropy(1,kmato(ispec))
+ c13 = anisotropy(2,kmato(ispec))
+ c15 = anisotropy(3,kmato(ispec))
+ c33 = anisotropy(4,kmato(ispec))
+ c35 = anisotropy(5,kmato(ispec))
+ c55 = anisotropy(6,kmato(ispec))
+ end if
+
+ ! implement anisotropy in 2D
+ sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
+ sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
+ sigma_xz = c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
+
+ endif
+
+ ! Pre-kernels calculation
+ if(SIMULATION_TYPE == 2) then
+ iglob = ibool(i,j,ispec)
+ if(p_sv)then !P-SV waves
+ dsxx = dux_dxl
+ dsxz = HALF * (duz_dxl + dux_dzl)
+ dszz = duz_dzl
+
+ b_dsxx = b_dux_dxl
+ b_dsxz = HALF * (b_duz_dxl + b_dux_dzl)
+ b_dszz = b_duz_dzl
+
+ kappa_k(iglob) = (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl)
+ mu_k(iglob) = dsxx * b_dsxx + dszz * b_dszz + &
+ 2._CUSTOM_REAL * dsxz * b_dsxz - 1._CUSTOM_REAL/3._CUSTOM_REAL * kappa_k(iglob)
+ else !SH (membrane) waves
+ mu_k(iglob) = duy_dxl * b_duy_dxl + duy_dzl * b_duy_dzl
+ endif
+ endif
+
+ jacobianl = jacobian(i,j,ispec)
+
+ ! weak formulation term based on stress tensor (non-symmetric form)
+ ! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
+ tempy1(i,j) = wzgll(j)*jacobianl*(sigma_xy*xixl+sigma_zy*xizl)
+ tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
+
+ tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
+ tempy2(i,j) = wxgll(i)*jacobianl*(sigma_xy*gammaxl+sigma_zy*gammazl)
+ tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
+ b_tempy1(i,j) = wzgll(j)*jacobianl*(b_sigma_xy*xixl+b_sigma_zy*xizl)
+ b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
+
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
+ b_tempy2(i,j) = wxgll(i)*jacobianl*(b_sigma_xy*gammaxl+b_sigma_zy*gammazl)
+ b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
+ endif
+
+ enddo
+ enddo
+
+ !
+ ! second double-loop over GLL to compute all the terms
+ !
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ ! along x direction and z direction
+ ! and assemble the contributions
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tempy1(k,j)*hprimewgll_xx(k,i) + tempy2(i,k)*hprimewgll_zz(k,j))
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tempz1(k,j)*hprimewgll_xx(k,i) + tempz2(i,k)*hprimewgll_zz(k,j))
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation, backward wavefield
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
+ (b_tempx1(k,j)*hprimewgll_xx(k,i) + b_tempx2(i,k)*hprimewgll_zz(k,j))
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
+ (b_tempy1(k,j)*hprimewgll_xx(k,i) + b_tempy2(i,k)*hprimewgll_zz(k,j))
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
+ (b_tempz1(k,j)*hprimewgll_xx(k,i) + b_tempz2(i,k)*hprimewgll_zz(k,j))
+ endif
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if elastic element
+
+ enddo ! end of loop over all spectral elements
+
+ !
+ !--- absorbing boundaries
+ !
+ if(anyabs) then
+
+ count_left=1
+ count_right=1
+ count_bottom=1
+
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+ ! get elastic parameters of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
+ cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
+ csl = sqrt(mul_relaxed/rhol)
+
+ !--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
+ i = 1
+
+ do j = 1,NGLLZ
+
+ iglob = ibool(i,j,ispec)
+
+ ! for analytical initial plane wave for Bielak's conditions
+ ! left or right edge, horizontal normal vector
+ if(add_Bielak_conditions .and. initialfield) then
+ if (.not.over_critical_angle) then
+ call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
+ traction_z_t0 = mul_relaxed*(dxUz + dzUx)
+ else
+ veloc_horiz=v0x_left(count_left)
+ veloc_vert=v0z_left(count_left)
+ traction_x_t0=t0x_left(count_left)
+ traction_z_t0=t0z_left(count_left)
+ count_left=count_left+1
+ end if
+ else
+ veloc_horiz = 0
+ veloc_vert = 0
+ traction_x_t0 = 0
+ traction_z_t0 = 0
+ endif
+
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+ ! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob) - veloc_horiz
+ vy = veloc_elastic(2,iglob)
+ vz = veloc_elastic(3,iglob) - veloc_vert
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ ty = rho_vs*vy
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz + traction_z_t0)*weight
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ if(p_sv)then !P-SV waves
+ b_absorb_elastic_left(1,j,ib_left(ispecabs),it) = tx*weight
+ b_absorb_elastic_left(3,j,ib_left(ispecabs),it) = tz*weight
+ else !SH (membrane) waves
+ b_absorb_elastic_left(2,j,ib_left(ispecabs),it) = ty*weight
+ endif
+ elseif(SIMULATION_TYPE == 2) then
+ if(p_sv)then !P-SV waves
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
+ b_absorb_elastic_left(1,j,ib_left(ispecabs),NSTEP-it+1)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
+ b_absorb_elastic_left(3,j,ib_left(ispecabs),NSTEP-it+1)
+ else !SH (membrane) waves
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
+ b_absorb_elastic_left(2,j,ib_left(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+ !--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+
+ i = NGLLX
+
+ do j = 1,NGLLZ
+
+ iglob = ibool(i,j,ispec)
+
+ ! for analytical initial plane wave for Bielak's conditions
+ ! left or right edge, horizontal normal vector
+ if(add_Bielak_conditions .and. initialfield) then
+ if (.not.over_critical_angle) then
+ call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = (lambdal_relaxed+2*mul_relaxed)*dxUx + lambdal_relaxed*dzUz
+ traction_z_t0 = mul_relaxed*(dxUz + dzUx)
+ else
+ veloc_horiz=v0x_right(count_right)
+ veloc_vert=v0z_right(count_right)
+ traction_x_t0=t0x_right(count_right)
+ traction_z_t0=t0z_right(count_right)
+ count_right=count_right+1
+ end if
+ else
+ veloc_horiz = 0
+ veloc_vert = 0
+ traction_x_t0 = 0
+ traction_z_t0 = 0
+ endif
+
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+ ! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob) - veloc_horiz
+ vy = veloc_elastic(2,iglob)
+ vz = veloc_elastic(3,iglob) - veloc_vert
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ ty = rho_vs*vy
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz - traction_z_t0)*weight
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ if(p_sv)then !P-SV waves
+ b_absorb_elastic_right(1,j,ib_right(ispecabs),it) = tx*weight
+ b_absorb_elastic_right(3,j,ib_right(ispecabs),it) = tz*weight
+ else! SH (membrane) waves
+ b_absorb_elastic_right(2,j,ib_right(ispecabs),it) = ty*weight
+ endif
+ elseif(SIMULATION_TYPE == 2) then
+ if(p_sv)then !P-SV waves
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
+ b_absorb_elastic_right(1,j,ib_right(ispecabs),NSTEP-it+1)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
+ b_absorb_elastic_right(3,j,ib_right(ispecabs),NSTEP-it+1)
+ else! SH (membrane) waves
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
+ b_absorb_elastic_right(2,j,ib_right(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of right absorbing boundary
+
+ !--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+
+ j = 1
+
+ ! exclude corners to make sure there is no contradiction on the normal
+ ibegin = 1
+ iend = NGLLX
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+ ! for analytical initial plane wave for Bielak's conditions
+ ! top or bottom edge, vertical normal vector
+ if(add_Bielak_conditions .and. initialfield) then
+ if (.not.over_critical_angle) then
+ call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = mul_relaxed*(dxUz + dzUx)
+ traction_z_t0 = lambdal_relaxed*dxUx + (lambdal_relaxed+2*mul_relaxed)*dzUz
+ else
+ veloc_horiz=v0x_bot(count_bottom)
+ veloc_vert=v0z_bot(count_bottom)
+ traction_x_t0=t0x_bot(count_bottom)
+ traction_z_t0=t0z_bot(count_bottom)
+ count_bottom=count_bottom+1
+ end if
+ else
+ veloc_horiz = 0
+ veloc_vert = 0
+ traction_x_t0 = 0
+ traction_z_t0 = 0
+ endif
+
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+ ! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob) - veloc_horiz
+ vy = veloc_elastic(2,iglob)
+ vz = veloc_elastic(3,iglob) - veloc_vert
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ ty = rho_vs*vy
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz + traction_z_t0)*weight
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ if(p_sv)then !P-SV waves
+ b_absorb_elastic_bottom(1,i,ib_bottom(ispecabs),it) = tx*weight
+ b_absorb_elastic_bottom(3,i,ib_bottom(ispecabs),it) = tz*weight
+ else!SH (membrane) waves
+ b_absorb_elastic_bottom(2,i,ib_bottom(ispecabs),it) = ty*weight
+ endif
+ elseif(SIMULATION_TYPE == 2) then
+ if(p_sv)then !P-SV waves
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
+ b_absorb_elastic_bottom(1,i,ib_bottom(ispecabs),NSTEP-it+1)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - &
+ b_absorb_elastic_bottom(3,i,ib_bottom(ispecabs),NSTEP-it+1)
+ else!SH (membrane) waves
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
+ b_absorb_elastic_bottom(2,i,ib_bottom(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of bottom absorbing boundary
+
+ !--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+
+ j = NGLLZ
+
+ ! exclude corners to make sure there is no contradiction on the normal
+ ibegin = 1
+ iend = NGLLX
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+ ! for analytical initial plane wave for Bielak's conditions
+ ! top or bottom edge, vertical normal vector
+ if(add_Bielak_conditions .and. initialfield) then
+ call compute_Bielak_conditions(coord,iglob,npoin,it,deltat,dxUx,dxUz,dzUx,dzUz,veloc_horiz,veloc_vert, &
+ x0_source, z0_source, A_plane, B_plane, C_plane, angleforce, angleforce_refl, &
+ c_inc, c_refl, time_offset,f0)
+ traction_x_t0 = mul_relaxed*(dxUz + dzUx)
+ traction_z_t0 = lambdal_relaxed*dxUx + (lambdal_relaxed+2*mul_relaxed)*dzUz
+ else
+ veloc_horiz = 0
+ veloc_vert = 0
+ traction_x_t0 = 0
+ traction_z_t0 = 0
+ endif
+
+ ! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+ ! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob) - veloc_horiz
+ vy = veloc_elastic(2,iglob)
+ vz = veloc_elastic(3,iglob) - veloc_vert
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ ty = rho_vs*vy
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - ty*weight
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - (tz - traction_z_t0)*weight
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1) then
+ if(p_sv)then !P-SV waves
+ b_absorb_elastic_top(1,i,ib_top(ispecabs),it) = tx*weight
+ b_absorb_elastic_top(3,i,ib_top(ispecabs),it) = tz*weight
+ else!SH (membrane) waves
+ b_absorb_elastic_top(2,i,ib_top(ispecabs),it) = ty*weight
+ endif
+ elseif(SIMULATION_TYPE == 2) then
+ if(p_sv)then !P-SV waves
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_top(1,i,ib_top(ispecabs),NSTEP-it+1)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - b_absorb_elastic_top(3,i,ib_top(ispecabs),NSTEP-it+1)
+ else!SH (membrane) waves
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_top(2,i,ib_top(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
+ endif
+
+ enddo
+
+ endif ! end of top absorbing boundary
+
+ enddo
+
+ endif ! end of absorbing boundaries
+
+ ! --- add the source if it is a moment tensor
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCES
+ ! if this processor carries the source and the source element is elastic
+ if (is_proc_source(i_source) == 1 .and. elastic(ispec_selected_source(i_source))) then
+
+ ! moment tensor
+ if(source_type(i_source) == 2) then
+
+ if(.not.p_sv) call exit_MPI('cannot have moment tensor source in SH (membrane) waves calculation')
+
+ if(SIMULATION_TYPE == 1) then ! forward wavefield
+ ! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) + &
+ sourcearray(i_source,1,i,j)*source_time_function(i_source,it)
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) + &
+ sourcearray(i_source,2,i,j)*source_time_function(i_source,it)
+ enddo
+ enddo
+ else ! backward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + &
+ sourcearray(i_source,1,i,j)*source_time_function(i_source,NSTEP-it+1)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) + &
+ sourcearray(i_source,2,i,j)*source_time_function(i_source,NSTEP-it+1)
+ enddo
+ enddo
+ endif !endif SIMULATION_TYPE == 1
+
+ endif !if(source_type(i_source) == 2)
+
+ endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCES
+
+ if(SIMULATION_TYPE == 2) then ! adjoint wavefield
+
+ irec_local = 0
+ do irec = 1,nrec
+ ! add the source (only if this proc carries the source)
+ if(myrank == which_proc_receiver(irec)) then
+
+ irec_local = irec_local + 1
+ if(elastic(ispec_selected_rec(irec))) then
+ ! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ if(p_sv)then !P-SH waves
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,3,i,j)
+ else !SH (membrane) waves
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,2,i,j)
+ endif
+ enddo
+ enddo
+ endif ! if element is elastic
+
+ endif ! if this processor carries the adjoint source and the source element is elastic
+ enddo ! irec = 1,nrec
+
+ endif ! if SIMULATION_TYPE == 2 adjoint wavefield
+
+ endif ! if not using an initial field
+
+ ! implement attenuation
+ if(TURN_ATTENUATION_ON) then
+
+ ! compute Grad(displ_elastic) at time step n+1 for attenuation
+ call compute_gradient_attenuation(displ_elastic,dux_dxl_np1,duz_dxl_np1, &
+ dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
+
+ ! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+ ! loop over spectral elements
+ do ispec = 1,nspec
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
+ theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
+
+ ! loop on all the standard linear solids
+ do i_sls = 1,N_SLS
+
+ ! evolution e1
+ Un = e1(i,j,ispec,i_sls)
+ tauinv = - inv_tau_sigma_nu1(i,j,ispec,i_sls)
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = theta_n * phi_nu1(i,j,ispec,i_sls)
+ Snp1 = theta_np1 * phi_nu1(i,j,ispec,i_sls)
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e1(i,j,ispec,i_sls) = Unp1
+
+ ! evolution e11
+ Un = e11(i,j,ispec,i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2(i,j,ispec,i_sls)
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e11(i,j,ispec,i_sls) = Unp1
+
+ ! evolution e13
+ Un = e13(i,j,ispec,i_sls)
+ tauinv = - inv_tau_sigma_nu2(i,j,ispec,i_sls)
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
+ Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2(i,j,ispec,i_sls)
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e13(i,j,ispec,i_sls) = Unp1
+
+ enddo
+
+ enddo
+ enddo
+ enddo
+
+ endif ! end of test on attenuation
+
+end subroutine compute_forces_viscoelastic
+
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_gradient_attenuation.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_gradient_attenuation.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_gradient_attenuation.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,126 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_gradient_attenuation(displ_elastic,dux_dxl,duz_dxl,dux_dzl,duz_dzl, &
+ xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
+
+! compute Grad(displ_elastic) for attenuation
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,npoin
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ logical, dimension(nspec) :: elastic
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(3,npoin) :: displ_elastic
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local variables
+ integer :: i,j,k,ispec
+
+! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+
+! jacobian
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+!---
+!--- elastic spectral element
+!---
+ if(elastic(ispec)) then
+
+! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of displacement
+ dux_dxl(i,j,ispec) = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl(i,j,ispec) = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl(i,j,ispec) = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl(i,j,ispec) = duz_dxi*xizl + duz_dgamma*gammazl
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+ end subroutine compute_gradient_attenuation
+
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_normal_vector.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_normal_vector.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_normal_vector.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_normal_vector.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,122 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine compute_normal_vector( angle, n1_x, n2_x, n3_x, n4_x, n1_z, n2_z, n3_z, n4_z )
+
+ implicit none
+
+ include 'constants.h'
+
+ double precision :: angle
+ double precision :: n1_x, n2_x, n3_x, n4_x, n1_z, n2_z, n3_z, n4_z
+
+ double precision :: theta1, theta2, theta3
+ double precision :: costheta1, costheta2, costheta3
+
+ if ( abs(n2_z - n1_z) < TINYVAL ) then
+ costheta1 = 0
+ else
+ costheta1 = (n2_z - n1_z) / sqrt((n2_x - n1_x)**2 + (n2_z - n1_z)**2)
+ endif
+ if ( abs(n3_z - n2_z) < TINYVAL ) then
+ costheta2 = 0
+ else
+ costheta2 = (n3_z - n2_z) / sqrt((n3_x - n2_x)**2 + (n3_z - n2_z)**2)
+ endif
+ if ( abs(n4_z - n3_z) < TINYVAL ) then
+ costheta3 = 0
+ else
+ costheta3 = (n4_z - n3_z) / sqrt((n4_x - n3_x)**2 + (n4_z - n3_z)**2)
+ endif
+
+ theta1 = - sign(1.d0,n2_x - n1_x) * acos(costheta1)
+ theta2 = - sign(1.d0,n3_x - n2_x) * acos(costheta2)
+ theta3 = - sign(1.d0,n4_x - n3_x) * acos(costheta3)
+
+ ! a sum is needed here because in the case of a source force vector
+ ! users can give an angle with respect to the normal to the topography surface,
+ ! in which case we must compute the normal to the topography
+ ! and add it the existing rotation angle
+ angle = angle + (theta1 + theta2 + theta3) / 3.d0 + PI/2.d0
+
+ end subroutine compute_normal_vector
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine tri_quad(n, n1, nnodes)
+
+ implicit none
+
+ integer :: n1, nnodes
+ integer, dimension(4) :: n
+
+
+ n(2) = n1
+
+ if ( n1 == 1 ) then
+ n(1) = nnodes
+ else
+ n(1) = n1-1
+ endif
+
+ if ( n1 == nnodes ) then
+ n(3) = 1
+ else
+ n(3) = n1+1
+ endif
+
+ if ( n(3) == nnodes ) then
+ n(4) = 1
+ else
+ n(4) = n(3)+1
+ endif
+
+
+ end subroutine tri_quad
+
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_pressure.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_pressure.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_pressure.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_pressure.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,493 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
+ npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,e1,e11, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
+
+! compute pressure in acoustic elements and in elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,npoin,numat
+
+
+ integer, dimension(nspec) :: kmato
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
+
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(6,numat) :: anisotropy
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ logical, dimension(nspec) :: elastic,poroelastic,anisotropic
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_dot_dot_acoustic
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
+
+ double precision, dimension(3,npoin) :: vector_field_display
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ logical :: assign_external_model,TURN_ATTENUATION_ON
+
+ integer :: N_SLS
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
+
+! local variables
+ integer :: i,j,ispec,iglob
+
+! pressure in this element
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+! compute pressure in this element
+ call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
+ npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
+
+! use vector_field_display as temporary storage, store pressure in its second component
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_display(3,iglob) = pressure_element(i,j)
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine compute_pressure_whole_medium
+
+!
+!=====================================================================
+!
+
+ subroutine compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
+ npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
+
+! compute pressure in acoustic elements and in elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,numat,ispec
+
+ integer, dimension(nspec) :: kmato
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
+
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(6,numat) :: anisotropy
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c15ext,c13ext,c33ext,c35ext,c55ext
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+! pressure in this element
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
+
+ logical, dimension(nspec) :: elastic,poroelastic,anisotropic
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_dot_dot_acoustic
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: displ_elastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: displs_poroelastic,displw_poroelastic
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ logical :: assign_external_model,TURN_ATTENUATION_ON
+
+ integer :: N_SLS
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11
+ real(kind=CUSTOM_REAL) :: e1_sum,e11_sum
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
+ integer :: i_sls
+
+! local variables
+ integer :: i,j,k,iglob
+
+! jacobian
+ real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl
+
+! spatial derivatives
+ real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_zz,sigmap
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dzl
+
+! material properties of the elastic medium
+ real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,denst
+ real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed,cpl,csl
+
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
+ real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
+
+! for anisotropy
+ double precision :: c11,c15,c13,c33,c35,c55
+
+! if elastic element
+!
+! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction,
+! J. Engrg. Mech., vol. 132(11), p. 1205-1214 (2006), below equation (5):
+! for a 3D isotropic solid, pressure is defined in terms of the trace of the stress tensor as
+! p = -1/3 (t11 + t22 + t33) where t is the Cauchy stress tensor.
+
+! to compute pressure in 3D in an elastic solid, one uses pressure = - trace(sigma) / 3
+! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
+! = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_ij
+! sigma_xx = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_xx
+! sigma_yy = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_yy
+! sigma_zz = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_zz
+! pressure = - trace(sigma) / 3 = - (lambda + 2/3 mu) trace(epsilon) = - kappa * trace(epsilon)
+!
+! to compute pressure in 2D in an elastic solid, one uses pressure = - trace(sigma) / 2
+! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
+! = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_ij
+! sigma_xx = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_xx
+! sigma_yy = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_yy
+! pressure = - trace(sigma) / 2 = - (lambda + mu) trace(epsilon)
+!
+
+
+ if(elastic(ispec)) then
+
+ ! get relaxed elastic parameters of current spectral element
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec))
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ !--- if external medium, get elastic parameters of current grid point
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ mul_relaxed = denst*csl*csl
+ lambdal_relaxed = denst*cpl*cpl - TWO*mul_relaxed
+ endif
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+! compute diagonal components of the stress tensor (include attenuation or anisotropy if needed)
+
+ if(TURN_ATTENUATION_ON) then
+
+! attenuation is implemented following the memory variable formulation of
+! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993). More details can be found in
+! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+ ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(i,j,ispec) &
+ - mul_relaxed * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_relaxed * Mu_nu2(i,j,ispec)
+ lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
+
+ ! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
+ sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
+
+ ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
+ ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
+ e1_sum = 0._CUSTOM_REAL
+ e11_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_SLS
+ e1_sum = e1_sum + e1(i,j,ispec,i_sls)
+ e11_sum = e11_sum + e11(i,j,ispec,i_sls)
+ enddo
+
+ sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum &
+ + TWO * mul_relaxed * e11_sum
+ sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum &
+ - TWO * mul_relaxed * e11_sum
+
+ else
+
+ ! no attenuation
+ sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
+ sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+
+ endif
+
+ ! full anisotropy
+ if(anisotropic(ispec)) then
+ if(assign_external_model) then
+ c11 = c11ext(i,j,ispec)
+ c15 = c15ext(i,j,ispec)
+ c13 = c13ext(i,j,ispec)
+ c33 = c33ext(i,j,ispec)
+ c35 = c35ext(i,j,ispec)
+ c55 = c55ext(i,j,ispec)
+ else
+ c11 = anisotropy(1,kmato(ispec))
+ c13 = anisotropy(2,kmato(ispec))
+ c15 = anisotropy(3,kmato(ispec))
+ c33 = anisotropy(4,kmato(ispec))
+ c35 = anisotropy(5,kmato(ispec))
+ c55 = anisotropy(6,kmato(ispec))
+ endif
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ ! implement anisotropy in 2D
+ sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
+ sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
+
+ endif
+
+ ! store pressure
+ pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
+
+ enddo
+ enddo
+
+ elseif(poroelastic(ispec)) then
+
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+
+ ! get poroelastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ !solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+ !fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ !frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+ !Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
+ + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ !where T = G:grad u_s + C div w I
+ !and T_f = C div u_s I + M div w I
+ !we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
+ mul_G = mul_fr
+ lambdal_G = H_biot - TWO*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+! compute diagonal components of the stress tensor (include attenuation if needed)
+
+ if(TURN_ATTENUATION_ON) then
+!-------------------- ATTENTION TO BE DEFINED ------------------------------!
+
+! attenuation is implemented following the memory variable formulation of
+! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993). More details can be found in
+! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+ ! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(i,j,ispec) &
+ - mul_relaxed * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_relaxed * Mu_nu2(i,j,ispec)
+ lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
+
+ ! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
+ sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
+
+ ! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
+ ! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
+ e1_sum = 0._CUSTOM_REAL
+ e11_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_SLS
+ e1_sum = e1_sum + e1(i,j,ispec,i_sls)
+ e11_sum = e11_sum + e11(i,j,ispec,i_sls)
+ enddo
+
+ sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum &
+ + TWO * mul_relaxed * e11_sum
+ sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum &
+ - TWO * mul_relaxed * e11_sum
+
+ else
+
+ ! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+ endif
+
+ ! store pressure
+ pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
+! pressure_element2(i,j) = - sigmap
+ enddo
+ enddo
+
+! pressure = - Chi_dot_dot if acoustic element
+ else
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ ! store pressure
+ pressure_element(i,j) = - potential_dot_dot_acoustic(iglob)
+
+ enddo
+ enddo
+
+ endif ! end of test if acoustic or elastic element
+
+ end subroutine compute_pressure_one_element
+
Copied: seismo/2D/SPECFEM2D/trunk/src/compute_vector_field.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/compute_vector_field.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/compute_vector_field.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,235 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine compute_vector_whole_medium(potential_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
+ nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+! compute Grad(potential) in acoustic elements
+! and combine with existing velocity vector field in elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,npoin,numat
+
+ logical :: assign_external_model
+ integer, dimension(nspec) :: kmato
+ double precision, dimension(NGLLX,NGLLX,nspec) :: rhoext
+ double precision, dimension(2,numat) :: density
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ logical, dimension(nspec) :: elastic,poroelastic
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: veloc_elastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: velocs_poroelastic
+
+ double precision, dimension(3,npoin) :: vector_field_display
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local variables
+ integer i,j,ispec,iglob
+
+! vector field in this element
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+! compute vector field in this element
+ call compute_vector_one_element(vector_field_element,potential_acoustic, &
+ veloc_elastic,velocs_poroelastic, &
+ elastic,poroelastic,xix,xiz,gammax,gammaz, &
+ ibool,hprime_xx,hprime_zz, &
+ nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ ispec,numat,kmato,density,rhoext,assign_external_model)
+
+! store the result
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_display(:,iglob) = vector_field_element(:,i,j)
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine compute_vector_whole_medium
+
+!
+!=====================================================================
+!
+
+ subroutine compute_vector_one_element(vector_field_element,potential_acoustic, &
+ veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,xix,xiz,gammax,gammaz, &
+ ibool,hprime_xx,hprime_zz, &
+ nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ ispec,numat,kmato,density,rhoext,assign_external_model)
+
+! compute Grad(potential) if acoustic element or copy existing vector if elastic element
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,ispec,numat
+
+ logical :: assign_external_model
+
+ integer, dimension(nspec) :: kmato
+
+ double precision, dimension(NGLLX,NGLLX,nspec) :: rhoext
+
+ double precision, dimension(2,numat) :: density
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+! vector field in this element
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
+
+ logical, dimension(nspec) :: elastic,poroelastic
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: potential_acoustic
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(3,npoin_elastic) :: veloc_elastic
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin_poroelastic) :: velocs_poroelastic
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local variables
+ integer i,j,k,iglob
+
+! space derivatives
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l
+ real(kind=CUSTOM_REAL) hp1,hp2
+
+! jacobian
+ real(kind=CUSTOM_REAL) xixl,xizl,gammaxl,gammazl
+
+! material properties of the elastic medium
+ real(kind=CUSTOM_REAL) :: rhol
+
+! simple copy of existing vector if elastic element
+ if(elastic(ispec)) then
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_element(1,i,j) = veloc_elastic(1,iglob)
+ vector_field_element(2,i,j) = veloc_elastic(2,iglob)
+ vector_field_element(3,i,j) = veloc_elastic(3,iglob)
+ enddo
+ enddo
+
+ elseif(poroelastic(ispec)) then
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_element(1,i,j) = velocs_poroelastic(1,iglob)
+ vector_field_element(2,i,j) = 0._CUSTOM_REAL
+ vector_field_element(3,i,j) = velocs_poroelastic(2,iglob)
+ enddo
+ enddo
+
+! compute gradient of potential to calculate vector if acoustic element
+! we then need to divide by density because the potential is a potential of (density * displacement)
+ else
+
+ rhol = density(1,kmato(ispec))
+
+! double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x
+ tempx1l = 0._CUSTOM_REAL
+ do k = 1,NGLLX
+ hp1 = hprime_xx(i,k)
+ iglob = ibool(k,j,ispec)
+ tempx1l = tempx1l + potential_acoustic(iglob)*hp1
+ enddo
+
+! derivative along z
+ tempx2l = 0._CUSTOM_REAL
+ do k = 1,NGLLZ
+ hp2 = hprime_zz(j,k)
+ iglob = ibool(i,k,ispec)
+ tempx2l = tempx2l + potential_acoustic(iglob)*hp2
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ if(assign_external_model) rhol = rhoext(i,j,ispec)
+
+! derivatives of potential
+ vector_field_element(1,i,j) = (tempx1l*xixl + tempx2l*gammaxl) / rhol
+ vector_field_element(2,i,j) = 0._CUSTOM_REAL
+ vector_field_element(3,i,j) = (tempx1l*xizl + tempx2l*gammazl) / rhol
+
+ enddo
+ enddo
+
+ endif ! end of test if acoustic or elastic element
+
+ end subroutine compute_vector_one_element
+
Copied: seismo/2D/SPECFEM2D/trunk/src/construct_acoustic_surface.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/construct_acoustic_surface.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/construct_acoustic_surface.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/construct_acoustic_surface.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,194 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! From array 'surface' (element, type : node/edge, node(s) ) that describes the
+! acoustic free surface, determines the points (ixmin, ixmax, izmin and izmax) on the surface
+! for each element.
+! We chose to have ixmin <= ixmax and izmin <= izmax, so as to be able to have DO loops on it with
+! an increment of +1.
+!
+subroutine construct_acoustic_surface ( nspec, ngnod, knods, nsurface, surface, tab_surface )
+
+ implicit none
+
+ integer, intent(in) :: nspec
+ integer, intent(in) :: ngnod
+ integer, dimension(ngnod,nspec), intent(in) :: knods
+ integer, intent(in) :: nsurface
+ integer, dimension(4,nsurface), intent(in) :: surface
+ integer, dimension(5,nsurface), intent(out) :: tab_surface
+
+ integer :: i, k
+ integer :: ixmin, ixmax
+ integer :: izmin, izmax
+ integer, dimension(ngnod) :: n
+ integer :: e1, e2
+ integer :: type
+
+ do i = 1, nsurface
+ tab_surface(1,i) = surface(1,i)
+ type = surface(2,i)
+ e1 = surface(3,i)
+ e2 = surface(4,i)
+ do k = 1, ngnod
+ n(k) = knods(k,tab_surface(1,i))
+ enddo
+
+ call get_acoustic_edge ( ngnod, n, type, e1, e2, ixmin, ixmax, izmin, izmax )
+
+ tab_surface(2,i) = ixmin
+ tab_surface(3,i) = ixmax
+ tab_surface(4,i) = izmin
+ tab_surface(5,i) = izmax
+
+ enddo
+
+end subroutine construct_acoustic_surface
+
+
+!-----------------------------------------------
+! Get the points (ixmin, ixmax, izmin and izmax) on an node/edge for one element.
+!-----------------------------------------------
+subroutine get_acoustic_edge ( ngnod, n, type, e1, e2, ixmin, ixmax, izmin, izmax )
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: ngnod
+ integer, dimension(ngnod), intent(in) :: n
+ integer, intent(in) :: type, e1, e2
+ integer, intent(out) :: ixmin, ixmax, izmin, izmax
+
+
+ if ( type == 1 ) then
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ ixmax = 1
+ izmin = 1
+ izmax = 1
+ endif
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ izmin = 1
+ izmax = 1
+ endif
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ izmin = NGLLZ
+ izmax = NGLLZ
+ endif
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ ixmax = 1
+ izmin = NGLLZ
+ izmax = NGLLZ
+ endif
+
+ else
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ izmin = 1
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ izmax = 1
+
+ endif
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ izmax = NGLLZ
+
+ endif
+ endif
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ izmin = 1
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ izmax = NGLLZ
+
+ endif
+ if ( e2 == n(1) ) then
+ ixmax = ixmin
+ ixmin = 1
+ izmax = 1
+
+ endif
+ endif
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ izmin = NGLLZ
+ if ( e2 == n(4) ) then
+ ixmax = ixmin
+ ixmin = 1
+ izmax = NGLLZ
+
+ endif
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ izmax = izmin
+ izmin = 1
+
+ endif
+ endif
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ izmin = NGLLZ
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ izmax = izmin
+ izmin = 1
+
+ endif
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ izmax = NGLLZ
+
+ endif
+ endif
+ endif
+
+end subroutine get_acoustic_edge
+
Copied: seismo/2D/SPECFEM2D/trunk/src/convert_time.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/convert_time.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/convert_time.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/convert_time.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,235 @@
+
+! open-source subroutines taken from the World Ocean Circulation Experiment (WOCE)
+! web site at http://www.coaps.fsu.edu/woce/html/wcdtools.htm
+
+! converted to Fortran90 by Dimitri Komatitsch,
+! University of Pau, France, January 2008.
+! Also converted "convtime" from a function to a subroutine.
+! Also used a more complete test to detect leap years (the original version was incomplete).
+
+ subroutine convtime(timestamp,yr,mon,day,hr,min)
+
+! Originally written by Shawn Smith (smith AT coaps.fsu.edu)
+! Updated Spring 1999 for Y2K compliance by Anthony Arguez (anthony AT coaps.fsu.edu).
+
+! This subroutine will convert a given year, month, day, hour, and
+! minutes to a minutes from 01 Jan 1980 00:00 time stamp.
+
+ implicit none
+
+ integer, intent(out) :: timestamp
+
+ integer, intent(in) :: yr,mon,day,hr,min
+
+ integer :: year(1980:2020),month(12),leap_mon(12)
+
+ integer :: min_day,min_hr
+
+! function to determine if year is a leap year
+ logical, external :: is_leap_year
+
+ data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
+ 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
+ 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
+ 9993600, 10519200, 11046240, 11571840, 12097440, &
+ 12623040, 13150080, 13675680, 14201280, 14726880, &
+ 15253920, 15779520, 16305120, 16830720, 17357760, &
+ 17883360, 18408960, 18934560, 19461600, 19987200, &
+ 20512800, 21038400/
+
+ data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
+ 305280, 349920, 393120, 437760, 480960/
+
+ data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
+ 306720, 351360, 394560, 439200, 482400/
+
+ data min_day, min_hr /1440, 60/
+
+! Test values to see if they fit valid ranges
+ if (yr < 1980 .or. yr > 2020) stop 'Error in convtime: year out of range (1980-2020)'
+
+ if (mon < 1 .or. mon > 12) stop 'Error in convtime: month out of range (1-12)'
+
+ if (mon == 2) then
+ if (is_leap_year(yr) .and. (day < 1 .or. day > 29)) then
+ stop 'Error in convtime: February day out of range (1-29)'
+ elseif (.not. is_leap_year(yr) .and. (day < 1 .or. day > 28)) then
+ stop 'Error in convtime: February day out of range (1-28)'
+ endif
+ elseif (mon == 4 .or. mon == 6 .or. mon == 9 .or. mon == 11) then
+ if (day < 1 .or. day > 30) stop 'Error in convtime: day out of range (1-30)'
+ else
+ if (day < 1 .or. day > 31) stop 'Error in convtime: day out of range (1-31)'
+ endif
+
+ if (hr < 0 .or. hr > 23) stop 'Error in convtime: hour out of range (0-23)'
+
+ if (min < 0 .or. min > 60) stop 'Error in convtime: minute out of range (0-60)'
+
+! convert time (test if leap year)
+ if (is_leap_year(yr)) then
+ timestamp = year(yr)+leap_mon(mon)+((day-1)*min_day)+(hr*min_hr)+min
+ else
+ timestamp = year(yr)+month(mon)+((day-1)*min_day)+(hr*min_hr)+min
+ endif
+
+ end subroutine convtime
+
+!
+!----
+!
+
+ subroutine invtime(timestamp,yr,mon,day,hr,min)
+
+! This subroutine will convert a minutes timestamp to a year/month
+! date. Based on the function convtime by Shawn Smith (COAPS).
+!
+! Written the spring of 1995, several iterations.
+! James N. Stricherz (stricherz AT coaps.fsu.edu)
+!
+! Updated for Y2K compliance in July 1999.
+! Shyam Lakshmin (lakshmin AT coaps.fsu.edu)
+!
+! This code returns correct results for the range of 01 Jan 1980 00:00
+! thru 31 Dec 2020 23:59. I know it does, because I tried each minute of that range.
+
+ implicit none
+
+ integer, intent(in) :: timestamp
+
+ integer, intent(out) :: yr,mon,day,hr,min
+
+ integer :: year(1980:2021),month(13),leap_mon(13)
+
+ integer :: min_day,min_hr,itime,tmon,ttime,thour,iyr,imon,iday,ihour
+
+! function to determine if year is a leap year
+ logical, external :: is_leap_year
+
+ data year /0, 527040, 1052640, 1578240, 2103840, 2630880, 3156480, &
+ 3682080, 4207680, 4734720, 5260320, 5785920, 6311520, &
+ 6838560, 7364160, 7889760, 8415360, 8942400, 9468000, &
+ 9993600, 10519200, 11046240, 11571840, 12097440, &
+ 12623040, 13150080, 13675680, 14201280, 14726880, &
+ 15253920, 15779520, 16305120, 16830720, 17357760, &
+ 17883360, 18408960, 18934560, 19461600, 19987200, &
+ 20512800, 21038400, 21565440/
+
+ data month /0, 44640, 84960, 129600, 172800, 217440, 260640, &
+ 305280, 349920, 393120, 437760, 480960,525600/
+
+ data leap_mon /0, 44640, 86400, 131040, 174240, 218880, 262080, &
+ 306720, 351360, 394560, 439200, 482400,527040/
+
+ data min_day, min_hr /1440, 60/
+
+! ok, let us invert the effects of the years: subtract off the
+! number of minutes per year until it goes negative
+! iyr then gives the year that the time (in minutes) occurs
+ if (timestamp >= year(2021)) stop 'year too high in invtime'
+
+ iyr=1979
+ itime=timestamp
+
+ 10 iyr=iyr+1
+ ttime=itime-year(iyr)
+ if (ttime <= 0) then
+ if (iyr == 1980) iyr=iyr+1
+ iyr=iyr-1
+ itime=itime-year(iyr)
+ else
+ goto 10
+ endif
+
+! assign the return variable
+ yr=iyr
+
+! ok, the remaining time is less than one full year, so convert
+! by the same method as above into months
+ imon=0
+
+! if not leap year
+ if (.not. is_leap_year(iyr)) then
+
+! increment the month, and subtract off the minutes from the
+! remaining time for a non-leap year
+ 20 imon=imon+1
+ tmon=itime-month(imon)
+ if (tmon > 0) then
+ goto 20
+ else if (tmon < 0) then
+ imon=imon-1
+ itime=itime-month(imon)
+ else
+ if (imon > 12) then
+ imon=imon-12
+ yr=yr+1
+ endif
+ mon=imon
+ day=1
+ hr=0
+ min=0
+ return
+ endif
+
+! if leap year
+ else
+
+! same thing, same code, but for a leap year
+ 30 imon=imon+1
+ tmon=itime-leap_mon(imon)
+ if (tmon > 0) then
+ goto 30
+ elseif (tmon < 0) then
+ imon=imon-1
+ itime=itime-month(imon)
+ else
+ if (imon > 12) then
+ imon=imon-12
+ yr=yr+1
+ endif
+ mon=imon
+ day=1
+ hr=0
+ min=0
+ return
+ endif
+ endif
+
+! assign the return variable
+ mon=imon
+
+! any remaining minutes will belong to day/hour/minutes
+! ok, let us get the days
+ iday=0
+ 40 iday=iday+1
+ ttime=itime-min_day
+ if (ttime >= 0) then
+ itime=ttime
+ goto 40
+ endif
+
+! assign the return variable
+ if (is_leap_year(iyr) .and. mon > 2) then
+ day=iday-1
+ else
+ day=iday
+ endif
+
+! pick off the hours of the days...remember, hours can be 0, so we start at -1
+ ihour=-1
+ 50 ihour=ihour+1
+ thour=itime-min_hr
+ if (thour >= 0) then
+ itime=thour
+ goto 50
+ endif
+
+! assign the return variables
+ hr=ihour
+
+! the remainder at this point is the minutes, so return them directly
+ min=itime
+
+ end subroutine invtime
+
Copied: seismo/2D/SPECFEM2D/trunk/src/convolve_source_timefunction.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/convolve_source_timefunction.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/convolve_source_timefunction.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,152 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ program convolve_source_time_function
+
+!
+! convolve seismograms computed for a Heaviside with given source time function
+!
+
+! we mimic a triangle of half duration equal to half_duration_triangle
+! using a Gaussian having a very close shape, as explained in Figure 4.2
+! of the manual
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: i,j,N_j,number_remove,nlines
+
+ double precision :: alpha,dt,tau_j,source,exponent,t1,t2,displ1,displ2,gamma,height,half_duration_triangle
+
+ logical :: triangle
+
+ double precision, dimension(:), allocatable :: time,sem,sem_fil
+
+! read file with number of lines in input
+ open(unit=33,file='input_convolve_code.txt',status='old',action='read')
+ read(33,*) nlines
+ read(33,*) half_duration_triangle
+ read(33,*) triangle
+ close(33)
+
+! allocate arrays
+ allocate(time(nlines),sem(nlines),sem_fil(nlines))
+
+! read the input seismogram
+ do i = 1,nlines
+ read(5,*) time(i),sem(i)
+ enddo
+
+! define a Gaussian with the right exponent to mimic a triangle of equivalent half duration
+ alpha = SOURCE_DECAY_MIMIC_TRIANGLE/half_duration_triangle
+
+! compute the time step
+ dt = time(2) - time(1)
+
+! number of integers for which the source wavelet is different from zero
+ if(triangle) then
+ N_j = ceiling(half_duration_triangle/dt)
+ else
+ N_j = ceiling(1.5d0*half_duration_triangle/dt)
+ endif
+
+ do i = 1,nlines
+
+ sem_fil(i) = 0.d0
+
+ do j = -N_j,N_j
+
+ if(i > j .and. i-j <= nlines) then
+
+ tau_j = dble(j)*dt
+
+! convolve with a triangle
+ if(triangle) then
+ height = 1.d0 / half_duration_triangle
+ if(abs(tau_j) > half_duration_triangle) then
+ source = 0.d0
+ else if (tau_j < 0.d0) then
+ t1 = - N_j * dt
+ displ1 = 0.d0
+ t2 = 0.d0
+ displ2 = height
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1.d0 - gamma) * displ1 + gamma * displ2
+ else
+ t1 = 0.d0
+ displ1 = height
+ t2 = + N_j * dt
+ displ2 = 0.d0
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1.d0 - gamma) * displ1 + gamma * displ2
+ endif
+
+ else
+
+! convolve with a Gaussian
+ exponent = alpha**2 * tau_j**2
+ if(exponent < 50.d0) then
+ source = alpha*exp(-exponent)/sqrt(PI)
+ else
+ source = 0.d0
+ endif
+
+ endif
+
+ sem_fil(i) = sem_fil(i) + sem(i-j)*source*dt
+
+ endif
+
+ enddo
+ enddo
+
+! compute number of samples to remove from end of seismograms
+ number_remove = N_j + 1
+ do i=1,nlines - number_remove
+ write(*,*) sngl(time(i)),' ',sngl(sem_fil(i))
+ enddo
+
+ end program convolve_source_time_function
+
Copied: seismo/2D/SPECFEM2D/trunk/src/create_color_image.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/create_color_image.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/create_color_image.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/create_color_image.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,267 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine create_color_image(color_image_2D_data,iglob_image_color_2D, &
+ NX,NY,it,cutsnaps,image_color_vp_display)
+
+! display a given field as a red and blue color image
+
+! to display the snapshots : display image*.gif
+
+! when compiling with Intel ifort, use " -assume byterecl " option to create binary PNM images
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NX,NY,it
+
+ double precision :: cutsnaps
+
+ integer, dimension(NX,NY) :: iglob_image_color_2D
+
+ double precision, dimension(NX,NY) :: color_image_2D_data
+ double precision, dimension(NX,NY) :: image_color_vp_display
+
+ integer :: ix,iy,R,G,B,tenthousands,thousands,hundreds,tens,units,remainder,current_rec
+
+ double precision :: amplitude_max,normalized_value,vpmin,vpmax,x1
+
+ character(len=100) :: file_name,system_command
+
+! create temporary image files in binary PNM P6 format (smaller) or ASCII PNM P3 format (easier to edit)
+ logical, parameter :: BINARY_FILE = .true.
+
+! ASCII code of character '0' and of carriage return character
+ integer, parameter :: ascii_code_of_zero = 48, ascii_code_of_carriage_return = 10
+
+! open the image file
+ write(file_name,"('OUTPUT_FILES/image',i7.7,'.pnm')") it
+
+ if(BINARY_FILE) then
+
+ open(unit=27,file=file_name,status='unknown',access='direct',recl=1)
+ write(27,rec=1) 'P'
+ write(27,rec=2) '6' ! write P6 = binary PNM image format
+ write(27,rec=3) char(ascii_code_of_carriage_return)
+
+! compute and write horizontal size
+ remainder = NX
+
+ tenthousands = remainder / 10000
+ remainder = remainder - 10000 * tenthousands
+
+ thousands = remainder / 1000
+ remainder = remainder - 1000 * thousands
+
+ hundreds = remainder / 100
+ remainder = remainder - 100 * hundreds
+
+ tens = remainder / 10
+ remainder = remainder - 10 * tens
+
+ units = remainder
+
+ write(27,rec=4) char(tenthousands + ascii_code_of_zero)
+ write(27,rec=5) char(thousands + ascii_code_of_zero)
+ write(27,rec=6) char(hundreds + ascii_code_of_zero)
+ write(27,rec=7) char(tens + ascii_code_of_zero)
+ write(27,rec=8) char(units + ascii_code_of_zero)
+ write(27,rec=9) ' '
+
+! compute and write vertical size
+ remainder = NY
+
+ tenthousands = remainder / 10000
+ remainder = remainder - 10000 * tenthousands
+
+ thousands = remainder / 1000
+ remainder = remainder - 1000 * thousands
+
+ hundreds = remainder / 100
+ remainder = remainder - 100 * hundreds
+
+ tens = remainder / 10
+ remainder = remainder - 10 * tens
+
+ units = remainder
+
+ write(27,rec=10) char(tenthousands + ascii_code_of_zero)
+ write(27,rec=11) char(thousands + ascii_code_of_zero)
+ write(27,rec=12) char(hundreds + ascii_code_of_zero)
+ write(27,rec=13) char(tens + ascii_code_of_zero)
+ write(27,rec=14) char(units + ascii_code_of_zero)
+ write(27,rec=15) char(ascii_code_of_carriage_return)
+
+! number of shades
+ write(27,rec=16) '2'
+ write(27,rec=17) '5'
+ write(27,rec=18) '5'
+ write(27,rec=19) char(ascii_code_of_carriage_return)
+
+! block of image data starts at sixteenth character
+ current_rec = 20
+
+ else
+
+ open(unit=27,file=file_name,status='unknown')
+ write(27,"('P3')") ! write P3 = ASCII PNM image format
+ write(27,*) NX,NY ! write image size
+ write(27,*) '255' ! number of shades
+
+ endif
+
+! compute maximum amplitude
+ amplitude_max = maxval(abs(color_image_2D_data))
+ vpmin = HUGEVAL
+ vpmax = TINYVAL
+ do iy=1,NY
+ do ix=1,NX
+ if ( iglob_image_color_2D(ix,iy) > -1 ) then
+ vpmin = min(vpmin,image_color_vp_display(ix,iy))
+ vpmax = max(vpmax,image_color_vp_display(ix,iy))
+ endif
+
+ enddo
+ enddo
+
+! in the PNM format, the image starts in the upper-left corner
+ do iy=NY,1,-1
+ do ix=1,NX
+
+! check if pixel is defined or not (can be above topography for instance)
+ if(iglob_image_color_2D(ix,iy) == -1) then
+
+! use light blue to display undefined region above topography
+ R = 204
+ G = 255
+ B = 255
+
+! suppress small amplitudes considered as noise
+ else if (abs(color_image_2D_data(ix,iy)) < amplitude_max * cutsnaps) then
+
+! use P velocity model as background where amplitude is negligible
+ if((vpmax-vpmin)/vpmin > 0.02d0) then
+ x1 = (image_color_vp_display(ix,iy)-vpmin)/(vpmax-vpmin)
+ else
+ x1 = 0.5d0
+ endif
+
+! rescale to avoid very dark gray levels
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+! invert scale: white = vpmin, dark gray = vpmax
+ x1 = 1.d0 - x1
+
+! map to [0,255]
+ x1 = x1 * 255.d0
+
+ R = nint(x1)
+ if(R < 0) R = 0
+ if(R > 255) R = 255
+ G = R
+ B = R
+
+ else
+
+! define normalized image data in [-1:1] and convert to nearest integer
+! keeping in mind that data values can be negative
+ normalized_value = color_image_2D_data(ix,iy) / amplitude_max
+
+! suppress values outside of [-1:+1]
+ if(normalized_value < -1.d0) normalized_value = -1.d0
+ if(normalized_value > 1.d0) normalized_value = 1.d0
+
+! use red if positive value, blue if negative, no green
+ if(normalized_value >= 0.d0) then
+ R = nint(255.d0*normalized_value**POWER_DISPLAY_COLOR)
+ G = 0
+ B = 0
+ else
+ R = 0
+ G = 0
+ B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY_COLOR)
+ endif
+
+ endif
+
+! write color image
+ if(BINARY_FILE) then
+
+! first write red
+ write(27,rec=current_rec) char(R)
+ current_rec = current_rec + 1
+
+! then write green
+ write(27,rec=current_rec) char(G)
+ current_rec = current_rec + 1
+
+! then write blue
+ write(27,rec=current_rec) char(B)
+ current_rec = current_rec + 1
+
+ else
+
+ write(27,"(i3,' ',i3,' ',i3)") R,G,B
+
+ endif
+
+ enddo
+ enddo
+
+! close the file
+ close(27)
+
+! open image file and create system command to convert image to more convenient format
+! use the "convert" command from ImageMagick http://www.imagemagick.org
+ write(system_command,"('cd OUTPUT_FILES ; convert image',i7.7,'.pnm image',i7.7,'.gif ; rm -f image',i7.7,'.pnm')") it,it,it
+
+! call the system to convert image to GIF
+! this line can be safely commented out if your compiler does not implement "system()" for system calls;
+! in such a case you will simply get images in PNM format in directory OUTPUT_FILES instead of GIF format
+ call system(system_command)
+
+ end subroutine create_color_image
+
Copied: seismo/2D/SPECFEM2D/trunk/src/createnum_fast.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/createnum_fast.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/createnum_fast.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/createnum_fast.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,343 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
+
+! same as subroutine "createnum_slow" but with a faster algorithm
+
+ implicit none
+
+ include "constants.h"
+
+ integer npoin,npgeo,nspec,ngnod,myrank,ipass
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
+ double precision shape(ngnod,NGLLX,NGLLX)
+ double precision coorg(NDIM,npgeo)
+
+ integer i,j
+
+! additional arrays needed for this fast version
+ integer, dimension(:), allocatable :: loc,ind,ninseg,iglob,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: xp,yp,work
+
+ integer ie,nseg,ioff,iseg,ig
+ integer nxyz,ntot,ispec,ieoff,ilocnum,iy,ix,in,nnum
+
+ double precision xmaxval,xminval,ymaxval,yminval,xtol,xtypdist
+ double precision xcor,ycor
+
+
+!---- create global mesh numbering
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,*) 'Generating global mesh numbering (fast version)...'
+ write(IOUT,*)
+ endif
+
+ nxyz = NGLLX*NGLLZ
+ ntot = nxyz*nspec
+
+ allocate(loc(ntot))
+ allocate(ind(ntot))
+ allocate(ninseg(ntot))
+ allocate(iglob(ntot))
+ allocate(ifseg(ntot))
+ allocate(xp(ntot))
+ allocate(yp(ntot))
+ allocate(work(ntot))
+ allocate(iwork(ntot))
+
+! compute coordinates of the grid points
+ do ispec=1,nspec
+ ieoff = nxyz*(ispec - 1)
+ ilocnum = 0
+
+ do iy = 1,NGLLX
+ do ix = 1,NGLLX
+
+ ilocnum = ilocnum + 1
+
+ xcor = zero
+ ycor = zero
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xcor = xcor + shape(in,ix,iy)*coorg(1,nnum)
+ ycor = ycor + shape(in,ix,iy)*coorg(2,nnum)
+ enddo
+
+ xp(ilocnum + ieoff) = xcor
+ yp(ilocnum + ieoff) = ycor
+
+ enddo
+ enddo
+
+ enddo
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+! Establish initial pointers
+ do ie=1,nspec
+ ieoff = nxyz*(ie -1)
+ do ix=1,nxyz
+ loc (ix+ieoff) = ix+ieoff
+ enddo
+ enddo
+
+! set up local geometric tolerances
+
+ xtypdist=+HUGEVAL
+
+ do ie=1,nspec
+
+ xminval=+HUGEVAL
+ yminval=+HUGEVAL
+ xmaxval=-HUGEVAL
+ ymaxval=-HUGEVAL
+ ieoff=nxyz*(ie-1)
+ do ilocnum=1,nxyz
+ xmaxval=max(xp(ieoff+ilocnum),xmaxval)
+ xminval=min(xp(ieoff+ilocnum),xminval)
+ ymaxval=max(yp(ieoff+ilocnum),ymaxval)
+ yminval=min(yp(ieoff+ilocnum),yminval)
+ enddo
+
+! compute the minimum typical "size" of an element in the mesh
+ xtypdist = min(xtypdist,xmaxval-xminval)
+ xtypdist = min(xtypdist,ymaxval-yminval)
+
+ enddo
+
+! define a tolerance, small with respect to the minimum size
+ xtol = SMALLVALTOL * xtypdist
+
+ ifseg(:) = .false.
+ nseg = 1
+ ifseg(1) = .true.
+ ninseg(1) = ntot
+
+ do j=1,NDIM
+! Sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+ call rank (xp(ioff),ind,ninseg(iseg))
+ else
+ call rank (yp(ioff),ind,ninseg(iseg))
+ endif
+ call swap(xp(ioff),work,ind,ninseg(iseg))
+ call swap(yp(ioff),work,ind,ninseg(iseg))
+ call iswap(loc(ioff),iwork,ind,ninseg(iseg))
+ ioff=ioff+ninseg(iseg)
+ enddo
+! Check for jumps in current coordinate
+ if (j == 1) then
+ do i=2,ntot
+ if (abs(xp(i)-xp(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else
+ do i=2,ntot
+ if (abs(yp(i)-yp(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ endif
+! Count up number of different segments
+ nseg = 0
+ do i=1,ntot
+ if (ifseg(i)) then
+ nseg = nseg+1
+ ninseg(nseg) = 1
+ else
+ ninseg(nseg) = ninseg(nseg) + 1
+ endif
+ enddo
+ enddo
+!
+! Assign global node numbers (now sorted lexicographically!)
+!
+ ig = 0
+ do i=1,ntot
+ if (ifseg(i)) ig=ig+1
+ iglob(loc(i)) = ig
+ enddo
+
+ npoin = ig
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+! get result in my format
+ do ispec=1,nspec
+ ieoff = nxyz*(ispec - 1)
+ ilocnum = 0
+ do iy = 1,NGLLX
+ do ix = 1,NGLLX
+ ilocnum = ilocnum + 1
+ ibool(ix,iy,ispec) = iglob(ilocnum + ieoff)
+ enddo
+ enddo
+ enddo
+
+ deallocate(loc)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(ifseg)
+ deallocate(xp)
+ deallocate(yp)
+ deallocate(work)
+ deallocate(iwork)
+
+! check the numbering obtained
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) call exit_MPI('Error while generating global numbering')
+
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Total number of points of the global mesh: ',npoin
+ write(IOUT,*)
+ endif
+
+ end subroutine createnum_fast
+
+
+!-----------------------------------------------------------------------
+
+ subroutine rank(A,IND,N)
+!
+! Use Heap Sort (p 233 Numerical Recipes)
+!
+ implicit none
+
+ integer N
+ double precision A(N)
+ integer IND(N)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do J=1,N
+ IND(j)=j
+ enddo
+
+ if(n == 1) return
+ L=n/2+1
+ ir=n
+ 100 continue
+ IF(l > 1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if(ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 continue
+ IF(J <= IR) THEN
+ IF(J < IR) THEN
+ IF(A(IND(j)) < A(IND(j+1))) j=j+1
+ ENDIF
+ IF(q < A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ GOTO 200
+ ENDIF
+ IND(I)=INDX
+ GOTO 100
+
+ end subroutine rank
+
+!-----------------------------------------------------------------------
+
+ subroutine swap(a,w,ind,n)
+!
+! Use IND to sort array A (p 233 Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(N),W(N)
+ integer IND(N)
+
+ integer j
+
+ W(:) = A(:)
+
+ do J=1,N
+ A(j) = W(ind(j))
+ enddo
+
+ end subroutine swap
+
+!-----------------------------------------------------------------------
+
+ subroutine iswap(a,w,ind,n)
+!
+! Use IND to sort array A
+!
+ implicit none
+
+ integer n
+ integer A(N),W(N),IND(N)
+
+ integer j
+
+ W(:) = A(:)
+
+ do J=1,N
+ A(j) = W(ind(j))
+ enddo
+
+ end subroutine iswap
+
Copied: seismo/2D/SPECFEM2D/trunk/src/createnum_slow.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/createnum_slow.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/createnum_slow.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/createnum_slow.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,324 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
+
+! generate the global numbering
+
+ implicit none
+
+ include "constants.h"
+
+ integer npoin,nspec,ngnod,myrank,ipass
+
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
+
+ integer i,j,num2,i2,j2,ipos,ipos2,iloc,jloc,kloc
+ integer ngnodloc,ngnodother,nedgeloc,nedgeother,npedge,numelem,npcorn
+
+ logical alreadyexist
+
+ integer, dimension(NEDGES) :: ngnod_begin,ngnod_end
+
+
+!---- create global mesh numbering
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Generating global mesh numbering (slow version)...'
+ write(IOUT,*)
+ endif
+
+ npoin = 0
+ npedge = 0
+ npcorn = 0
+
+! define edges from the four control points
+
+! --- edge 1 linking point 1 to point 2
+ ngnod_begin(1)= 1
+ ngnod_end(1)= 2
+
+! --- edge 2 linking point 2 to point 3
+ ngnod_begin(2)= 2
+ ngnod_end(2)= 3
+
+! --- edge 3 linking point 3 to point 4
+ ngnod_begin(3)= 3
+ ngnod_end(3)= 4
+
+! --- edge 4 linking point 4 to point 1
+ ngnod_begin(4)= 4
+ ngnod_end(4)= 1
+
+! initialisation du tableau de numerotation globale
+ ibool(:,:,:) = 0
+
+ do numelem = 1,nspec
+ do i=1,NGLLX
+ do j=1,NGLLZ
+
+! verifier que le point n'a pas deja ete genere
+
+ if(ibool(i,j,numelem) == 0) then
+
+!
+!---- point interieur a un element, donc forcement unique
+!
+ if(i /= 1 .and. i /= NGLLX .and. j /= 1 .and. j /= NGLLZ) then
+
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+
+!
+!---- point au coin d'un element, rechercher les coins des autres elements
+!
+ else if((i == 1 .and. j == 1) .or. (i == 1 .and. j == NGLLZ) .or. &
+ (i == NGLLX .and. j == 1) .or. (i == NGLLX .and. j == NGLLZ)) then
+
+! trouver numero local du coin
+ if(i == 1 .and. j == 1) then
+ ngnodloc = 1
+ else if(i == NGLLX .and. j == 1) then
+ ngnodloc = 2
+ else if(i == NGLLX .and. j == NGLLZ) then
+ ngnodloc = 3
+ else if(i == 1 .and. j == NGLLZ) then
+ ngnodloc = 4
+ endif
+
+! rechercher si existe deja, forcement dans un element precedent
+
+ alreadyexist = .false.
+
+ if(numelem > 1) then
+
+ do num2=1,numelem-1
+
+! ne rechercher que sur les 4 premiers points de controle et non sur ngnod
+ do ngnodother=1,4
+
+! voir si ce coin a deja ete genere
+ if(knods(ngnodother,num2) == knods(ngnodloc,numelem)) then
+ alreadyexist = .true.
+
+! obtenir la numerotation dans l'autre element
+ if(ngnodother == 1) then
+ i2 = 1
+ j2 = 1
+ else if(ngnodother == 2) then
+ i2 = NGLLX
+ j2 = 1
+ else if(ngnodother == 3) then
+ i2 = NGLLX
+ j2 = NGLLZ
+ else if(ngnodother == 4) then
+ i2 = 1
+ j2 = NGLLZ
+ else
+ call exit_MPI('bad corner')
+ endif
+
+! affecter le meme numero
+ ibool(i,j,numelem) = ibool(i2,j2,num2)
+
+! sortir de la recherche
+ goto 134
+
+ endif
+ enddo
+ enddo
+
+ 134 continue
+
+ endif
+
+! si un ancien point n'a pas ete trouve, en generer un nouveau
+ if(.not. alreadyexist) then
+ npcorn = npcorn + 1
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+ endif
+
+!
+!---- point a l'interieur d'une arete, rechercher si autre arete correspondante
+!
+ else
+
+! trouver numero local de l'arete
+ if(j == 1) then
+ nedgeloc = 1
+ else if(i == NGLLX) then
+ nedgeloc = 2
+ else if(j == NGLLZ) then
+ nedgeloc = 3
+ else if(i == 1) then
+ nedgeloc = 4
+ endif
+
+! rechercher si existe deja, forcement dans un element precedent
+
+ alreadyexist = .false.
+
+ if(numelem > 1) then
+
+ do num2=1,numelem-1
+
+! rechercher sur les 4 aretes
+ do nedgeother=1,4
+
+!--- detecter un eventuel defaut dans la structure topologique du maillage
+
+ if((knods(ngnod_begin(nedgeother),num2) == knods(ngnod_begin(nedgeloc),numelem)) &
+ .and. &
+ (knods(ngnod_end(nedgeother),num2) == knods(ngnod_end(nedgeloc),numelem))) then
+ call exit_MPI('Improper topology of the input mesh detected')
+
+!--- sinon voir si cette arete a deja ete generee
+
+ else if((knods(ngnod_begin(nedgeother),num2) == knods(ngnod_end(nedgeloc),numelem)) &
+ .and. &
+ (knods(ngnod_end(nedgeother),num2) == knods(ngnod_begin(nedgeloc),numelem))) then
+
+ alreadyexist = .true.
+
+! obtenir la numerotation dans l'autre element
+! maillage conforme donc on doit supposer que NGLLX == NGLLZ
+
+! generer toute l'arete pour eviter des recherches superflues
+ do kloc = 2,NGLLX-1
+
+! calculer l'abscisse le long de l'arete de depart
+ if(nedgeloc == 1) then
+ iloc = kloc
+ jloc = 1
+ ipos = iloc
+ else if(nedgeloc == 2) then
+ iloc = NGLLX
+ jloc = kloc
+ ipos = jloc
+ else if(nedgeloc == 3) then
+ iloc = kloc
+ jloc = NGLLZ
+ ipos = NGLLX - iloc + 1
+ else if(nedgeloc == 4) then
+ iloc = 1
+ jloc = kloc
+ ipos = NGLLZ - jloc + 1
+ else
+ call exit_MPI('bad nedgeloc')
+ endif
+
+! calculer l'abscisse le long de l'arete d'arrivee
+! topologie du maillage coherente, donc sens de parcours des aretes opposes
+
+ ipos2 = NGLLX - ipos + 1
+
+! calculer les coordonnees reelles dans l'element d'arrivee
+ if(nedgeother == 1) then
+ i2 = ipos2
+ j2 = 1
+ else if(nedgeother == 2) then
+ i2 = NGLLX
+ j2 = ipos2
+ else if(nedgeother == 3) then
+ i2 = NGLLX - ipos2 + 1
+ j2 = NGLLZ
+ else if(nedgeother == 4) then
+ i2 = 1
+ j2 = NGLLZ - ipos2 + 1
+ else
+ call exit_MPI('bad nedgeother')
+ endif
+
+! verifier que le point de depart n'existe pas deja
+ if(ibool(iloc,jloc,numelem) /= 0) call exit_MPI('point generated twice')
+
+! verifier que le point d'arrivee existe bien deja
+ if(ibool(i2,j2,num2) == 0) call exit_MPI('unknown point in the mesh')
+
+! affecter le meme numero
+ ibool(iloc,jloc,numelem) = ibool(i2,j2,num2)
+
+ enddo
+
+! sortir de la recherche
+ goto 135
+
+ endif
+ enddo
+ enddo
+
+ 135 continue
+
+ endif
+
+! si un ancien point n'a pas ete trouve, en generer un nouveau
+ if(.not. alreadyexist) then
+ npedge = npedge + 1
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+ endif
+
+ endif
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! verification de la coherence de la numerotation generee
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) call exit_MPI('Error while generating global numbering')
+
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*) 'Total number of points of the global mesh: ',npoin,' distributed as follows:'
+ write(IOUT,*)
+ write(IOUT,*) 'Number of interior points: ',npoin-npedge-npcorn
+ write(IOUT,*) 'Number of edge points (without corners): ',npedge
+ write(IOUT,*) 'Number of corner points: ',npcorn
+ write(IOUT,*)
+ endif
+
+ end subroutine createnum_slow
+
Copied: seismo/2D/SPECFEM2D/trunk/src/datim.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/datim.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/datim.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/datim.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,72 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine datim(string_input)
+
+! get date and time
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=50) string_input
+ character(len=8) datein
+ character(len=10) timein
+ character(len=16) dateprint
+ character(len=8) timeprint
+
+ datein = ' '
+ timein = ' '
+
+ call date_and_time(datein,timein)
+
+ dateprint = datein(7:8)//' - '//datein(5:6)//' - '//datein(1:4)
+ timeprint = timein(1:2)//':'//timein(3:4)//':'//timein(5:6)
+
+ write(iout,"(//1x,79('-')/1x,79('-')/1x,'Program SPECFEM2D: ')")
+ write(iout,"(1x,79('-')/1x,79('-')/1x,a50)") string_input
+ write(iout,"(1x,79('-')/,1x,79('-')/' D a t e : ',a16,30x,' T i m e : ',a8/1x,79('-'),/1x,79('-'))") dateprint,timeprint
+
+ end subroutine datim
+
Copied: seismo/2D/SPECFEM2D/trunk/src/define_derivation_matrices.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/define_derivation_matrices.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/define_derivation_matrices.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/define_derivation_matrices.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,94 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
+
+ implicit none
+
+ include "constants.h"
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+! weights
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLZ) :: wzgll
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+! function for calculating derivatives of Lagrange polynomials
+ double precision, external :: lagrange_deriv_GLL
+
+ integer i1,i2,k1,k2
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly zero
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! calculate derivatives of the Lagrange polynomials
+! and precalculate some products in double precision
+! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
+ do i1=1,NGLLX
+ do i2=1,NGLLX
+ hprime_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)
+ hprimewgll_xx(i2,i1) = wxgll(i2) * hprime_xx(i2,i1)
+ enddo
+ enddo
+
+ do k1=1,NGLLZ
+ do k2=1,NGLLZ
+ hprime_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)
+ hprimewgll_zz(k2,k1) = wzgll(k2) * hprime_zz(k2,k1)
+ enddo
+ enddo
+
+ end subroutine define_derivation_matrices
+
Copied: seismo/2D/SPECFEM2D/trunk/src/define_external_model.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/define_external_model.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/define_external_model.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/define_external_model.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,91 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine define_external_model(x,y,iflag_element,myrank,rho,vp,vs,Qp_attenuation,&
+ Qs_attenuation,c11,c13,c15,c33,c35,c55 )
+
+ implicit none
+
+ include "constants.h"
+
+! user can modify this routine to assign any different external Earth model (rho, vp, vs)
+! based on the x and y coordinates of that grid point and the flag of the region it belongs to
+
+ integer, intent(in) :: iflag_element,myrank
+
+ double precision, intent(in) :: x,y
+
+ double precision, intent(out) :: rho,vp,vs
+ double precision, intent(out) :: Qp_attenuation,Qs_attenuation
+ double precision, intent(out) :: c11,c15,c13,c33,c35,c55
+
+! dummy routine here, just to demonstrate how the model can be assigned
+ if(myrank == 0 .and. iflag_element == 1 .or. x < 1700.d0 .or. y >= 2300.d0) then
+ rho = 2000.d0
+ vp = 3000.d0
+ vs = vp / sqrt(3.d0)
+ Qp_attenuation = 0
+ Qs_attenuation = 0
+ c11 = 169.d9
+ c13 = 122.d9
+ c15 = 0.d0
+ c33 = c11
+ c35 = 0.d0
+ c55 = 75.3d9
+ else
+ rho = 2500.d0
+ vp = 3600.d0
+ vs = vp / 2.d0
+ Qp_attenuation = 60
+ Qs_attenuation = 60
+ c11 = 0.d0
+ c13 = 0.d0
+ c15 = 0.d0
+ c33 = 0.d0
+ c35 = 0.d0
+ c55 = 0.d0
+ endif
+
+ end subroutine define_external_model
Copied: seismo/2D/SPECFEM2D/trunk/src/define_shape_functions.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/define_shape_functions.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/define_shape_functions.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,170 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)
+
+!=======================================================================
+!
+! Set up the shape functions for the subparametric transformation.
+! The routine can handle 4 or 9 control nodes defined as follows:
+!
+! 4 . . . . 7 . . . . 3
+! . .
+! . t .
+! . .
+! 8 9 s 6
+! . .
+! . .
+! . .
+! 1 . . . . 5 . . . . 2
+!
+! Local coordinate system : s,t
+!
+!=======================================================================
+
+ implicit none
+
+ include "constants.h"
+
+ integer ngnod
+
+ double precision shape2D(ngnod)
+ double precision dershape2D(NDIM,ngnod)
+ double precision xi,gamma
+
+ double precision s,t,sp,sm,tp,tm,s2,t2,ss,tt,st
+
+!
+!---- set up the shape functions and their local derivatives
+!
+ s = xi
+ t = gamma
+
+!---- 4-node element
+ if(ngnod == 4) then
+ sp = s + ONE
+ sm = s - ONE
+ tp = t + ONE
+ tm = t - ONE
+
+!---- corner nodes
+ shape2D(1) = QUART * sm * tm
+ shape2D(2) = - QUART * sp * tm
+ shape2D(3) = QUART * sp * tp
+ shape2D(4) = - QUART * sm * tp
+
+ dershape2D(1,1) = QUART * tm
+ dershape2D(1,2) = - QUART * tm
+ dershape2D(1,3) = QUART * tp
+ dershape2D(1,4) = - QUART * tp
+
+ dershape2D(2,1) = QUART * sm
+ dershape2D(2,2) = - QUART * sp
+ dershape2D(2,3) = QUART * sp
+ dershape2D(2,4) = - QUART * sm
+
+!---- 9-node element
+ else if(ngnod == 9) then
+
+ sp = s + ONE
+ sm = s - ONE
+ tp = t + ONE
+ tm = t - ONE
+ s2 = s * TWO
+ t2 = t * TWO
+ ss = s * s
+ tt = t * t
+ st = s * t
+
+!---- corner nodes
+ shape2D(1) = QUART * sm * st * tm
+ shape2D(2) = QUART * sp * st * tm
+ shape2D(3) = QUART * sp * st * tp
+ shape2D(4) = QUART * sm * st * tp
+
+ dershape2D(1,1) = QUART * tm * t * (s2 - ONE)
+ dershape2D(1,2) = QUART * tm * t * (s2 + ONE)
+ dershape2D(1,3) = QUART * tp * t * (s2 + ONE)
+ dershape2D(1,4) = QUART * tp * t * (s2 - ONE)
+
+ dershape2D(2,1) = QUART * sm * s * (t2 - ONE)
+ dershape2D(2,2) = QUART * sp * s * (t2 - ONE)
+ dershape2D(2,3) = QUART * sp * s * (t2 + ONE)
+ dershape2D(2,4) = QUART * sm * s * (t2 + ONE)
+
+!---- midside nodes
+ shape2D(5) = HALF * tm * t * (ONE - ss)
+ shape2D(6) = HALF * sp * s * (ONE - tt)
+ shape2D(7) = HALF * tp * t * (ONE - ss)
+ shape2D(8) = HALF * sm * s * (ONE - tt)
+
+ dershape2D(1,5) = -ONE * st * tm
+ dershape2D(1,6) = HALF * (ONE - tt) * (s2 + ONE)
+ dershape2D(1,7) = -ONE * st * tp
+ dershape2D(1,8) = HALF * (ONE - tt) * (s2 - ONE)
+
+ dershape2D(2,5) = HALF * (ONE - ss) * (t2 - ONE)
+ dershape2D(2,6) = -ONE * st * sp
+ dershape2D(2,7) = HALF * (ONE - ss) * (t2 + ONE)
+ dershape2D(2,8) = -ONE * st * sm
+
+!---- center node
+ shape2D(9) = (ONE - ss) * (ONE - tt)
+
+ dershape2D(1,9) = -ONE * s2 * (ONE - tt)
+ dershape2D(2,9) = -ONE * t2 * (ONE - ss)
+
+ else
+ call exit_MPI('Error: wrong number of control nodes')
+ endif
+
+!--- check the shape functions and their derivatives
+! sum of shape functions should be one
+! sum of derivaticves of shape functions should be zero
+ if(abs(sum(shape2D)-ONE) > TINYVAL) call exit_MPI('error shape functions')
+ if(abs(sum(dershape2D(1,:))) > TINYVAL) call exit_MPI('error deriv xi shape functions')
+ if(abs(sum(dershape2D(2,:))) > TINYVAL) call exit_MPI('error deriv gamma shape functions')
+
+ end subroutine define_shape_functions
+
Copied: seismo/2D/SPECFEM2D/trunk/src/enforce_acoustic_free_surface.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/enforce_acoustic_free_surface.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/enforce_acoustic_free_surface.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/enforce_acoustic_free_surface.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,88 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+
+! free surface for an acoustic medium
+! if acoustic, the free surface condition is a Dirichlet condition for the potential,
+! not Neumann, in order to impose zero pressure at the surface
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nelem_acoustic_surface,npoin,nspec
+
+ integer, dimension(5,nelem_acoustic_surface) :: acoustic_surface
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(npoin) :: &
+ potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
+
+!---
+!--- local variables
+!---
+
+ integer :: ispec_acoustic_surface,ispec,i,j,iglob
+
+ do ispec_acoustic_surface = 1, nelem_acoustic_surface
+
+ ispec = acoustic_surface(1,ispec_acoustic_surface)
+
+ do j = acoustic_surface(4,ispec_acoustic_surface), acoustic_surface(5,ispec_acoustic_surface)
+ do i = acoustic_surface(2,ispec_acoustic_surface), acoustic_surface(3,ispec_acoustic_surface)
+ iglob = ibool(i,j,ispec)
+ potential_acoustic(iglob) = ZERO
+ potential_dot_acoustic(iglob) = ZERO
+ potential_dot_dot_acoustic(iglob) = ZERO
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine enforce_acoustic_free_surface
+
Copied: seismo/2D/SPECFEM2D/trunk/src/exit_mpi.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/exit_mpi.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/exit_mpi.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/exit_mpi.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,75 @@
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!-----------------------------------------------
+! subroutine to stop the code whether sequential or parallel.
+!-----------------------------------------------
+subroutine exit_MPI(error_msg)
+
+ implicit none
+#ifdef USE_MPI
+ ! standard include of the MPI library
+ include "mpif.h"
+#endif
+
+ ! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ character(len=*) error_msg
+
+ integer ier
+
+ ier = 0
+
+ ! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc '
+
+ ! stop all the MPI processes, and exit
+#ifdef USE_MPI
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+#endif
+
+ stop 'error, program ended in exit_MPI'
+
+end subroutine exit_MPI
Copied: seismo/2D/SPECFEM2D/trunk/src/get_MPI.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/get_MPI.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/get_MPI.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/get_MPI.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,319 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+#ifdef USE_MPI
+
+ subroutine get_MPI(nspec,ibool,knods,ngnod,npoin,elastic,poroelastic, &
+ ninterface, max_interface_size, &
+ my_nelmnts_neighbours,my_interfaces,my_neighbours, &
+ ibool_interfaces_acoustic, ibool_interfaces_elastic, &
+ ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic, nibool_interfaces_elastic, &
+ nibool_interfaces_poroelastic, &
+ inum_interfaces_acoustic, inum_interfaces_elastic, &
+ inum_interfaces_poroelastic, &
+ ninterface_acoustic, ninterface_elastic, ninterface_poroelastic, &
+ mask_ispec_inner_outer, &
+ myrank,ipass,coord)
+
+! sets up the MPI interface for communication between partitions
+
+ implicit none
+
+ include "constants.h"
+ include 'mpif.h'
+
+ integer, intent(in) :: nspec, npoin, ngnod
+ logical, dimension(nspec), intent(in) :: elastic, poroelastic
+ integer, dimension(ngnod,nspec), intent(in) :: knods
+ integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
+
+ integer :: ninterface
+ integer :: max_interface_size
+ integer, dimension(ninterface) :: my_nelmnts_neighbours,my_neighbours
+ integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
+
+ integer, dimension(NGLLX*max_interface_size,ninterface) :: &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(ninterface) :: &
+ nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(out) :: &
+ inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
+ integer, intent(out) :: ninterface_acoustic, ninterface_elastic, ninterface_poroelastic
+
+ logical, dimension(nspec), intent(inout) :: mask_ispec_inner_outer
+
+ integer :: myrank,ipass
+ double precision, dimension(NDIM,npoin) :: coord
+
+ !local parameters
+ double precision, dimension(:), allocatable :: xp,zp
+ double precision, dimension(:), allocatable :: work
+ integer, dimension(:), allocatable :: locval
+ integer, dimension(:), allocatable :: nibool_interfaces_true
+ ! for MPI buffers
+ integer, dimension(:), allocatable :: reorder_interface,ind,ninseg,iwork
+ integer, dimension(:), allocatable :: ibool_dummy
+! integer, dimension(:,:), allocatable :: ibool_interfaces_dummy
+ logical, dimension(:), allocatable :: ifseg
+ integer :: iinterface,ilocnum
+ integer :: num_points1, num_points2
+ ! assembly test
+ integer :: i,j,ispec,iglob,count,inum,ier,idomain
+ integer :: max_nibool_interfaces,num_nibool,num_interface
+ real(kind=CUSTOM_REAL), dimension(:),allocatable :: test_flag_cr
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_ac
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_ac
+ integer, dimension(:), allocatable :: tab_requests_send_recv_acoustic
+
+ ! gets global indices for points on MPI interfaces
+ ! (defined by my_interfaces) between different partitions
+ ! and stores them in ibool_interfaces*** & nibool_interfaces*** (number of total points)
+ call prepare_assemble_MPI(nspec,ibool,knods, ngnod,npoin, elastic, poroelastic, &
+ ninterface, max_interface_size, &
+ my_nelmnts_neighbours, my_interfaces, &
+ ibool_interfaces_acoustic, ibool_interfaces_elastic, &
+ ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic, nibool_interfaces_elastic, &
+ nibool_interfaces_poroelastic, &
+ inum_interfaces_acoustic, inum_interfaces_elastic, &
+ inum_interfaces_poroelastic, &
+ ninterface_acoustic, ninterface_elastic, ninterface_poroelastic, &
+ mask_ispec_inner_outer )
+
+
+ ! sorts ibool comm buffers lexicographically for all MPI interfaces
+ num_points1 = 0
+ num_points2 = 0
+ allocate(nibool_interfaces_true(ninterface))
+
+ do idomain = 1,3
+
+ ! checks number of interface in this domain
+ num_interface = 0
+ if( idomain == 1 ) then
+ num_interface = ninterface_acoustic
+ elseif( idomain == 2 ) then
+ num_interface = ninterface_elastic
+ elseif( idomain == 3 ) then
+ num_interface = ninterface_poroelastic
+ endif
+ if( num_interface == 0 ) cycle
+
+ ! loops over interfaces
+ do iinterface = 1, ninterface
+
+ ! number of global points in this interface
+ num_nibool = 0
+ if( idomain == 1 ) then
+ num_nibool = nibool_interfaces_acoustic(iinterface)
+ elseif( idomain == 2 ) then
+ num_nibool = nibool_interfaces_elastic(iinterface)
+ elseif( idomain == 3 ) then
+ num_nibool = nibool_interfaces_poroelastic(iinterface)
+ endif
+ ! checks if anything to sort
+ if( num_nibool == 0 ) cycle
+
+ allocate(xp(num_nibool))
+ allocate(zp(num_nibool))
+ allocate(locval(num_nibool))
+ allocate(ifseg(num_nibool))
+ allocate(reorder_interface(num_nibool))
+ allocate(ibool_dummy(num_nibool))
+ allocate(ind(num_nibool))
+ allocate(ninseg(num_nibool))
+ allocate(iwork(num_nibool))
+ allocate(work(num_nibool))
+
+ ! works with a copy of ibool array
+ if( idomain == 1 ) then
+ ibool_dummy(:) = ibool_interfaces_acoustic(1:num_nibool,iinterface)
+ elseif( idomain == 2 ) then
+ ibool_dummy(:) = ibool_interfaces_elastic(1:num_nibool,iinterface)
+ elseif( idomain == 3 ) then
+ ibool_dummy(:) = ibool_interfaces_poroelastic(1:num_nibool,iinterface)
+ endif
+
+ ! gets x,y,z coordinates of global points on MPI interface
+ do ilocnum = 1, num_nibool
+ iglob = ibool_dummy(ilocnum)
+ xp(ilocnum) = coord(1,iglob)
+ zp(ilocnum) = coord(2,iglob)
+ enddo
+
+ ! sorts (lexicographically?) ibool_interfaces and updates value
+ ! of total number of points nibool_interfaces_true(iinterface)
+ call sort_array_coordinates(num_nibool,xp,zp, &
+ ibool_dummy, &
+ reorder_interface,locval,ifseg, &
+ nibool_interfaces_true(iinterface), &
+ ind,ninseg,iwork,work)
+
+ ! checks that number of MPI points are still the same
+ num_points1 = num_points1 + num_nibool
+ num_points2 = num_points2 + nibool_interfaces_true(iinterface)
+ if( num_points1 /= num_points2 ) then
+ write(IOUT,*) 'error sorting MPI interface points:',myrank
+ write(IOUT,*) ' domain:',idomain
+ write(IOUT,*) ' interface:',iinterface,num_points1,num_points2
+ call exit_MPI('error sorting MPI interface')
+ endif
+
+ ! stores new order of ibool array
+ if( idomain == 1 ) then
+ ibool_interfaces_acoustic(1:num_nibool,iinterface) = ibool_dummy(:)
+ elseif( idomain == 2 ) then
+ ibool_interfaces_elastic(1:num_nibool,iinterface) = ibool_dummy(:)
+ elseif( idomain == 3 ) then
+ ibool_interfaces_poroelastic(1:num_nibool,iinterface) = ibool_dummy(:)
+ endif
+
+ ! cleanup temporary arrays
+ deallocate(xp)
+ deallocate(zp)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(reorder_interface)
+ deallocate(ibool_dummy)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iwork)
+ deallocate(work)
+ enddo
+ enddo
+
+ ! cleanup
+ deallocate(nibool_interfaces_true)
+
+ ! outputs total number of MPI interface points
+ call MPI_ALLREDUCE(num_points2, num_points1, 1, MPI_INTEGER, &
+ MPI_SUM, MPI_COMM_WORLD, ier)
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) 'total MPI interface points: ',num_points1
+ endif
+
+ ! checks interfaces in acoustic domains
+ if ( ninterface_acoustic > 0) then
+
+ ! checks with assembly of test fields
+ allocate(test_flag_cr(npoin))
+ test_flag_cr(:) = 0._CUSTOM_REAL
+ count = 0
+ do ispec = 1, nspec
+ ! sets flags on global points
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ ! global index
+ iglob = ibool(i,j,ispec)
+
+ ! counts number of unique global points to set
+ if( nint(test_flag_cr(iglob)) == 0 ) count = count+1
+
+ ! sets identifier
+ test_flag_cr(iglob) = myrank + 1.0
+ enddo
+ enddo
+ enddo
+
+ max_nibool_interfaces = maxval(nibool_interfaces_acoustic(:))
+
+ allocate(tab_requests_send_recv_acoustic(ninterface_acoustic*2))
+ allocate(buffer_send_faces_vector_ac(max_nibool_interfaces,ninterface_acoustic))
+ allocate(buffer_recv_faces_vector_ac(max_nibool_interfaces,ninterface_acoustic))
+
+ inum = 0
+ do iinterface = 1, ninterface
+ inum = inum + nibool_interfaces_acoustic(iinterface)
+ enddo
+
+ call MPI_ALLREDUCE(inum, num_points2, 1, MPI_INTEGER, &
+ MPI_SUM, MPI_COMM_WORLD, ier)
+
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) ' acoustic interface points: ',num_points2
+ endif
+
+ ! adds contributions from different partitions to flag arrays
+ ! custom_real arrays
+ call assemble_MPI_vector_ac(test_flag_cr,npoin, &
+ ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
+ max_interface_size, max_nibool_interfaces,&
+ ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
+ tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
+ buffer_recv_faces_vector_ac, my_neighbours)
+
+ ! checks number of interface points
+ i = 0
+ do iglob=1,npoin
+ ! only counts flags with MPI contributions
+ if( test_flag_cr(iglob) > myrank+1.0_CUSTOM_REAL ) i = i + 1
+ enddo
+ call MPI_ALLREDUCE(inum, iglob, 1, MPI_INTEGER, &
+ MPI_SUM, MPI_COMM_WORLD, ier)
+
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) ' assembled acoustic MPI interface points:',iglob
+ endif
+ if( num_points2 /= iglob ) then
+ print*,'error assembly:',myrank
+ print*,' count = ',count
+ print*,' inum = ',inum
+ print*,' i = ',i
+ print*,' total: ',num_points2,' not equal to assembled ',iglob
+ call exit_MPI('error acoustic MPI assembly')
+ endif
+ deallocate(tab_requests_send_recv_acoustic)
+ deallocate(buffer_send_faces_vector_ac)
+ deallocate(buffer_recv_faces_vector_ac)
+
+ deallocate(test_flag_cr)
+
+ endif
+
+
+
+ end subroutine get_MPI
+
+#endif
Copied: seismo/2D/SPECFEM2D/trunk/src/get_node_number.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/get_node_number.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/get_node_number.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/get_node_number.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,94 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+! *******************
+! meshing subroutines
+! *******************
+
+!--- global node number
+
+integer function num(i,j,nx)
+
+ implicit none
+
+ integer i,j,nx
+
+ num = j*(nx+1) + i + 1
+
+end function num
+
+
+!--- global node number (when ngnod==4).
+integer function num_4(i,j,nx)
+
+ implicit none
+
+ integer i,j,nx
+
+ num_4 = j*(nx+1) + i + 1
+
+end function num_4
+
+
+!--- global node number (when ngnod==9).
+integer function num_9(i,j,nx,nz)
+
+ implicit none
+
+ integer i,j,nx,nz
+
+
+ if ( (mod(i,2) == 0) .and. (mod(j,2) == 0) ) then
+ num_9 = j/2 * (nx+1) + i/2 + 1
+ else
+ if ( mod(j,2) == 0 ) then
+ num_9 = (nx+1)*(nz+1) + j/2 * nx + ceiling(real(i)/real(2))
+ else
+ num_9 = (nx+1)*(nz+1) + nx*(nz+1) + floor(real(j)/real(2))*(nx*2+1) + i + 1
+
+ endif
+ endif
+
+end function num_9
Copied: seismo/2D/SPECFEM2D/trunk/src/get_perm_cuthill_mckee.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/get_perm_cuthill_mckee.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/get_perm_cuthill_mckee.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/get_perm_cuthill_mckee.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,806 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! implement reverse Cuthill-McKee (1969) ordering, introduced in
+! E. Cuthill and J. McKee. Reducing the bandwidth of sparse symmetric matrices.
+! In Proceedings of the 1969 24th national conference, pages 157-172,
+! New-York, New-York, USA, 1969. ACM Press.
+! see for instance http://en.wikipedia.org/wiki/Cuthill%E2%80%93McKee_algorithm
+
+ subroutine get_perm(ibool,perm,limit,nspec,nglob)
+
+ implicit none
+
+ include "constants.h"
+
+! local variables
+ integer nspec,nglob_GLL_full
+ integer nglob_four_corners_only,nglob
+
+! maximum number of neighbors of a spectral element (in principle, it could be any value)
+ integer, parameter :: MAX_NUMBER_OF_NEIGHBORS = 50
+
+! input
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! output
+ integer, dimension(nspec) :: perm
+
+! global corner numbers that need to be created
+ integer, dimension(nglob) :: global_corner_number
+
+ integer mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
+ integer, dimension(:), allocatable :: ne,np,adj
+ integer xadj(nspec+1)
+
+! arrays to store the permutation and inverse permutation of the Cuthill-McKee algorithm
+ integer, dimension(nspec) :: invperm
+
+ logical maskel(nspec)
+
+ integer i,istart,istop,number_of_neighbors
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne,total_size_adj,limit
+
+!
+!-----------------------------------------------------------------------
+!
+ if(PERFORM_CUTHILL_MCKEE) then
+
+ ! total number of points in the mesh
+ nglob_GLL_full = nglob
+
+ !---- call Charbel Farhat's routines
+ call form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,nglob_GLL_full,ibool,nglob_four_corners_only)
+ do i=1,nspec
+ istart = mp(i)
+ istop = mp(i+1) - 1
+ enddo
+
+ allocate(np(nglob_four_corners_only+1))
+ count_only = .true.
+ total_size_ne = 1
+ allocate(ne(total_size_ne))
+ call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only,nspec,count_only,total_size_ne)
+ deallocate(ne)
+ allocate(ne(total_size_ne))
+ count_only = .false.
+ call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only,nspec,count_only,total_size_ne)
+ do i=1,nglob_four_corners_only
+ istart = np(i)
+ istop = np(i+1) - 1
+ enddo
+
+ count_only = .true.
+ total_size_adj = 1
+ allocate(adj(total_size_adj))
+ call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_four_corners_only,&
+ count_only,total_size_ne,total_size_adj)
+ deallocate(adj)
+ allocate(adj(total_size_adj))
+ count_only = .false.
+ call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_four_corners_only,&
+ count_only,total_size_ne,total_size_adj)
+ do i=1,nspec
+ istart = xadj(i)
+ istop = xadj(i+1) - 1
+ number_of_neighbors = istop-istart+1
+ if(number_of_neighbors < 1) stop 'error: your mesh seems to have at least one element not connected to any other'
+ if(number_of_neighbors > MAX_NUMBER_OF_NEIGHBORS) stop 'error: your mesh seems to have an unlikely high valence'
+ enddo
+ deallocate(ne,np)
+
+! call the Cuthill-McKee sorting algorithm
+ call cuthill_mckee(adj,xadj,perm,invperm,nspec,total_size_adj,limit)
+ deallocate(adj)
+ else
+! create identity permutation in order to do nothing
+ do i=1,nspec
+ perm(i) = i
+ enddo
+ endif
+
+ end subroutine get_perm
+
+!=======================================================================
+!
+! Charbel Farhat's FEM topology routines
+!
+! Dimitri Komatitsch, February 1996 - Code based on Farhat's original version
+! described in his technical report from 1987
+!
+! modified and adapted by Dimitri Komatitsch, May 2006
+!
+!=======================================================================
+
+ subroutine form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number, &
+ nglob_GLL_full,ibool,nglob_four_corners_only)
+
+!-----------------------------------------------------------------------
+!
+! Forms the MN and MP arrays
+!
+! Input :
+! -------
+! ibool Array needed to build the element connectivity table
+! nspec Number of elements in the domain
+! NGNOD_QUADRANGLE number of nodes per hexahedron (brick with 8 corners)
+!
+! Output :
+! --------
+! MN, MP This is the element connectivity array pair.
+! Array MN contains the list of the element
+! connectivity, that is, the nodes contained in each
+! element. They are stored in a stacked fashion.
+!
+! Pointer array MP stores the location of each
+! element list. Its length is equal to the number
+! of elements plus one.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,nglob_GLL_full
+
+! arrays with mesh parameters per slice
+ integer, intent(in), dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! global corner numbers that need to be created
+ integer, intent(out), dimension(nglob_GLL_full) :: global_corner_number
+ integer, intent(out) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
+ integer, intent(out) :: nglob_four_corners_only
+
+ integer ninter,nsum,ispec,node,k,inumcorner,ix,iy
+
+ ninter = 1
+ nsum = 1
+ mp(1) = 1
+
+!---- define topology of the elements in the mesh
+!---- we need to define adjacent numbers from the sub-mesh consisting of the corners only
+ nglob_four_corners_only = 0
+ global_corner_number(:) = -1
+
+ do ispec=1,nspec
+
+ inumcorner = 0
+ do iy = 1,NGLLZ,NGLLZ-1
+ do ix = 1,NGLLX,NGLLX-1
+
+ inumcorner = inumcorner + 1
+ if(inumcorner > NGNOD_QUADRANGLE) stop 'corner number too large'
+
+! check if this point was already assigned a number previously, otherwise create one and store it
+ if(global_corner_number(ibool(ix,iy,ispec)) == -1) then
+ nglob_four_corners_only = nglob_four_corners_only + 1
+ global_corner_number(ibool(ix,iy,ispec)) = nglob_four_corners_only
+ endif
+
+ node = global_corner_number(ibool(ix,iy,ispec))
+ do k=nsum,ninter-1
+ if(node == mn(k)) goto 200
+ enddo
+
+ mn(ninter) = node
+ ninter = ninter + 1
+ 200 continue
+
+ enddo
+ enddo
+
+ nsum = ninter
+ mp(ispec + 1) = nsum
+
+ enddo
+
+ end subroutine form_elt_connectivity_foelco
+
+!
+!----------------------------------------------------
+!
+
+ subroutine form_node_connectivity_fonoco(mn,mp,ne,np,nglob_four_corners_only, &
+ nspec,count_only,total_size_ne)
+
+!-----------------------------------------------------------------------
+!
+! Forms the NE and NP arrays
+!
+! Input :
+! -------
+! MN, MP, nspec
+! nglob_four_corners_only Number of nodes in the domain
+!
+! Output :
+! --------
+! NE, NP This is the node-connected element array pair.
+! Integer array NE contains a list of the
+! elements connected to each node, stored in stacked fashion.
+!
+! Array NP is the pointer array for the
+! location of a node's element list in the NE array.
+! Its length is equal to the number of points plus one.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne
+
+ integer nglob_four_corners_only,nspec
+
+ integer, intent(in) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1)
+
+ integer, intent(out) :: ne(total_size_ne),np(nglob_four_corners_only+1)
+
+ integer nsum,inode,ispec,j
+
+ nsum = 1
+ np(1) = 1
+
+ do inode=1,nglob_four_corners_only
+ do 200 ispec=1,nspec
+
+ do j=mp(ispec),mp(ispec + 1) - 1
+ if (mn(j) == inode) then
+ if(count_only) then
+ total_size_ne = nsum
+ else
+ ne(nsum) = ispec
+ endif
+ nsum = nsum + 1
+ goto 200
+ endif
+ enddo
+ 200 continue
+
+ np(inode + 1) = nsum
+
+ enddo
+
+ end subroutine form_node_connectivity_fonoco
+
+!
+!----------------------------------------------------
+!
+
+ subroutine create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec, &
+ nglob_four_corners_only,count_only,total_size_ne,total_size_adj)
+
+!-----------------------------------------------------------------------
+!
+! Establishes the element adjacency information of the mesh
+! Two elements are considered adjacent if they share a face.
+!
+! Input :
+! -------
+! MN, MP, NE, NP, nspec
+! MASKEL logical mask (length = nspec)
+!
+! Output :
+! --------
+! ADJ, XADJ This is the element adjacency array pair. Array
+! ADJ contains the list of the elements adjacent to
+! element i. They are stored in a stacked fashion.
+! Pointer array XADJ stores the location of each element list.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne,total_size_adj
+
+ integer nglob_four_corners_only
+
+ integer nspec,iad,ispec,istart,istop,ino,node,jstart,jstop,nelem,jel
+
+ integer, intent(in) :: mn(nspec*NGNOD_QUADRANGLE),mp(nspec+1),ne(total_size_ne),np(nglob_four_corners_only+1)
+
+ integer, intent(out) :: adj(total_size_adj),xadj(nspec+1)
+
+ logical maskel(nspec)
+ integer countel(nspec)
+
+ xadj(1) = 1
+ iad = 1
+
+ do ispec=1,nspec
+
+! reset mask
+ maskel(:) = .false.
+
+! mask current element
+ maskel(ispec) = .true.
+ if (FACE) countel(:) = 0
+
+ istart = mp(ispec)
+ istop = mp(ispec+1) - 1
+ do ino=istart,istop
+ node = mn(ino)
+ jstart = np(node)
+ jstop = np(node + 1) - 1
+ do 120 jel=jstart,jstop
+ nelem = ne(jel)
+ if(maskel(nelem)) goto 120
+ if (FACE) then
+!! DK DK this below implemented by David Michea in 3D, but not true anymore in 2D: should be
+!! DK DK two corners instead of three. But does not matter because FACE is always .false.
+!! DK DK and therefore this part of the routine is currently never used.
+!! DK DK Let me add a stop statement just in case.
+ stop 'FACE = .true. not implemented, check the above comment in the source code'
+!! DK DK End of the stop statement added.
+ ! if 2 elements share at least 3 corners, therefore they share a face
+ countel(nelem) = countel(nelem) + 1
+ if (countel(nelem)>=3) then
+ if(count_only) then
+ total_size_adj = iad
+ else
+ adj(iad) = nelem
+ endif
+ maskel(nelem) = .true.
+ iad = iad + 1
+ endif
+ else
+ if(count_only) then
+ total_size_adj = iad
+ else
+ adj(iad) = nelem
+ endif
+ maskel(nelem) = .true.
+ iad = iad + 1
+ endif
+ 120 continue
+ enddo
+
+ xadj(ispec+1) = iad
+
+ enddo
+
+ end subroutine create_adjacency_table_adjncy
+
+!
+!----------------------------------------------------
+!
+
+ subroutine cuthill_mckee(adj,xadj,mask,invperm_all,nspec,total_size_adj,limit)
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: nspec,total_size_adj, limit
+ integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
+
+ integer, intent(out), dimension(nspec) :: mask,invperm_all
+ integer, dimension(nspec) :: invperm_sub
+ integer ispec,gsize,counter,nspec_sub,root,total_ordered_elts, next_root
+
+! fill the mask with ones
+ mask(:) = 1
+ invperm_all(:) = 0
+ counter = 0
+ nspec_sub = limit
+ root = 1
+ total_ordered_elts = 0
+
+ do while(total_ordered_elts < nspec)
+ ! creation of a sublist of sorted elements which fit in the cache (the criterion of size is limit)
+ ! limit = nb of elements that can fit in the L2 cache
+ call Cut_McK( root, nspec, total_size_adj, xadj, adj, mask, gsize, invperm_sub, limit, nspec_sub, next_root)
+ ! add the sublist in the main permutation list
+ invperm_all(total_ordered_elts+1:total_ordered_elts+nspec_sub) = invperm_sub(1:nspec_sub)
+ total_ordered_elts = total_ordered_elts + nspec_sub
+ ! seek for a new root to build the new sublist
+ if (next_root > 0) then
+ root = next_root
+ else
+ if (total_ordered_elts /= nspec) &
+ call find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
+ root = next_root
+ endif
+ enddo
+
+ if (INVERSE) then
+ do ispec=1,nspec
+ mask(invperm_all(ispec)) = ispec
+ enddo
+ else
+ mask(:) = invperm_all(:)
+ endif
+
+ end subroutine cuthill_mckee
+
+
+!*******************************************************************************
+! Objective: Cuthill-McKee ordering
+! The algorithm is:
+!
+! X(1) = ROOT.
+! for ( I = 1 to N-1)
+! Find all unlabeled neighbors of X(I),
+! assign them the next available labels, in order of increasing degree.
+!
+! Parameters:
+! root the starting point for the cm ordering.
+! nbnodes the number of nodes.
+! nnz the number of adjacency entries.
+!
+! xadj/adj the graph
+! mask only those nodes with nonzero mask are considered
+!
+! gsize the number of the connected component
+! invp Inverse permutation (from new order to old order)
+!*******************************************************************************
+
+subroutine find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+! input
+ integer, intent(in) :: total_size_adj,total_ordered_elts,nspec
+ integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
+ integer, intent(in), dimension(nspec) :: mask,invperm_all
+! output
+ integer, intent(out) :: next_root
+! variables
+ integer :: cur_node,neighbor_node,i,j
+
+ do i=total_ordered_elts, 1, -1
+ cur_node = invperm_all(i)
+ do j= xadj(cur_node), xadj(cur_node+1)-1
+ neighbor_node = adj(j)
+ if (mask(neighbor_node)/=0) then
+ next_root=neighbor_node
+ return
+ endif
+ enddo
+ enddo
+
+end subroutine find_next_root
+
+!*******************************************************************************
+! Objective: Cuthill-McKee ordering
+! The algorithm is:
+!
+! X(1) = ROOT.
+! for ( I = 1 to N-1)
+! Find all unlabeled neighbors of X(I),
+! assign them the next available labels, in order of increasing degree.
+!
+! Parameters:
+! root the starting point for the cm ordering.
+! nbnodes the number of nodes.
+! nnz the number of adjacency entries.
+!
+! xadj/adj the graph
+! mask only those nodes with nonzero mask are considered
+!
+! gsize the number of the connected component
+! invp Inverse permutation (from new order to old order)
+!*******************************************************************************
+
+subroutine Cut_McK( root, nbnodes, nnz, xadj, adj, mask, gsize, invp, limit, nspec_sub, next_root)
+
+ implicit none
+
+ include "constants.h"
+
+!--------------------------------------------------------------- Input Variables
+ integer root, nnz, nbnodes, limit, nspec_sub, next_root
+
+ integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
+
+!-------------------------------------------------------------- Output Variables
+ integer gsize
+ integer invp(nbnodes)
+
+!--------------------------------------------------------------- Local Variables
+ integer i, j, k, l, lbegin, lnbr, linvp, lvlend, nbr, node, fnbr
+ integer deg(nbnodes)
+
+! Find the degrees of the nodes in the subgraph specified by mask and root
+! Here invp is used to store a levelization of the subgraph
+ invp(:)=0
+ deg(:)=0
+ call degree ( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, invp)
+
+ mask(root) = 0
+
+ IF (gsize > 1) THEN
+ !If there is at least 2 nodes in the subgraph
+ lvlend = 0
+ lnbr = 1
+
+ DO while (lvlend < lnbr)
+ !lbegin/lvlend point to the begin/end of the present level
+ lbegin = lvlend + 1
+ lvlend = lnbr
+
+ do i= lbegin, lvlend
+ node = invp(i)
+
+ !Find the unnumbered neighbours of node.
+ !fnbr/lnbr point to the first/last neighbors of node
+ fnbr = lnbr + 1
+ do j= xadj(node), xadj(node+1)-1
+ nbr = adj(j)
+
+ if (mask(nbr) /= 0) then
+ lnbr = lnbr + 1
+ mask(nbr) = 0
+ invp(lnbr) = nbr
+ endif
+ enddo
+
+ !If no neighbors, go to next node in this level.
+ IF (lnbr > fnbr) THEN
+ !Sort the neighbors of NODE in increasing order by degree.
+ !Linear insertion is used.
+ k = fnbr
+ do while (k < lnbr)
+ l = k
+ k = k + 1
+ nbr = invp(k)
+
+ DO WHILE (fnbr < l)
+ linvp = invp(l)
+
+ if (deg(linvp) <= deg(nbr)) then
+ exit
+ endif
+
+ invp(l+1) = linvp
+ l = l-1
+ ENDDO
+
+ invp(l+1) = nbr
+ enddo
+ ENDIF
+ enddo
+ ENDDO
+
+ ENDIF
+
+ if (gsize > limit) then
+ do i = limit + 1 , nbnodes
+ node=invp(i)
+ if (node /=0) mask(node) = 1
+ enddo
+ next_root = invp(limit +1)
+ nspec_sub = limit
+ else
+ next_root = -1
+ nspec_sub = gsize
+ endif
+
+END subroutine Cut_McK
+
+
+!*******************************************************************************
+! Objective: computes the degrees of the nodes in the connected graph
+!
+! Parameters:
+! root the root node
+! nbnodes the number of nodes in the graph
+! nnz the graph size
+! xadj/adj the whole graph
+! mask Only nodes with mask == 0 are considered
+!
+! gsize the number of nodes in the connected graph
+! deg degree for all the nodes in the connected graph
+! level levelization of the connected graph
+!
+!*******************************************************************************
+
+subroutine degree( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, level )
+
+ implicit none
+
+!--------------------------------------------------------------- Input Variables
+ integer root, nbnodes, nnz
+ integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
+
+!-------------------------------------------------------------- Output Variables
+ integer gsize
+ integer deg(nbnodes), level(nbnodes)
+
+!--------------------------------------------------------------- Local Variables
+ integer i, j, ideg, lbegin, lvlend, lvsize, nxt, nbr, node
+
+! added a test to detect disconnected subsets in the mesh
+! (in which case Cuthill-McKee fails and should be turned off)
+ if(root > nbnodes+1) stop 'error: root > nbnodes+1 in Cuthill-McKee'
+ if(root < 1) then
+ print *,'error: root < 1 in Cuthill-McKee; you probably have a mesh composed of'
+ print *,'two disconnected subsets of elements, in which case Cuthill-McKee fails and should be turned off.'
+ print *,'please set PERFORM_CUTHILL_MCKEE = .false. in constants.h and recompile.'
+ print *,'please also doublecheck that you indeed want to run two separate meshes simultaneously,'
+ print *,'which is extremely unusual (but formally not incorrect).'
+ stop 'fatal error in Cuthill-McKee'
+ endif
+
+! The sign of xadj(I) is used to indicate if node i has been considered
+ xadj(root) = -xadj(root)
+ level(1) = root
+ nxt = 1
+ lvlend = 0
+ lvsize = 1
+
+ DO WHILE (lvsize > 0)
+ ! lbegin/lvlend points the begin/end of the present level
+ lbegin = lvlend + 1
+ lvlend = nxt
+
+ ! Find the degrees of nodes in the present level and generate the next level
+ DO i= lbegin, lvlend
+ node = level(i)
+ ideg = 0
+ do j= ABS( xadj(node) ), ABS( xadj(node+1) )-1
+ nbr = adj(j)
+
+ if (mask(nbr) /= 0) then
+ ideg = ideg + 1
+
+ if (xadj(nbr) >= 0) then
+ xadj(nbr) = -xadj(nbr)
+ nxt = nxt + 1
+ level(nxt) = nbr
+ endif
+ endif
+ enddo
+
+ deg(node) = ideg
+ ENDDO
+
+ !Compute the level size of the next level
+ lvsize = nxt - lvlend
+ ENDDO
+
+ !Reset xadj to its correct sign
+ do i = 1, nxt
+ node = level(i)
+ xadj(node) = -xadj(node)
+ enddo
+
+ gsize = nxt
+
+END subroutine degree
+
+!
+!-----------------------------------------------------------------------
+!
+
+ subroutine permute_elements_real(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ real(kind=CUSTOM_REAL), intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:) = array_to_permute(:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_real
+
+!
+!-----------------------------------------------------------------------
+!
+
+! implement permutation of elements for arrays of integer type
+ subroutine permute_elements_integer(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ integer, intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:) = array_to_permute(:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_integer
+
+!
+!-----------------------------------------------------------------------
+!
+
+! implement permutation of elements for arrays of double precision type
+ subroutine permute_elements_dble(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ double precision, intent(inout), dimension(NGLLX,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:) = array_to_permute(:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,new_ispec) = temp_array(:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_dble
+
Copied: seismo/2D/SPECFEM2D/trunk/src/get_poroelastic_velocities.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/get_poroelastic_velocities.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/get_poroelastic_velocities.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/get_poroelastic_velocities.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,155 @@
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!----
+!---- subroutine to compute poroelastic velocities cpI, cpII, & cs as a function of the dominant frequency
+!----
+
+ subroutine get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare,H_biot,C_biot,M_biot,mul_fr,phil, &
+ tortl,rhol_s,rhol_f,etal_f,perm,fi,f0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: f0,w0il
+ double precision :: H_biot,C_biot,M_biot
+ double precision :: cpIsquare,cpIIsquare
+ double precision :: cssquare,att_I,att_II
+ double precision :: etal_f,rhol_f,rhol_s,rhol_bar,perm
+ double precision :: mul_fr,phil,tortl
+
+ double precision :: a_r,a_i,b_r,b_i,cc,alpha,aa1,aa2
+ double precision :: xx,yy, gXI, gYI,gXII,gYII,w_c,f_c
+ double precision :: wi,fi,taus,taue,Q0,bbr,bbi
+
+ double precision :: gA,gB,sa,sb,xxs,yys
+ logical :: TURN_VISCATTENUATION_ON
+
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+
+ w_c = etal_f*phil/(tortl*rhol_f*perm)
+ f_c = w_c/(2*pi)
+
+ wi=2.d0*pi*fi
+
+ alpha=10.d0**dlog10(wi)
+ w0il = 2.d0*pi*f0
+ taue = (sqrt(Q0*Q0+1) +1)/(w0il*Q0)
+ taus = (sqrt(Q0*Q0+1) -1)/(w0il*Q0)
+
+ if(TURN_VISCATTENUATION_ON) then
+! high frequency, with memory variables
+ bbr = etal_f/perm*(1.d0+alpha*alpha*taus*taue)/(1.d0 + alpha*alpha*taus*taus)
+ bbi = etal_f/perm*alpha*(taue-taus)/(1.d0 + alpha*alpha*taus*taus)
+ else
+! low frequency
+ bbr = etal_f/perm
+ bbi = 0.d0
+ endif
+
+! cs
+ gA = (rhol_f*tortl*rhol_bar-phil*rhol_f**2)**2/(phil*rhol_bar)**2 - (bbr**2-bbi**2)/alpha**2*&
+ (phil*rhol_f/(rhol_bar*tortl) -1.d0) - bbi/alpha*phil*rhol_f/(rhol_bar*tortl)*&
+ (rhol_f*tortl*rhol_bar-phil*rhol_f**2)/(phil*rhol_bar)
+ gB = -2.d0*bbr*bbi/alpha**2*(phil*rhol_f/(rhol_bar*tortl) -1.d0) + bbr/alpha*phil*rhol_f/&
+ (rhol_bar*tortl)*(rhol_f*tortl*rhol_bar-phil*rhol_f**2)/(phil*rhol_bar)
+!
+ sa = (rhol_f*tortl*rhol_bar-phil*rhol_f**2)**2/(phil*rhol_bar)**2 + (bbr**2-bbi**2)/alpha**2
+ sb = 2.d0*bbr*bbi/alpha**2
+!
+ xxs = sa*gA + sb*gB
+ yys = gA*sb - sa*gB
+
+ cssquare = mul_fr/(rhol_bar-phil*rhol_f/tortl) * 2.d0*(gA**2+gB**2)/(sqrt(xxs**2+yys**2)+xxs)
+
+
+! cpI & cpII
+ a_r = rhol_bar - phil*rhol_f/tortl - phil*rhol_bar/(tortl*rhol_f)*bbi/alpha
+ a_i = phil*rhol_bar/(tortl*rhol_f)*bbr
+ b_r = H_biot + M_biot*phil*rhol_bar/(tortl*rhol_f) - 2.d0*phil*C_biot/tortl - &
+ phil*H_biot/(tortl*rhol_f)*bbi/alpha
+ b_i = phil*H_biot/(tortl*rhol_f)*bbr
+ cc = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
+!
+ xx = b_r*b_r - b_i*b_i/(alpha*alpha) - 4.d0*a_r*cc
+ yy = 2.d0*b_r*b_i/alpha - 4.d0*a_i/alpha*cc
+!
+ gXI = a_r*(b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) + &
+ a_i/alpha*(b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
+
+ gYI = a_i/alpha*(b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) - &
+ a_r*(b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
+ gYI = -gYI
+
+ gXII = a_r*(b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) + &
+ a_i/alpha*(b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
+
+ gYII = a_i/alpha*(b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx)) - &
+ a_r*(b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))
+ gYII = -gYII
+!
+!
+!
+ cpIsquare = ((b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2 + &
+ (b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)/&
+ (sqrt(gXI**2+gYI**2) + gXI)
+
+ cpIIsquare = ((b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2 + &
+ (b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)/&
+ (sqrt(gXII**2+gYII**2) + gXII)
+
+! attenuation factors
+ att_I = -alpha*sign(1.d0,yy)*sqrt(sqrt(gXI**2+gYI**2)-gXI) / &
+ sqrt((b_r + sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2+&
+ (b_i/alpha + sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)
+ att_II = -alpha*sign(1.d0,yy)*sqrt(sqrt(gXII**2+gYII**2)-gXII) / &
+ sqrt((b_r - sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)+xx))**2+&
+ (b_i/alpha - sign(1.d0,yy)*sqrt(0.5)*sqrt(sqrt(xx**2+yy**2)-xx))**2)
+
+! inverse quality factors
+ aa1 = -gYI/gXI
+ aa2 = -gYII/gXII
+
+ end subroutine get_poroelastic_velocities
+
Copied: seismo/2D/SPECFEM2D/trunk/src/gll_library.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/gll_library.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/gll_library.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/gll_library.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,534 @@
+
+!=======================================================================
+!
+! Library to compute the Gauss-Lobatto-Legendre points and weights
+! Based on Gauss-Lobatto routines from M.I.T.
+! Department of Mechanical Engineering
+!
+!=======================================================================
+
+ double precision function endw1(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ f3 = zero
+ apb = alpha+beta
+ if(n == 0) then
+ endw1 = zero
+ return
+ endif
+ f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if(n == 1) then
+ endw1 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
+ if(n == 2) then
+ endw1 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw1 = f3
+
+ end function endw1
+
+!
+!=======================================================================
+!
+
+ double precision function endw2(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ apb = alpha+beta
+ f3 = zero
+ if (n == 0) then
+ endw2 = zero
+ return
+ endif
+ f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw2 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw2 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw2 = f3
+
+ end function endw2
+
+!
+!=======================================================================
+!
+
+ double precision function gammaf (x)
+
+ implicit none
+
+ double precision, parameter :: pi = 3.141592653589793d0
+
+ double precision x
+
+ double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
+
+ gammaf = one
+
+ if (x == -half) gammaf = -two*sqrt(pi)
+ if (x == half) gammaf = sqrt(pi)
+ if (x == one ) gammaf = one
+ if (x == two ) gammaf = one
+ if (x == 1.5d0) gammaf = sqrt(pi)/2.d0
+ if (x == 2.5d0) gammaf = 1.5d0*sqrt(pi)/2.d0
+ if (x == 3.5d0) gammaf = 2.5d0*1.5d0*sqrt(pi)/2.d0
+ if (x == 3.d0 ) gammaf = 2.d0
+ if (x == 4.d0 ) gammaf = 6.d0
+ if (x == 5.d0 ) gammaf = 24.d0
+ if (x == 6.d0 ) gammaf = 120.d0
+
+ end function gammaf
+
+!
+!=====================================================================
+!
+
+ subroutine jacg (xjac,np,alpha,beta)
+
+!=======================================================================
+!
+! computes np Gauss points, which are the zeros of the
+! Jacobi polynomial with parameters alpha and beta
+!
+! .alpha = beta = 0.0 -> Legendre points
+! .alpha = beta = -0.5 -> Chebyshev points
+!
+!=======================================================================
+
+ implicit none
+
+ integer np
+ double precision alpha,beta
+ double precision xjac(np)
+
+ integer k,j,i,jmin,jm,n
+ double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+
+ integer, parameter :: K_MAX_ITER = 10
+ double precision, parameter :: zero = 0.d0, eps = 1.0d-12
+
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ xlast = 0.d0
+ n = np-1
+ dth = 4.d0*atan(1.d0)/(2.d0*dble(n)+2.d0)
+ p = 0.d0
+ pd = 0.d0
+ jmin = 0
+ do j=1,np
+ if(j == 1) then
+ x = cos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ else
+ x1 = cos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ x2 = xlast
+ x = (x1+x2)/2.d0
+ endif
+ do k=1,K_MAX_ITER
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
+ recsum = 0.d0
+ jm = j-1
+ do i=1,jm
+ recsum = recsum+1.d0/(x-xjac(np-i+1))
+ enddo
+ delx = -p/(pd-recsum*p)
+ x = x+delx
+ if(abs(delx) < eps) goto 31
+ enddo
+ 31 continue
+ xjac(np-j+1) = x
+ xlast = x
+ enddo
+ do i=1,np
+ xmin = 2.d0
+ do j=i,np
+ if(xjac(j) < xmin) then
+ xmin = xjac(j)
+ jmin = j
+ endif
+ enddo
+ if(jmin /= i) then
+ swap = xjac(i)
+ xjac(i) = xjac(jmin)
+ xjac(jmin) = swap
+ endif
+ enddo
+
+ end subroutine jacg
+
+!
+!=====================================================================
+!
+
+ subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
+
+!=======================================================================
+!
+! Computes the Jacobi polynomial of degree n and its derivative at x
+!
+!=======================================================================
+
+ implicit none
+
+ double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
+ integer n
+
+ double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
+ integer k
+
+ apb = alp+bet
+ poly = 1.d0
+ pder = 0.d0
+ psave = 0.d0
+ pdsave = 0.d0
+
+ if (n == 0) return
+
+ polyl = poly
+ pderl = pder
+ poly = (alp-bet+(apb+2.d0)*x)/2.d0
+ pder = (apb+2.d0)/2.d0
+ if (n == 1) return
+
+ do k=2,n
+ dk = dble(k)
+ a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
+ a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
+ b3 = (2.d0*dk+apb-2.d0)
+ a3 = b3*(b3+1.d0)*(b3+2.d0)
+ a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
+ polyn = ((a2+a3*x)*poly-a4*polyl)/a1
+ pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
+ psave = polyl
+ pdsave = pderl
+ polyl = poly
+ poly = polyn
+ pderl = pder
+ pder = pdern
+ enddo
+
+ polym1 = polyl
+ pderm1 = pderl
+ polym2 = psave
+ pderm2 = pdsave
+
+ end subroutine jacobf
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNDLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the derivative of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P1D,P2D,P3D,FK,P3
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P1D = 0.d0
+ P2D = 1.d0
+ P3D = 1.d0
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
+ P1 = P2
+ P2 = P3
+ P1D = P2D
+ P2D = P3D
+ enddo
+
+ PNDLEG = P3D
+
+ end function pndleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P3,FK
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P3 = P2
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P1 = P2
+ P2 = P3
+ enddo
+
+ PNLEG = P3
+
+ end function pnleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision function pnormj (n,alpha,beta)
+
+ implicit none
+
+ double precision alpha,beta
+ integer n
+
+ double precision one,two,dn,const,prod,dindx,frac
+ double precision, external :: gammaf
+ integer i
+
+ one = 1.d0
+ two = 2.d0
+ dn = dble(n)
+ const = alpha+beta+one
+
+ if (n <= 1) then
+ prod = gammaf(dn+alpha)*gammaf(dn+beta)
+ prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
+ pnormj = prod * two**const/(two*dn+const)
+ return
+ endif
+
+ prod = gammaf(alpha+one)*gammaf(beta+one)
+ prod = prod/(two*(one+const)*gammaf(const+one))
+ prod = prod*(one+alpha)*(two+alpha)
+ prod = prod*(one+beta)*(two+beta)
+
+ do i=3,n
+ dindx = dble(i)
+ frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
+ prod = prod*frac
+ enddo
+
+ pnormj = prod * two**const/(two*dn+const)
+
+ end function pnormj
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgjd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g j d : Generate np Gauss-Jacobi points and weights
+! associated with Jacobi polynomial of degree n = np-1
+!
+! Note : Coefficients alpha and beta must be greater than -1.
+! ----
+!=======================================================================
+
+ implicit none
+ include 'constants.h'
+
+ !double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision z(np)
+ real(kind=CUSTOM_REAL) :: w(np)
+ double precision alpha,beta
+
+ integer n,np1,np2,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
+ double precision, external :: gammaf,pnormj
+
+ pd = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ apb = alpha+beta
+ p = zero
+ pdm1 = zero
+
+ if (np <= 0) call exit_MPI('minimum number of Gauss points is 1')
+
+ if ((alpha <= -one) .or. (beta <= -one)) call exit_MPI('alpha and beta must be greater than -1')
+
+ if (np == 1) then
+ z(1) = (beta-alpha)/(apb+two)
+ w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
+ return
+ endif
+
+ call jacg(z,np,alpha,beta)
+
+ np1 = n+1
+ np2 = n+2
+ dnp1 = dble(np1)
+ dnp2 = dble(np2)
+ fac1 = dnp1+alpha+beta+one
+ fac2 = fac1+dnp1
+ fac3 = fac2+one
+ fnorm = pnormj(np1,alpha,beta)
+ rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
+ do i=1,np
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
+ w(i) = -rcoef/(p*pdm1)
+ enddo
+
+ end subroutine zwgjd
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgljd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
+! ----------- weights associated with Jacobi polynomials of degree
+! n = np-1.
+!
+! Note : alpha and beta coefficients must be greater than -1.
+! Legendre polynomials are special case of Jacobi polynomials
+! just by setting alpha and beta to 0.
+!
+!=======================================================================
+
+ implicit none
+ include 'constants.h'
+
+
+ !double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision alpha,beta
+ double precision z(np)
+ real(kind=CUSTOM_REAL) :: w(np)
+
+ integer n,nm1,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision alpg,betg
+ double precision, external :: endw1,endw2
+
+ p = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ nm1 = n-1
+ pd = zero
+
+ if (np <= 1) call exit_MPI('minimum number of Gauss-Lobatto points is 2')
+
+! with spectral elements, use at least 3 points
+ if (np <= 2) call exit_MPI('minimum number of Gauss-Lobatto points for the SEM is 3')
+
+ if ((alpha <= -one) .or. (beta <= -one)) call exit_MPI('alpha and beta must be greater than -1')
+
+ if (nm1 > 0) then
+ alpg = alpha+one
+ betg = beta+one
+ call zwgjd(z(2),w(2),nm1,alpg,betg)
+ endif
+
+ z(1) = - one
+ z(np) = one
+
+ do i=2,np-1
+ w(i) = w(i)/(one-z(i)**2)
+ enddo
+
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
+ w(1) = endw1(n,alpha,beta)/(two*pd)
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
+ w(np) = endw2(n,alpha,beta)/(two*pd)
+
+ end subroutine zwgljd
+
Copied: seismo/2D/SPECFEM2D/trunk/src/gmat01.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/gmat01.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/gmat01.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/gmat01.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,396 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine gmat01(density_array,porosity_array,tortuosity_array, &
+ aniso_array,permeability,poroelastcoef, &
+ numat,myrank,ipass,Qp_array,Qs_array, &
+ freq0,Q0,f0,TURN_VISCATTENUATION_ON)
+
+! reads properties of a 2D isotropic or anisotropic linear elastic element
+
+ implicit none
+ include "constants.h"
+
+ integer :: numat,myrank,ipass
+ double precision :: density_array(2,numat),poroelastcoef(4,3,numat),porosity_array(numat)
+ double precision :: aniso_array(6,numat),tortuosity_array(numat),permeability(3,numat)
+ double precision :: Qp_array(numat),Qs_array(numat)
+ double precision :: f0,Q0,freq0
+ logical :: TURN_VISCATTENUATION_ON
+
+ ! local parameters
+ double precision :: lambdaplus2mu,kappa
+ double precision :: young,poisson,cp,cs,mu,two_mu,lambda,Qp,Qs
+ double precision :: lambdaplus2mu_s,lambdaplus2mu_fr,kappa_s,kappa_f,kappa_fr
+ double precision :: young_s,poisson_s,density(2),phi,tortuosity
+ double precision :: cpIsquare,cpIIsquare,cssquare,mu_s,mu_fr,eta_f,lambda_s,lambda_fr
+ double precision :: val1,val2,val3,val4,val5,val6
+ double precision :: val7,val8,val9,val10,val11,val12,val0
+ double precision :: c11,c13,c15,c33,c35,c55
+ double precision :: D_biot,H_biot,C_biot,M_biot
+ double precision :: w_c
+ integer in,n,indic
+ character(len=80) datlin
+
+
+ !
+ !---- loop over the different material sets
+ !
+ density_array(:,:) = zero
+ porosity_array(:) = zero
+ tortuosity_array(:) = zero
+ aniso_array(:,:) = zero
+ permeability(:,:) = zero
+ poroelastcoef(:,:,:) = zero
+ Qp_array(:) = zero
+ Qs_array(:) = zero
+
+ if(myrank == 0 .and. ipass == 1) write(IOUT,100) numat
+
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ do in = 1,numat
+
+ read(IIN,*) n,indic,val0,val1,val2,val3,val4,val5,val6,val7,val8,val9,val10,val11,val12
+
+ if(n<1 .or. n>numat) call exit_MPI('Wrong material set number')
+
+ !---- isotropic material, P and S velocities given, allows for declaration of elastic/acoustic material
+ !---- elastic (cs/=0) and acoustic (cs=0)
+ if(indic == 1) then
+ density(1) = val0
+
+ ! P and S velocity
+ cp = val1
+ cs = val2
+
+ ! Qp and Qs values
+ Qp = val5
+ Qs = val6
+
+ ! Lam'e parameters
+ lambdaplus2mu = density(1)*cp*cp
+ mu = density(1)*cs*cs
+ two_mu = 2.d0*mu
+ lambda = lambdaplus2mu - two_mu
+
+ ! bulk modulus Kappa
+ kappa = lambda + two_mu/3.d0
+
+ ! Young modulus
+ young = 9.d0*kappa*mu/(3.d0*kappa + mu)
+
+ ! Poisson's ratio
+ poisson = half*(3.d0*kappa-two_mu)/(3.d0*kappa+mu)
+
+ ! Poisson's ratio must be between -1 and +1/2
+ if (poisson < -1.d0 .or. poisson > 0.5d0) call exit_MPI('Poisson''s ratio out of range')
+
+ !---- anisotropic material, c11, c13, c33 and c44 given in Pascal
+ else if (indic == 2) then
+
+ density(1) =val0
+
+ ! P and S velocity
+ cp = 20
+ cs = 10
+
+ ! Anisotropy parameters
+ c11 = val1
+ c13 = val2
+ c15 = val3
+ c33 = val4
+ c35 = val5
+ c55 = val6
+
+ ! Qp and Qs values
+ !Qp = val9
+ !Qs = val10
+
+ ! Lam'e parameters
+ lambdaplus2mu = density(1)*cp*cp
+ mu = density(1)*cs*cs
+ two_mu = 2.d0*mu
+ lambda = lambdaplus2mu - two_mu
+
+ ! bulk modulus Kappa
+ kappa = lambda + two_mu/3.d0
+
+ ! Young modulus
+ young = 9.d0*kappa*mu/(3.d0*kappa + mu)
+
+ ! Poisson's ratio
+ poisson = half*(3.d0*kappa-two_mu)/(3.d0*kappa+mu)
+
+ !---- isotropic material, moduli are given, allows for declaration of poroelastic material
+ !---- poroelastic (0<phi<1)
+ else if (indic == 3) then
+ ! Qs values
+ Qs = val12
+
+ density(1) =val0
+ density(2) =val1
+
+ ! Solid properties
+ kappa_s = val7
+ mu_s = val11
+ ! Fluid properties
+ kappa_f = val8
+ eta_f = val10
+ ! Frame properties
+ kappa_fr = val9
+ mu_fr = val11
+ ! Lam'e parameters for the solid phase and the frame
+ lambdaplus2mu_s = kappa_s + FOUR_THIRDS*mu_s
+ lambda_s = lambdaplus2mu_s - 2.d0*mu_s
+ lambdaplus2mu_fr = kappa_fr + FOUR_THIRDS*mu_fr
+ lambda_fr = lambdaplus2mu_fr - 2.d0*mu_fr
+ phi = val2
+ tortuosity = val3
+
+ ! Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+
+ call get_poroelastic_velocities(cpIsquare,cpIIsquare,cssquare, &
+ H_biot,C_biot,M_biot,mu_fr,phi, &
+ tortuosity,density(1),density(2),eta_f, &
+ val4,f0,freq0,Q0,w_c,TURN_VISCATTENUATION_ON)
+
+ porosity_array(n) = val2
+ tortuosity_array(n) = val3
+ permeability(1,n) = val4
+ permeability(2,n) = val5
+ permeability(3,n) = val6
+
+ ! Young modulus for the solid phase
+ young_s = 9.d0*kappa_s*mu_s/(3.d0*kappa_s + mu_s)
+
+ ! Poisson's ratio for the solid phase
+ poisson_s = HALF*(3.d0*kappa_s- 2.d0*mu_s)/(3.d0*kappa_s+mu_s)
+
+ ! Poisson's ratio must be between -1 and +1/2
+ if (poisson_s < -1.d0 .or. poisson_s > 0.5d0) stop 'Poisson''s ratio for the solid phase out of range'
+
+ else
+ call exit_MPI('wrong model flag read')
+
+ endif
+
+ !
+ !---- set elastic coefficients and density
+ !
+ ! Isotropic : lambda, mu, K (= lambda + 2*mu), zero
+ ! Transverse anisotropic : c11, c13, c33, c44
+ !
+ if(indic == 1) then
+ density_array(1,n) = density(1)
+ poroelastcoef(1,1,n) = lambda
+ poroelastcoef(2,1,n) = mu
+ poroelastcoef(3,1,n) = lambdaplus2mu
+ poroelastcoef(4,1,n) = zero
+ Qp_array(n) = Qp
+ Qs_array(n) = Qs
+ if(mu > TINYVAL) then
+ porosity_array(n) = 0.d0
+ else
+ porosity_array(n) = 1.d0
+ endif
+ elseif (indic == 2) then
+ density_array(1,n) = density(1)
+! dummy poroelastcoef values, trick to avoid floating invalid
+ poroelastcoef(1,1,n) = lambda
+ poroelastcoef(2,1,n) = mu
+ poroelastcoef(3,1,n) = lambdaplus2mu
+ poroelastcoef(4,1,n) = zero
+ aniso_array(1,n) = c11
+ aniso_array(2,n) = c13
+ aniso_array(3,n) = c15
+ aniso_array(4,n) = c33
+ aniso_array(5,n) = c35
+ aniso_array(6,n) = c55
+! dummy Q values, trick to avoid a bug in attenuation_model
+ Qp_array(n) = 15
+ Qs_array(n) = 15
+ porosity_array(n) = 0.d0
+ elseif (indic == 3) then
+ density_array(1,n) = density(1)
+ density_array(2,n) = density(2)
+ poroelastcoef(1,1,n) = lambda_s
+ poroelastcoef(2,1,n) = mu_s ! = mu_fr
+ poroelastcoef(3,1,n) = lambdaplus2mu_s
+ poroelastcoef(4,1,n) = zero
+
+ poroelastcoef(1,2,n) = kappa_f
+ poroelastcoef(2,2,n) = eta_f
+ poroelastcoef(3,2,n) = zero
+ poroelastcoef(4,2,n) = zero
+
+ poroelastcoef(1,3,n) = lambda_fr
+ poroelastcoef(2,3,n) = mu_fr
+ poroelastcoef(3,3,n) = lambdaplus2mu_fr
+ poroelastcoef(4,3,n) = zero
+ Qp_array(n) = 10.d0 ! dummy for attenuation_model
+ Qs_array(n) = Qs
+ endif
+
+ !
+ !---- check what has been read
+ !
+ if(myrank == 0 .and. ipass == 1) then
+ if(indic == 1) then
+ ! material can be acoustic (fluid) or elastic (solid)
+ if(poroelastcoef(2,1,n) > TINYVAL) then ! elastic
+ write(IOUT,200) n,cp,cs,density(1),poisson,lambda,mu,kappa,young,Qp,Qs
+ else ! acoustic
+ write(IOUT,300) n,cp,density(1),kappa,Qp,Qs
+ endif
+ elseif(indic == 2) then ! elastic (anisotropic)
+ write(IOUT,400) n,density(1),c11,c13,c15,c33,c35,c55
+ elseif(indic == 3) then
+ ! material is poroelastic (solid/fluid)
+ write(iout,500) n,sqrt(cpIsquare),sqrt(cpIIsquare),sqrt(cssquare)
+ write(iout,600) density(1),poisson_s,lambda_s,mu_s,kappa_s,young_s
+ write(iout,700) density(2),kappa_f,eta_f
+ write(iout,800) lambda_fr,mu_fr,kappa_fr,porosity_array(n),tortuosity_array(n),&
+ permeability(1,n),permeability(2,n),permeability(3,n),Qs
+ write(iout,900) D_biot,H_biot,C_biot,M_biot,w_c
+ endif
+ endif
+
+ enddo
+
+ !
+ !---- formats
+ !
+100 format(//,' M a t e r i a l s e t s : ', &
+ ' 2 D (p o r o) e l a s t i c i t y', &
+ /1x,54('='),//5x,'Number of material sets . . . . . . (numat) =',i6)
+
+200 format(//5x,'----------------------------------------',/5x, &
+ '-- Elastic (solid) isotropic material --',/5x, &
+ '----------------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
+ 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
+ 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8,/5x, &
+ 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
+ 'Poisson''s ratio. . . . . . . . .(poisson) =',1pe15.8,/5x, &
+ 'First Lame parameter Lambda. . . (lambda) =',1pe15.8,/5x, &
+ 'Second Lame parameter Mu. . . . . . .(mu) =',1pe15.8,/5x, &
+ 'Bulk modulus Kappa . . . . . . . .(kappa) =',1pe15.8,/5x, &
+ 'Young''s modulus E. . . . . . . . .(young) =',1pe15.8,/5x, &
+ 'Qp_attenuation. . . . . . . . . . . .(Qp) =',1pe15.8,/5x, &
+ 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
+
+300 format(//5x,'-------------------------------',/5x, &
+ '-- Acoustic (fluid) material --',/5x, &
+ '-------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
+ 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
+ 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
+ 'Bulk modulus Kappa . . . . . . . .(kappa) =',1pe15.8,/5x, &
+ 'Qp_attenuation. . . . . . . . . . . .(Qp) =',1pe15.8,/5x, &
+ 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
+
+400 format(//5x,'-------------------------------------',/5x, &
+ '-- Transverse anisotropic material --',/5x, &
+ '-------------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
+ 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
+ 'c11 coefficient (Pascal). . . . . . (c11) =',1pe15.8,/5x, &
+ 'c13 coefficient (Pascal). . . . . . (c13) =',1pe15.8,/5x, &
+ 'c15 coefficient (Pascal). . . . . . (c15) =',1pe15.8,/5x, &
+ 'c33 coefficient (Pascal). . . . . . (c33) =',1pe15.8,/5x, &
+ 'c35 coefficient (Pascal). . . . . . (c35) =',1pe15.8,/5x, &
+ 'c55 coefficient (Pascal). . . . . . (c55) =',1pe15.8,/5x)
+
+500 format(//5x,'----------------------------------------',/5x, &
+ '-- Poroelastic isotropic material --',/5x, &
+ '----------------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
+ 'First P-wave velocity. . . . . . . . . . . (cpI) =',1pe15.8,/5x, &
+ 'Second P-wave velocity. . . . . . . . . . . (cpII) =',1pe15.8,/5x, &
+ 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8)
+
+600 format(//5x,'-------------------------------',/5x, &
+ '-- Solid phase properties --',/5x, &
+ 'Mass density. . . . . . . . . . (density_s) =',1pe15.8,/5x, &
+ 'Poisson''s ratio. . . . . . . . .(poisson_s) =',1pe15.8,/5x, &
+ 'First Lame parameter Lambda. . . (lambda_s) =',1pe15.8,/5x, &
+ 'Second Lame parameter Mu. . . . . . .(mu_s) =',1pe15.8,/5x, &
+ 'Solid bulk modulus Kappa . . . . . . . .(kappa_s) =',1pe15.8,/5x, &
+ 'Young''s modulus E. . . . . . . . .(young_s) =',1pe15.8)
+
+700 format(//5x,'-------------------------------',/5x, &
+ '-- Fluid phase properties --',/5x, &
+ 'Mass density. . . . . . . . . . (density_f) =',1pe15.8,/5x, &
+ 'Fluid bulk modulus Kappa . . . . . . . .(kappa_f) =',1pe15.8,/5x, &
+ 'Fluid viscosity Eta . . . . . . . .(eta_f) =',1pe15.8)
+
+800 format(//5x,'-------------------------------',/5x, &
+ '-- Frame properties --',/5x, &
+ 'First Lame parameter Lambda. . . (lambda_fr) =',1pe15.8,/5x, &
+ 'Second Lame parameter Mu. . . . . . .(mu_fr) =',1pe15.8,/5x, &
+ 'Frame bulk modulus Kappa . . . . . . . .(kappa_fr) =',1pe15.8,/5x, &
+ 'Porosity. . . . . . . . . . . . . . . . .(phi) =',1pe15.8,/5x,&
+ 'Tortuosity. . . . . . . . . . . . . . . . .(c) =',1pe15.8,/5x,&
+ 'Permeability xx component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Permeability zx component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Permeability zz component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
+
+900 format(//5x,'-------------------------------',/5x, &
+ '-- Biot coefficients --',/5x, &
+ '-------------------------------',/5x, &
+ 'D. . . . . . . . =',1pe15.8,/5x, &
+ 'H. . . . . . . . =',1pe15.8,/5x, &
+ 'C. . . . . . . . =',1pe15.8,/5x, &
+ 'M. . . . . . . . =',1pe15.8,/5x, &
+ 'characteristic freq =',1pe15.8)
+
+ end subroutine gmat01
+
Copied: seismo/2D/SPECFEM2D/trunk/src/include_for_periodic_conditions.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/include_for_periodic_conditions.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/include_for_periodic_conditions.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/include_for_periodic_conditions.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,105 @@
+
+!----------------------------------------------------------------------
+ do ispecperio2 = 1,NSPEC_PERIO
+
+ ispec2 = numperio_right(ispecperio2)
+
+ if(codeabs_perio_right(ILEFT,ispecperio2)) then
+ i2 = 1
+ do j2 = 1,NGLLZ
+ iglob2 = ibool(i2,j2,ispec2)
+ if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
+ (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
+ print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
+! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
+! print *,ispec,i,j,ispec2,i2,j2
+! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
+!--------------------------------------------------------------------------------
+ iglob_target_to_replace = ibool(i2,j2,ispec2)
+ do ispec3 = 1,nspec
+ do j3 = 1,NGLLZ
+ do i3 = 1,NGLLX
+ if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
+ enddo
+ enddo
+ enddo
+!--------------------------------------------------------------------------------
+ endif
+ enddo
+ endif
+
+ if(codeabs_perio_right(IRIGHT,ispecperio2)) then
+ i2 = NGLLX
+ do j2 = 1,NGLLZ
+ iglob2 = ibool(i2,j2,ispec2)
+ if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
+ (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
+ print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
+! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
+! print *,ispec,i,j,ispec2,i2,j2
+! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
+!--------------------------------------------------------------------------------
+ iglob_target_to_replace = ibool(i2,j2,ispec2)
+ do ispec3 = 1,nspec
+ do j3 = 1,NGLLZ
+ do i3 = 1,NGLLX
+ if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
+ enddo
+ enddo
+ enddo
+!--------------------------------------------------------------------------------
+ endif
+ enddo
+ endif
+
+ if(codeabs_perio_right(IBOTTOM,ispecperio2)) then
+ j2 = 1
+ do i2 = 1,NGLLX
+ iglob2 = ibool(i2,j2,ispec2)
+ if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
+ (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
+ print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
+! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
+! print *,ispec,i,j,ispec2,i2,j2
+! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
+!--------------------------------------------------------------------------------
+ iglob_target_to_replace = ibool(i2,j2,ispec2)
+ do ispec3 = 1,nspec
+ do j3 = 1,NGLLZ
+ do i3 = 1,NGLLX
+ if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
+ enddo
+ enddo
+ enddo
+!--------------------------------------------------------------------------------
+ endif
+ enddo
+ endif
+
+ if(codeabs_perio_right(ITOP,ispecperio2)) then
+ j2 = NGLLZ
+ do i2 = 1,NGLLX
+ iglob2 = ibool(i2,j2,ispec2)
+ if(sqrt(abs(coord(2,iglob) - coord(2,iglob2))**2 + &
+ (abs(coord(1,iglob) - coord(1,iglob2)) - PERIODIC_horiz_dist)**2) < PERIODIC_DETECT_TOL) then
+ print *,iglob,' and ',iglob2,' are the same periodic point, merging them'
+! print *,'horiz dist is = ',abs(coord(1,iglob) - coord(1,iglob2))
+! print *,ispec,i,j,ispec2,i2,j2
+! ibool(i2,j2,ispec2) = ibool(i,j,ispec)
+!--------------------------------------------------------------------------------
+ iglob_target_to_replace = ibool(i2,j2,ispec2)
+ do ispec3 = 1,nspec
+ do j3 = 1,NGLLZ
+ do i3 = 1,NGLLX
+ if(ibool(i3,j3,ispec3) == iglob_target_to_replace) ibool(i3,j3,ispec3) = ibool(i,j,ispec)
+ enddo
+ enddo
+ enddo
+!--------------------------------------------------------------------------------
+ endif
+ enddo
+ endif
+
+ enddo
+!----------------------------------------------------------------------
+
Copied: seismo/2D/SPECFEM2D/trunk/src/initialize_simulation.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/initialize_simulation.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/initialize_simulation.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/initialize_simulation.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,120 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine initialize_simulation(nproc,myrank,NUMBER_OF_PASSES, &
+ ninterface_acoustic,ninterface_elastic,ninterface_poroelastic)
+
+ implicit none
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: nproc,myrank,NUMBER_OF_PASSES
+ integer :: ninterface_acoustic, ninterface_elastic,ninterface_poroelastic
+
+ ! local parameters
+ integer :: ier
+ character(len=256) :: prname
+
+!***********************************************************************
+!
+! i n i t i a l i z a t i o n p h a s e
+!
+!***********************************************************************
+
+#ifdef USE_MPI
+ call MPI_INIT(ier)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,nproc,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+ if( ier /= 0 ) call exit_MPI('error MPI initialization')
+
+ ! this is only used in the case of MPI because it distinguishes between inner and outer element
+ ! in the MPI partitions, which is meaningless in the serial case
+ if(FURTHER_REDUCE_CACHE_MISSES) then
+ NUMBER_OF_PASSES = 2
+ else
+ NUMBER_OF_PASSES = 1
+ endif
+
+#else
+ nproc = 1
+ myrank = 0
+ !ier = 0
+ !ninterface_acoustic = 0
+ !ninterface_elastic = 0
+ !ninterface_poroelastic = 0
+ !iproc = 0
+ !ispec_inner = 0
+ !ispec_outer = 0
+
+ if(PERFORM_CUTHILL_MCKEE) then
+ NUMBER_OF_PASSES = 2
+ else
+ NUMBER_OF_PASSES = 1
+ endif
+#endif
+
+ ninterface_acoustic = 0
+ ninterface_elastic = 0
+ ninterface_poroelastic = 0
+
+ ! determine if we write to file instead of standard output
+ if(IOUT /= ISTANDARD_OUTPUT) then
+
+#ifdef USE_MPI
+ write(prname,240) myrank
+ 240 format('simulation_results',i5.5,'.txt')
+#else
+ prname = 'simulation_results.txt'
+#endif
+
+ open(IOUT,file=prname,status='unknown',action='write',iostat=ier)
+ if( ier /= 0 ) call exit_MPI('error opening file simulation_results***.txt')
+
+ endif
+
+ end subroutine initialize_simulation
Copied: seismo/2D/SPECFEM2D/trunk/src/invert_mass_matrix.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/invert_mass_matrix.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/invert_mass_matrix.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/invert_mass_matrix.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,206 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine invert_mass_matrix_init(any_elastic,any_acoustic,any_poroelastic, &
+ rmass_inverse_elastic,npoin_elastic, &
+ rmass_inverse_acoustic,npoin_acoustic, &
+ rmass_s_inverse_poroelastic, &
+ rmass_w_inverse_poroelastic,npoin_poroelastic, &
+ nspec,ibool,kmato,wxgll,wzgll,jacobian, &
+ elastic,poroelastic, &
+ assign_external_model,numat, &
+ density,poroelastcoef,porosity,tortuosity, &
+ vpext,rhoext)
+
+! builds the global mass matrix
+
+ implicit none
+ include 'constants.h'
+
+ logical any_elastic,any_acoustic,any_poroelastic
+
+ ! inverse mass matrices
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(npoin_elastic) :: rmass_inverse_elastic
+
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: rmass_inverse_acoustic
+
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(npoin_poroelastic) :: &
+ rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
+
+ integer :: nspec
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wzgll
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: jacobian
+
+ logical,dimension(nspec) :: elastic,poroelastic
+
+ logical :: assign_external_model
+ integer :: numat
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,rhoext
+
+ ! local parameters
+ integer :: ispec,i,j,iglob
+ double precision :: rhol,kappal,mul_relaxed,lambdal_relaxed
+ double precision :: rhol_s,rhol_f,rhol_bar,phil,tortl
+
+ ! initializes mass matrix
+ if(any_elastic) rmass_inverse_elastic(:) = 0._CUSTOM_REAL
+ if(any_poroelastic) rmass_s_inverse_poroelastic(:) = 0._CUSTOM_REAL
+ if(any_poroelastic) rmass_w_inverse_poroelastic(:) = 0._CUSTOM_REAL
+ if(any_acoustic) rmass_inverse_acoustic(:) = 0._CUSTOM_REAL
+
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+
+ ! if external density model (elastic or acoustic)
+ if(assign_external_model) then
+ rhol = rhoext(i,j,ispec)
+ kappal = rhol * vpext(i,j,ispec)**2
+ else
+ rhol = density(1,kmato(ispec))
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ kappal = lambdal_relaxed + 2.d0/3.d0*mul_relaxed
+ endif
+
+ if( poroelastic(ispec) ) then
+
+ ! material is poroelastic
+
+ rhol_s = density(1,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ rhol_bar = (1.d0-phil)*rhol_s + phil*rhol_f
+
+ ! for the solid mass matrix
+ rmass_s_inverse_poroelastic(iglob) = rmass_s_inverse_poroelastic(iglob) &
+ + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar - phil*rhol_f/tortl)
+ ! for the fluid mass matrix
+ rmass_w_inverse_poroelastic(iglob) = rmass_w_inverse_poroelastic(iglob) &
+ + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar*rhol_f*tortl &
+ - phil*rhol_f*rhol_f)/(rhol_bar*phil)
+
+ elseif( elastic(ispec) ) then
+
+ ! for elastic medium
+
+ rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) &
+ + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
+
+ else
+
+ ! for acoustic medium
+
+ rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) &
+ + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / kappal
+
+ endif
+
+ enddo
+ enddo
+ enddo ! do ispec = 1,nspec
+
+ end subroutine invert_mass_matrix_init
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine invert_mass_matrix(any_elastic,any_acoustic,any_poroelastic, &
+ rmass_inverse_elastic,npoin_elastic, &
+ rmass_inverse_acoustic,npoin_acoustic, &
+ rmass_s_inverse_poroelastic, &
+ rmass_w_inverse_poroelastic,npoin_poroelastic)
+
+! inverts the global mass matrix
+
+ implicit none
+ include 'constants.h'
+
+ logical any_elastic,any_acoustic,any_poroelastic
+
+! inverse mass matrices
+ integer :: npoin_elastic
+ real(kind=CUSTOM_REAL), dimension(npoin_elastic) :: rmass_inverse_elastic
+
+ integer :: npoin_acoustic
+ real(kind=CUSTOM_REAL), dimension(npoin_acoustic) :: rmass_inverse_acoustic
+
+ integer :: npoin_poroelastic
+ real(kind=CUSTOM_REAL), dimension(npoin_poroelastic) :: &
+ rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
+
+
+! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ if(any_elastic) &
+ where(rmass_inverse_elastic <= 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
+ if(any_poroelastic) &
+ where(rmass_s_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_s_inverse_poroelastic = 1._CUSTOM_REAL
+ if(any_poroelastic) &
+ where(rmass_w_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_w_inverse_poroelastic = 1._CUSTOM_REAL
+ if(any_acoustic) &
+ where(rmass_inverse_acoustic <= 0._CUSTOM_REAL) rmass_inverse_acoustic = 1._CUSTOM_REAL
+
+! compute the inverse of the mass matrix
+ if(any_elastic) &
+ rmass_inverse_elastic(:) = 1._CUSTOM_REAL / rmass_inverse_elastic(:)
+ if(any_poroelastic) &
+ rmass_s_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_s_inverse_poroelastic(:)
+ if(any_poroelastic) &
+ rmass_w_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_w_inverse_poroelastic(:)
+ if(any_acoustic) &
+ rmass_inverse_acoustic(:) = 1._CUSTOM_REAL / rmass_inverse_acoustic(:)
+
+ end subroutine invert_mass_matrix
Copied: seismo/2D/SPECFEM2D/trunk/src/is_in_convex_quadrilateral.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/is_in_convex_quadrilateral.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/is_in_convex_quadrilateral.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/is_in_convex_quadrilateral.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,77 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine is_in_convex_quadrilateral(elmnt_coords, x_coord, z_coord, is_in)
+
+ implicit none
+
+ double precision, dimension(2,4) :: elmnt_coords
+ double precision, intent(in) :: x_coord, z_coord
+ logical, intent(out) :: is_in
+
+ real :: x1, x2, x3, x4, z1, z2, z3, z4
+ real :: normal1, normal2, normal3, normal4
+
+ x1 = elmnt_coords(1,1)
+ x2 = elmnt_coords(1,2)
+ x3 = elmnt_coords(1,3)
+ x4 = elmnt_coords(1,4)
+ z1 = elmnt_coords(2,1)
+ z2 = elmnt_coords(2,2)
+ z3 = elmnt_coords(2,3)
+ z4 = elmnt_coords(2,4)
+
+ normal1 = (z_coord-z1) * (x2-x1) - (x_coord-x1) * (z2-z1)
+ normal2 = (z_coord-z2) * (x3-x2) - (x_coord-x2) * (z3-z2)
+ normal3 = (z_coord-z3) * (x4-x3) - (x_coord-x3) * (z4-z3)
+ normal4 = (z_coord-z4) * (x1-x4) - (x_coord-x4) * (z1-z4)
+
+ if ((normal1 < 0) .or. (normal2 < 0) .or. (normal3 < 0) .or. (normal4 < 0)) then
+ is_in = .false.
+ else
+ is_in = .true.
+ endif
+
+ end subroutine is_in_convex_quadrilateral
+
Copied: seismo/2D/SPECFEM2D/trunk/src/lagrange_poly.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/lagrange_poly.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/lagrange_poly.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,162 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ double precision function hgll(I,Z,ZGLL,NZ)
+
+!-------------------------------------------------------------
+!
+! Compute the value of the Lagrangian interpolant L through
+! the NZ Gauss-Lobatto Legendre points ZGLL at point Z
+!
+!-------------------------------------------------------------
+
+ implicit none
+
+ integer i,nz
+ double precision z
+ double precision ZGLL(0:nz-1)
+
+ integer n
+ double precision EPS,DZ,ALFAN
+ double precision, external :: PNLEG,PNDLEG
+
+ EPS = 1.d-5
+ DZ = Z - ZGLL(I)
+ if(abs(DZ) < EPS) then
+ HGLL = 1.d0
+ return
+ endif
+ N = NZ - 1
+ ALFAN = dble(N)*(dble(N)+1.d0)
+ HGLL = - (1.d0-Z*Z)*PNDLEG(Z,N)/ (ALFAN*PNLEG(ZGLL(I),N)*(Z-ZGLL(I)))
+
+ end function hgll
+
+!
+!=====================================================================
+!
+
+ subroutine lagrange_any(xi,NGLL,xigll,h,hprime)
+
+! subroutine to compute the Lagrange interpolants based upon the GLL points
+! and their first derivatives at any point xi in [-1,1]
+
+ implicit none
+
+ integer NGLL
+ double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)
+
+ integer dgr,i,j
+ double precision prod1,prod2
+
+ do dgr=1,NGLL
+
+ prod1 = 1.0d0
+ prod2 = 1.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1 = prod1*(xi-xigll(i))
+ prod2 = prod2*(xigll(dgr)-xigll(i))
+ endif
+ enddo
+ h(dgr)=prod1/prod2
+
+ hprime(dgr)=0.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1=1.0d0
+ do j=1,NGLL
+ if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
+ enddo
+ hprime(dgr) = hprime(dgr)+prod1
+ endif
+ enddo
+ hprime(dgr) = hprime(dgr)/prod2
+
+ enddo
+
+ end subroutine lagrange_any
+
+!
+!=====================================================================
+!
+
+! subroutine to compute the derivative of the Lagrange interpolants
+! at the GLL points at any given GLL point
+
+ double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the derivative of the I-th
+! Lagrange interpolant through the
+! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
+!
+!------------------------------------------------------------------------
+
+ implicit none
+
+ integer i,j,nz
+ double precision zgll(0:nz-1)
+
+ integer degpoly
+
+ double precision, external :: pnleg,pndleg
+
+ degpoly = nz - 1
+ if (i == 0 .and. j == 0) then
+ lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == degpoly .and. j == degpoly) then
+ lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == j) then
+ lagrange_deriv_GLL = 0.d0
+ else
+ lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
+ (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
+ + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
+ (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
+ endif
+
+ end function lagrange_deriv_GLL
+
Copied: seismo/2D/SPECFEM2D/trunk/src/locate_receivers.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/locate_receivers.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/locate_receivers.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/locate_receivers.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,317 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!----
+!---- locate_receivers finds the correct position of the receivers
+!----
+
+ subroutine locate_receivers(ibool,coord,nspec,npoin,xigll,zigll, &
+ nrec,nrecloc,recloc,which_proc_receiver,nproc,myrank, &
+ st_xval,st_zval,ispec_selected_rec, &
+ xi_receiver,gamma_receiver,station_name,network_name, &
+ x_source,z_source, &
+ coorg,knods,ngnod,npgeo,ipass, &
+ x_final_receiver, z_final_receiver)
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer nrec,nspec,npoin,ngnod,npgeo,ipass
+ integer, intent(in) :: nproc, myrank
+
+ integer knods(ngnod,nspec)
+ double precision coorg(NDIM,npgeo)
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! array containing coordinates of the points
+ double precision coord(NDIM,npoin)
+
+ integer irec,i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
+
+ double precision x_source,z_source,dist,stele,stbur
+ double precision, dimension(nrec) :: distance_receiver
+ double precision xi,gamma,dx,dz,dxi,dgamma
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision zigll(NGLLZ)
+
+ double precision x,z,xix,xiz,gammax,gammaz,jacobian
+
+! use dynamic allocation
+ double precision distmin
+ double precision, dimension(:), allocatable :: final_distance
+
+! receiver information
+ integer :: nrecloc
+ integer, dimension(nrec) :: ispec_selected_rec, recloc
+ double precision, dimension(nrec) :: xi_receiver,gamma_receiver
+
+! station information for writing the seismograms
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ double precision, dimension(nrec) :: st_xval,st_zval
+
+! tangential detection
+ double precision, dimension(nrec) :: x_final_receiver, z_final_receiver
+
+ double precision, dimension(nrec,nproc) :: gather_final_distance
+ double precision, dimension(nrec,nproc) :: gather_xi_receiver, gather_gamma_receiver
+ integer, dimension(nrec,nproc) :: gather_ispec_selected_rec
+ integer, dimension(nrec), intent(inout) :: which_proc_receiver
+ integer :: ierror
+
+
+ ierror = 0
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ierror)
+#endif
+
+! **************
+
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) '********************'
+ write(IOUT,*) ' locating receivers'
+ write(IOUT,*) '********************'
+ write(IOUT,*)
+ write(IOUT,*) 'reading receiver information from the DATA/STATIONS file'
+ write(IOUT,*)
+ endif
+
+ open(unit=1,file='DATA/STATIONS_target',status='old',action='read')
+
+! allocate memory for arrays using number of stations
+ allocate(final_distance(nrec))
+
+! loop on all the stations
+ do irec=1,nrec
+
+ ! set distance to huge initial value
+ distmin=HUGEVAL
+
+ read(1,*) station_name(irec),network_name(irec),st_xval(irec),st_zval(irec),stele,stbur
+
+ ! check that station is not buried, burial is not implemented in current code
+ if(abs(stbur) > TINYVAL) call exit_MPI('stations with non-zero burial not implemented yet')
+
+ ! compute distance between source and receiver
+ distance_receiver(irec) = sqrt((st_zval(irec)-z_source)**2 + (st_xval(irec)-x_source)**2)
+
+ do ispec=1,nspec
+
+ ! loop only on points inside the element
+ ! exclude edges to ensure this point is not shared with other elements
+ do j=2,NGLLZ-1
+ do i=2,NGLLX-1
+
+ iglob = ibool(i,j,ispec)
+ dist = sqrt((st_xval(irec)-dble(coord(1,iglob)))**2 + (st_zval(irec)-dble(coord(2,iglob)))**2)
+
+ ! keep this point if it is closer to the receiver
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_rec(irec) = ispec
+ ix_initial_guess = i
+ iz_initial_guess = j
+ endif
+
+ enddo
+ enddo
+
+ ! end of loop on all the spectral elements
+ enddo
+
+
+! ****************************************
+! find the best (xi,gamma) for each receiver
+! ****************************************
+
+ ! use initial guess in xi and gamma
+ xi = xigll(ix_initial_guess)
+ gamma = zigll(iz_initial_guess)
+
+ ! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+ ! recompute jacobian for the new point
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_rec(irec),ngnod,nspec,npgeo, &
+ .true.)
+
+ ! compute distance to target location
+ dx = - (x - st_xval(irec))
+ dz = - (z - st_zval(irec))
+
+ ! compute increments
+ dxi = xix*dx + xiz*dz
+ dgamma = gammax*dx + gammaz*dz
+
+ ! update values
+ xi = xi + dxi
+ gamma = gamma + dgamma
+
+ ! impose that we stay in that element
+ ! (useful if user gives a receiver outside the mesh for instance)
+ ! we can go slightly outside the [1,1] segment since with finite elements
+ ! the polynomial solution is defined everywhere
+ ! this can be useful for convergence of itertive scheme with distorted elements
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
+
+ ! end of non linear iterations
+ enddo
+
+ ! compute final coordinates of point found
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_rec(irec),ngnod,nspec,npgeo, &
+ .true.)
+
+ ! store xi,gamma of point found
+ xi_receiver(irec) = xi
+ gamma_receiver(irec) = gamma
+
+ ! compute final distance between asked and found
+ final_distance(irec) = sqrt((st_xval(irec)-x)**2 + (st_zval(irec)-z)**2)
+
+ x_final_receiver(irec) = x
+ z_final_receiver(irec) = z
+
+ enddo
+
+ ! close receiver file
+ close(1)
+
+! elect one process for each receiver.
+#ifdef USE_MPI
+ call MPI_GATHER(final_distance(1),nrec,MPI_DOUBLE_PRECISION,&
+ gather_final_distance(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
+ call MPI_GATHER(xi_receiver(1),nrec,MPI_DOUBLE_PRECISION,&
+ gather_xi_receiver(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
+ call MPI_GATHER(gamma_receiver(1),nrec,MPI_DOUBLE_PRECISION,&
+ gather_gamma_receiver(1,1),nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierror)
+ call MPI_GATHER(ispec_selected_rec(1),nrec,MPI_INTEGER,&
+ gather_ispec_selected_rec(1,1),nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
+
+ if ( myrank == 0 ) then
+ do irec = 1, nrec
+ which_proc_receiver(irec:irec) = minloc(gather_final_distance(irec,:)) - 1
+ enddo
+ endif
+
+ call MPI_BCAST(which_proc_receiver(1),nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
+
+#else
+
+ gather_final_distance(:,1) = final_distance(:)
+
+ gather_xi_receiver(:,1) = xi_receiver(:)
+ gather_gamma_receiver(:,1) = gamma_receiver(:)
+ gather_ispec_selected_rec(:,1) = ispec_selected_rec(:)
+
+ which_proc_receiver(:) = 0
+
+#endif
+
+ nrecloc = 0
+ do irec = 1, nrec
+ if ( which_proc_receiver(irec) == myrank ) then
+ nrecloc = nrecloc + 1
+ recloc(nrecloc) = irec
+ endif
+ enddo
+
+ if (myrank == 0 .and. ipass == 1) then
+
+ do irec = 1, nrec
+ write(IOUT,*)
+ write(IOUT,*) 'Station # ',irec,' ',station_name(irec),network_name(irec)
+
+ if(gather_final_distance(irec,which_proc_receiver(irec)+1) == HUGEVAL) &
+ call exit_MPI('error locating receiver')
+
+ write(IOUT,*) ' original x: ',sngl(st_xval(irec))
+ write(IOUT,*) ' original z: ',sngl(st_zval(irec))
+ write(IOUT,*) ' distance from source: ',sngl(distance_receiver(irec))
+ write(IOUT,*) 'closest estimate found: ',sngl(gather_final_distance(irec,which_proc_receiver(irec)+1)), &
+ ' m away'
+ write(IOUT,*) ' in element ',gather_ispec_selected_rec(irec,which_proc_receiver(irec)+1)
+ write(IOUT,*) ' at process ', which_proc_receiver(irec)
+ write(IOUT,*) ' at xi,gamma coordinates = ',gather_xi_receiver(irec,which_proc_receiver(irec)+1),&
+ gather_gamma_receiver(irec,which_proc_receiver(irec)+1)
+ write(IOUT,*)
+ enddo
+
+ write(IOUT,*)
+ write(IOUT,*) 'end of receiver detection'
+ write(IOUT,*)
+
+ ! write out actual station locations (compare with STATIONS_target from meshfem2D)
+ ! NOTE: this will be written out even if generate_STATIONS = .false.
+ open(unit=15,file='DATA/STATIONS',status='unknown')
+ do irec = 1,nrec
+ write(15,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") &
+ irec,x_final_receiver(irec),z_final_receiver(irec)
+ enddo
+ close(15)
+
+ endif
+
+ ! deallocate arrays
+ deallocate(final_distance)
+
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ierror)
+#endif
+
+ end subroutine locate_receivers
+
Copied: seismo/2D/SPECFEM2D/trunk/src/locate_source_force.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/locate_source_force.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/locate_source_force.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/locate_source_force.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,257 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!----
+!---- locate_source_force finds the correct position of the point force source
+!----
+
+ subroutine locate_source_force(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
+ ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank, &
+ xi_source,gamma_source,coorg,knods,ngnod,npgeo,ipass,iglob_source)
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer nspec,npoin,ngnod,npgeo,ipass
+
+ integer knods(ngnod,nspec)
+ double precision coorg(NDIM,npgeo)
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! array containing coordinates of the points
+ double precision coord(NDIM,npoin)
+
+ integer i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
+
+ double precision x_source,z_source,dist
+ double precision xi,gamma,dx,dz,dxi,dgamma
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision zigll(NGLLZ)
+
+ double precision x,z,xix,xiz,gammax,gammaz,jacobian
+ double precision distmin,final_distance,dist_glob
+
+! source information
+ integer ispec_selected_source,is_proc_source,nb_proc_source,iglob_source
+ integer, intent(in) :: nproc, myrank
+ double precision xi_source,gamma_source
+
+#ifdef USE_MPI
+ integer, dimension(1:nproc) :: allgather_is_proc_source
+ integer, dimension(1) :: locate_is_proc_source
+ integer :: ierror
+#endif
+
+
+
+! **************
+ if ((myrank == 0 .or. nproc == 1) .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) '*******************************'
+ write(IOUT,*) ' locating force source'
+ write(IOUT,*) '*******************************'
+ write(IOUT,*)
+ endif
+
+! set distance to huge initial value
+ distmin = HUGEVAL
+
+ is_proc_source = 0
+
+ do ispec = 1,nspec
+
+! loop only on points inside the element
+! exclude edges to ensure this point is not shared with other elements
+ do j = 2,NGLLZ-1
+ do i = 2,NGLLX-1
+
+ iglob = ibool(i,j,ispec)
+ dist = sqrt((x_source-dble(coord(1,iglob)))**2 &
+ + (z_source-dble(coord(2,iglob)))**2)
+
+! keep this point if it is closer to the source
+ if(dist < distmin) then
+ iglob_source = iglob
+ distmin = dist
+ ispec_selected_source = ispec
+ ix_initial_guess = i
+ iz_initial_guess = j
+ endif
+
+ enddo
+ enddo
+
+! end of loop on all the spectral elements
+ enddo
+
+#ifdef USE_MPI
+ ! global minimum distance computed over all processes
+ call MPI_ALLREDUCE (distmin, dist_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ierror)
+
+#else
+ dist_glob = distmin
+
+#endif
+
+! check if this process contains the source
+ if ( abs(dist_glob - distmin) < TINYVAL ) is_proc_source = 1
+
+#ifdef USE_MPI
+ ! determining the number of processes that contain the source
+ ! (useful when the source is located on an interface)
+ call MPI_ALLREDUCE (is_proc_source, nb_proc_source, 1, MPI_INTEGER, &
+ MPI_SUM, MPI_COMM_WORLD, ierror)
+
+#else
+
+ nb_proc_source = is_proc_source
+
+#endif
+
+
+#ifdef USE_MPI
+ ! when several processes contain the source, we elect one of them (minimum rank).
+ if ( nb_proc_source > 1 ) then
+
+ call MPI_ALLGATHER(is_proc_source, 1, MPI_INTEGER, allgather_is_proc_source(1), &
+ 1, MPI_INTEGER, MPI_COMM_WORLD, ierror)
+ locate_is_proc_source = maxloc(allgather_is_proc_source) - 1
+
+ if ( myrank /= locate_is_proc_source(1) ) then
+ is_proc_source = 0
+ endif
+ nb_proc_source = 1
+
+ endif
+
+#endif
+
+! ****************************************
+! find the best (xi,gamma) for each source
+! ****************************************
+
+! use initial guess in xi and gamma
+ xi = xigll(ix_initial_guess)
+ gamma = zigll(iz_initial_guess)
+
+! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+! recompute jacobian for the new point
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
+ .true.)
+
+! compute distance to target location
+ dx = - (x - x_source)
+ dz = - (z - z_source)
+
+! compute increments
+ dxi = xix*dx + xiz*dz
+ dgamma = gammax*dx + gammaz*dz
+
+! update values
+ xi = xi + dxi
+ gamma = gamma + dgamma
+
+! impose that we stay in that element
+! (useful if user gives a source outside the mesh for instance)
+! we can go slightly outside the [1,1] segment since with finite elements
+! the polynomial solution is defined everywhere
+! this can be useful for convergence of itertive scheme with distorted elements
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
+
+! end of non linear iterations
+ enddo
+
+! compute final coordinates of point found
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
+ .true.)
+
+! store xi,gamma of point found
+ xi_source = xi
+ gamma_source = gamma
+
+! compute final distance between asked and found
+ final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
+
+ if (is_proc_source == 1 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Force source:'
+
+ if(final_distance == HUGEVAL) call exit_MPI('error locating force source')
+
+ write(IOUT,*) ' original x: ',sngl(x_source)
+ write(IOUT,*) ' original z: ',sngl(z_source)
+ write(IOUT,*) 'closest estimate found: ',sngl(final_distance),' m away'
+#ifdef USE_MPI
+ write(IOUT,*) ' in rank ',myrank
+#endif
+ write(IOUT,*) ' in element ',ispec_selected_source
+ write(IOUT,*) ' at xi,gamma coordinates = ',xi_source,gamma_source
+ write(IOUT,*)
+
+ write(IOUT,*)
+ write(IOUT,*) 'end of force source detection'
+ write(IOUT,*)
+ endif
+
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ierror)
+#endif
+
+ end subroutine locate_source_force
+
Copied: seismo/2D/SPECFEM2D/trunk/src/locate_source_moment_tensor.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/locate_source_moment_tensor.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/locate_source_moment_tensor.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,256 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!----
+!---- locate_source_moment_tensor finds the correct position of the moment-tensor source
+!----
+
+ subroutine locate_source_moment_tensor(ibool,coord,nspec,npoin, &
+ xigll,zigll,x_source,z_source, &
+ ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank, &
+ xi_source,gamma_source,coorg,knods,ngnod,npgeo,ipass)
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer nspec,npoin,ngnod,npgeo,ipass
+
+ integer knods(ngnod,nspec)
+ double precision coorg(NDIM,npgeo)
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! array containing coordinates of the points
+ double precision coord(NDIM,npoin)
+
+ integer i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
+
+ double precision x_source,z_source,dist
+ double precision xi,gamma,dx,dz,dxi,dgamma
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision zigll(NGLLZ)
+
+ double precision x,z,xix,xiz,gammax,gammaz,jacobian
+ double precision distmin,final_distance,dist_glob
+
+! source information
+ integer ispec_selected_source,is_proc_source,nb_proc_source
+ integer, intent(in) :: nproc, myrank
+ double precision xi_source,gamma_source
+
+#ifdef USE_MPI
+ integer, dimension(1:nproc) :: allgather_is_proc_source
+ integer, dimension(1) :: locate_is_proc_source
+ integer :: ierror
+#endif
+
+
+
+! **************
+ if ((myrank == 0 .or. nproc == 1) .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) '*******************************'
+ write(IOUT,*) ' locating moment-tensor source'
+ write(IOUT,*) '*******************************'
+ write(IOUT,*)
+ endif
+
+! set distance to huge initial value
+ distmin = HUGEVAL
+
+ is_proc_source = 0
+
+ do ispec = 1,nspec
+
+! loop only on points inside the element
+! exclude edges to ensure this point is not shared with other elements
+ do j = 2,NGLLZ-1
+ do i = 2,NGLLX-1
+
+ iglob = ibool(i,j,ispec)
+ dist = sqrt((x_source-dble(coord(1,iglob)))**2 &
+ + (z_source-dble(coord(2,iglob)))**2)
+
+! keep this point if it is closer to the source
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_source = ispec
+ ix_initial_guess = i
+ iz_initial_guess = j
+ endif
+
+ enddo
+ enddo
+
+! end of loop on all the spectral elements
+ enddo
+
+#ifdef USE_MPI
+ ! global minimum distance computed over all processes
+ call MPI_ALLREDUCE (distmin, dist_glob, 1, MPI_DOUBLE_PRECISION, &
+ MPI_MIN, MPI_COMM_WORLD, ierror)
+
+#else
+ dist_glob = distmin
+
+#endif
+
+! check if this process contains the source
+ if ( dist_glob == distmin ) is_proc_source = 1
+
+#ifdef USE_MPI
+ ! determining the number of processes that contain the source
+ ! (useful when the source is located on an interface)
+ call MPI_ALLREDUCE (is_proc_source, nb_proc_source, 1, MPI_INTEGER, &
+ MPI_SUM, MPI_COMM_WORLD, ierror)
+
+#else
+ nb_proc_source = is_proc_source
+
+#endif
+
+
+#ifdef USE_MPI
+ ! when several processes contain the source, we elect one of them (minimum rank).
+ if ( nb_proc_source > 1 ) then
+
+ call MPI_ALLGATHER(is_proc_source, 1, MPI_INTEGER, allgather_is_proc_source(1), &
+ 1, MPI_INTEGER, MPI_COMM_WORLD, ierror)
+ locate_is_proc_source = maxloc(allgather_is_proc_source) - 1
+
+ if ( myrank /= locate_is_proc_source(1) ) then
+ is_proc_source = 0
+ endif
+ nb_proc_source = 1
+
+ endif
+
+#endif
+
+! ****************************************
+! find the best (xi,gamma) for each source
+! ****************************************
+
+! use initial guess in xi and gamma
+ xi = xigll(ix_initial_guess)
+ gamma = zigll(iz_initial_guess)
+
+! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+! recompute jacobian for the new point
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
+ .true.)
+
+! compute distance to target location
+ dx = - (x - x_source)
+ dz = - (z - z_source)
+
+! compute increments
+ dxi = xix*dx + xiz*dz
+ dgamma = gammax*dx + gammaz*dz
+
+! update values
+ xi = xi + dxi
+ gamma = gamma + dgamma
+
+! impose that we stay in that element
+! (useful if user gives a source outside the mesh for instance)
+! we can go slightly outside the [1,1] segment since with finite elements
+! the polynomial solution is defined everywhere
+! this can be useful for convergence of itertive scheme with distorted elements
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
+
+! end of non linear iterations
+ enddo
+
+! compute final coordinates of point found
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian, &
+ coorg,knods,ispec_selected_source,ngnod,nspec,npgeo, &
+ .true.)
+
+! store xi,gamma of point found
+ xi_source = xi
+ gamma_source = gamma
+
+! compute final distance between asked and found
+ final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
+
+ if (is_proc_source == 1 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Moment-tensor source:'
+
+ if(final_distance == HUGEVAL) call exit_MPI('error locating moment-tensor source')
+
+ write(IOUT,*) ' original x: ',sngl(x_source)
+ write(IOUT,*) ' original z: ',sngl(z_source)
+ write(IOUT,*) 'closest estimate found: ',sngl(final_distance),' m away'
+#ifdef USE_MPI
+ write(IOUT,*) ' in rank ',myrank
+#endif
+ write(IOUT,*) ' in element ',ispec_selected_source
+ write(IOUT,*) ' at xi,gamma coordinates = ',xi_source,gamma_source
+ write(IOUT,*)
+
+ write(IOUT,*)
+ write(IOUT,*) 'end of moment-tensor source detection'
+ write(IOUT,*)
+ endif
+
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ierror)
+#endif
+
+ end subroutine locate_source_moment_tensor
+
Copied: seismo/2D/SPECFEM2D/trunk/src/meshfem2D.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/meshfem2D.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/meshfem2D.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/meshfem2D.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,942 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!========================================================================
+!
+! Basic mesh generator for SPECFEM2D
+!
+!========================================================================
+
+! If you use this code for your own research, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{VaCaSaKoVi99,
+! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
+! D. Komatitsch and J. P. Vilotte},
+! title = {Elastic wave propagation in an irregularly layered medium},
+! journal = {Soil Dynamics and Earthquake Engineering},
+! year = {1999},
+! volume = {18},
+! pages = {11-18},
+! number = {1},
+! doi = {10.1016/S0267-7261(98)00027-X}}
+!
+! @ARTICLE{LeChKoHuTr09,
+! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
+! Shouh Huang and Jeroen Tromp},
+! title = {Effects of realistic surface topography on seismic ground motion
+! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
+! method and {LiDAR DTM}},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2009},
+! volume = {99},
+! pages = {681-693},
+! number = {2A},
+! doi = {10.1785/0120080264}}
+!
+! @ARTICLE{LeChLiKoHuTr08,
+! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
+! and Bor Shouh Huang and Jeroen Tromp},
+! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
+! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2008},
+! volume = {98},
+! pages = {253-264},
+! number = {1},
+! doi = {10.1785/0120070033}}
+!
+! @ARTICLE{LeKoHuTr09,
+! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
+! title = {Effects of topography on seismic wave propagation: An example from
+! northern {T}aiwan},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2009},
+! volume = {99},
+! pages = {314-325},
+! number = {1},
+! doi = {10.1785/0120080020}}
+!
+! @ARTICLE{KoErGoMi10,
+! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
+! David Mich\'ea},
+! title = {High-order finite-element seismic wave propagation modeling with
+! {MPI} on a large {GPU} cluster},
+! journal = {J. Comput. Phys.},
+! year = {2010},
+! volume = {229},
+! pages = {7692-7714},
+! number = {20},
+! doi = {10.1016/j.jcp.2010.06.024}}
+!
+! @ARTICLE{KoGoErMi10,
+! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
+! David Mich\'ea},
+! title = {Modeling the propagation of elastic waves using spectral elements
+! on a cluster of 192 {GPU}s},
+! journal = {Computer Science Research and Development},
+! year = {2010},
+! volume = {25},
+! pages = {75-82},
+! number = {1-2},
+! doi = {10.1007/s00450-010-0109-1}}
+!
+! @ARTICLE{KoMiEr09,
+! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
+! title = {Porting a high-order finite-element earthquake modeling application
+! to {NVIDIA} graphics cards using {CUDA}},
+! journal = {Journal of Parallel and Distributed Computing},
+! year = {2009},
+! volume = {69},
+! pages = {451-460},
+! number = {5},
+! doi = {10.1016/j.jpdc.2009.01.006}}
+!
+! @ARTICLE{LiPoKoTr04,
+! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
+! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
+! journal={Bull. Seismol. Soc. Am.},
+! year = {2004},
+! volume = {94},
+! pages = {1748-1761},
+! number = {5},
+! doi = {10.1785/012004038}}
+!
+! @INCOLLECTION{ChKoViCaVaFe07,
+! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
+! Yann Capdeville and Bernard Valette and Gaetano Festa},
+! title = {Spectral Element Analysis in Seismology},
+! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
+! publisher = {Elsevier - Academic Press},
+! year = {2007},
+! editor = {Ru-Shan Wu and Val\'erie Maupin},
+! volume = {48},
+! series = {Advances in Geophysics},
+! pages = {365-419}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoLiTrSuStSh04,
+! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
+! and Christiane Stidham and John H. Shaw},
+! year=2004,
+! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
+! based upon the Spectral-Element Method},
+! journal={Bull. Seism. Soc. Am.},
+! volume=94,
+! number=1,
+! pages={187-206}}
+!
+! @ARTICLE{MoTr08,
+! author={C. Morency and J. Tromp},
+! title={Spectral-element simulations of wave propagation in poroelastic media},
+! journal={Geophys. J. Int.},
+! year=2008,
+! volume=175,
+! pages={301-345}}
+!
+! and/or other articles from http://web.univ-pau.fr/~dkomati1/publications.html
+!
+! If you use the kernel capabilities of the code, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! @ARTICLE{MoLuTr09,
+! author={C. Morency and Y. Luo and J. Tromp},
+! title={Finite-frequency kernels for wave propagation in porous media based upon adjoint methods},
+! year=2009,
+! journal={Geophys. J. Int.},
+! doi={10.1111/j.1365-246X.2009.04332}}
+!
+! If you use the METIS / SCOTCH / CUBIT non-structured capabilities, please also cite:
+!
+! @ARTICLE{MaKoBlLe08,
+! author = {R. Martin and D. Komatitsch and C. Blitz and N. {Le Goff}},
+! title = {Simulation of seismic wave propagation in an asteroid based upon
+! an unstructured {MPI} spectral-element method: blocking and non-blocking
+! communication strategies},
+! journal = {Lecture Notes in Computer Science},
+! year = {2008},
+! volume = {5336},
+! pages = {350-363}}
+!
+! version 6.1, Christina Morency and Pieyre Le Loher, March 2010:
+! - added SH (membrane) waves calculation for elastic media
+! - added support for external fully anisotropic media
+! - fixed some bugs in acoustic kernels
+!
+! version 6.0, Christina Morency and Yang Luo, August 2009:
+! - support for poroelastic media
+! - adjoint method for acoustic/elastic/poroelastic
+!
+! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, February 2008:
+! - support for CUBIT and GiD meshes
+! - MPI implementation of the code based on domain decomposition
+! with METIS or SCOTCH
+! - general fluid/solid implementation with any number, shape and orientation of
+! matching edges
+! - fluid potential of density * displacement instead of displacement
+! - absorbing edges with any normal vector
+! - general numbering of absorbing and acoustic free surface edges
+! - cleaned implementation of attenuation as in Carcione (1993)
+! - merged loops in the solver for efficiency
+! - simplified input of external model
+! - added CPU time information
+! - translated many comments from French to English
+!
+! version 5.1, Dimitri Komatitsch, January 2005:
+! - more general mesher with any number of curved layers
+! - Dirac and Gaussian time sources and corresponding convolution routine
+! - option for acoustic medium instead of elastic
+! - receivers at any location, not only grid points
+! - moment-tensor source at any location, not only a grid point
+! - color snapshots
+! - more flexible DATA/Par_file with any number of comment lines
+! - Xsu scripts for seismograms
+! - subtract t0 from seismograms
+! - seismograms and snapshots in pressure in addition to vector field
+!
+! version 5.0, Dimitri Komatitsch, May 2004:
+! - got rid of useless routines, suppressed commons etc.
+! - weak formulation based explicitly on stress tensor
+! - implementation of full anisotropy
+! - implementation of attenuation based on memory variables
+!
+! based on SPECFEM2D version 4.2, June 1998
+! (c) by Dimitri Komatitsch, Harvard University, USA
+! and Jean-Pierre Vilotte, Institut de Physique du Globe de Paris, France
+!
+! itself based on SPECFEM2D version 1.0, 1995
+! (c) by Dimitri Komatitsch and Jean-Pierre Vilotte,
+! Institut de Physique du Globe de Paris, France
+!
+
+! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
+! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
+! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement is then: u = grad(Chi) / rho
+! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+! The source in an acoustic element is a pressure source.
+! First-order acoustic-acoustic discontinuities are also handled automatically
+! because pressure is continuous at such an interface, therefore Chi_dot_dot
+! is continuous, therefore Chi is also continuous, which is consistent with
+! the spectral-element basis functions and with the assembling process.
+! This is the reason why a simple displacement potential u = grad(Chi) would
+! not work because it would be discontinuous at such an interface and would
+! therefore not be consistent with the basis functions.
+
+program meshfem2D
+
+ use part_unstruct
+ use parameter_file
+ use source_file
+ use interfaces_file
+ implicit none
+
+ include "constants.h"
+
+ ! coordinates of the grid points of the mesh
+ double precision, dimension(:,:), allocatable :: x,z
+
+ ! to compute the coordinate transformation
+ integer :: ioffset
+ double precision :: gamma,absx,a00,a01,bot0,top0
+
+ ! to store density and velocity model
+ integer, dimension(:), allocatable :: num_material
+
+ ! interface data
+ integer :: max_npoints_interface,number_of_interfaces,npoints_interface_bottom, &
+ npoints_interface_top
+ integer :: number_of_layers
+ integer :: nz,nxread,nzread
+
+ integer :: ilayer,ipoint_current
+ integer, dimension(:), pointer :: nz_layer
+ double precision, dimension(:), allocatable :: &
+ xinterface_bottom,zinterface_bottom,coefs_interface_bottom, &
+ xinterface_top,zinterface_top,coefs_interface_top
+
+ integer :: nspec
+ integer :: nbregion
+
+ ! external functions
+ integer, external :: num_4, num_9
+ double precision, external :: value_spline
+
+ ! variables used for storing info about the mesh and partitions
+ integer, dimension(:), allocatable :: my_interfaces
+ integer, dimension(:), allocatable :: my_nb_interfaces
+
+ integer :: num_start
+ integer :: num_node
+
+ ! variables used for tangential detection
+ integer :: nnodes_tangential_curve
+ double precision, dimension(:,:), allocatable :: nodes_tangential_curve
+
+#ifdef USE_SCOTCH
+ integer :: edgecut
+#endif
+
+ integer :: iproc
+ integer :: ix,iz,i,j
+ integer :: imaterial_number,inumelem
+ integer :: i_source,ios
+ double precision :: tang1,tangN
+
+ ! ***
+ ! *** read the parameter file
+ ! ***
+
+ print *,'Reading the parameter file ... '
+ print *
+
+ open(unit=IIN,file='DATA/Par_file',status='old',iostat=ios)
+ if( ios /= 0 ) stop 'error opening DATA/Par_file file'
+
+ ! reads in parameters in DATA/Par_file
+ call read_parameter_file()
+
+ ! reads in mesh elements
+ if ( read_external_mesh ) then
+ call read_external_mesh_file(mesh_file, num_start, ngnod)
+
+ else
+ call read_interfaces_file(interfacesfile,max_npoints_interface, &
+ number_of_interfaces,npoints_interface_bottom, &
+ number_of_layers,nz_layer,nx,nz,nxread,nzread,ngnod, &
+ nelmnts,elmnts)
+ endif
+
+ allocate(num_material(nelmnts))
+ num_material(:) = 0
+
+ ! assigns materials to mesh elements
+ if ( read_external_mesh ) then
+ call read_mat(materials_file, num_material)
+ else
+ call read_regions(nbregion,nb_materials,icodemat,cp,cs, &
+ rho_s,Qp,Qs,aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
+ nelmnts,num_material,nxread,nzread)
+ endif
+
+ close(IIN)
+
+ print *
+ print *,'Parameter file successfully read... '
+
+ ! reads in source descriptions
+ call read_source_file(NSOURCES)
+
+ ! reads in tangential detection
+ if (force_normal_to_surface .or. rec_normal_to_surface) then
+ open(unit=IIN,file=tangential_detection_curve_file,status='old',action='read')
+ read(IIN,*) nnodes_tangential_curve
+ allocate(nodes_tangential_curve(2,nnodes_tangential_curve))
+ do i = 1, nnodes_tangential_curve
+ read(IIN,*) nodes_tangential_curve(1,i), nodes_tangential_curve(2,i)
+ enddo
+ close(IIN)
+ else
+ nnodes_tangential_curve = 1 ! dummy values instead of 0
+ allocate(nodes_tangential_curve(2,1))
+ endif
+
+
+ !---
+
+ if(ngnod /= 4 .and. ngnod /= 9) stop 'ngnod different from 4 or 9!'
+
+ print *
+ print *,'The mesh contains ',nelmnts,' elements'
+ print *
+ print *,'Control elements have ',ngnod,' nodes'
+ print *
+
+ !---
+
+ if ( .not. read_external_mesh ) then
+ ! allocate arrays for the grid
+ allocate(x(0:nx,0:nz))
+ allocate(z(0:nx,0:nz))
+
+ x(:,:) = 0.d0
+ z(:,:) = 0.d0
+
+ ! get interface data from external file
+ print *,'Reading interface data from file DATA/',interfacesfile(1:len_trim(interfacesfile))
+ open(unit=IIN_INTERFACES,file='DATA/'//interfacesfile,status='old')
+
+ allocate(xinterface_bottom(max_npoints_interface))
+ allocate(zinterface_bottom(max_npoints_interface))
+ allocate(coefs_interface_bottom(max_npoints_interface))
+
+ allocate(xinterface_top(max_npoints_interface))
+ allocate(zinterface_top(max_npoints_interface))
+ allocate(coefs_interface_top(max_npoints_interface))
+
+ ! read number of interfaces
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,number_of_interfaces)
+
+ ! read bottom interface
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_bottom)
+
+ ! loop on all the points describing this interface
+ do ipoint_current = 1,npoints_interface_bottom
+ call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
+ xinterface_bottom(ipoint_current),zinterface_bottom(ipoint_current))
+ enddo
+
+ ! loop on all the layers
+ do ilayer = 1,number_of_layers
+
+ ! read top interface
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_top)
+
+ ! loop on all the points describing this interface
+ do ipoint_current = 1,npoints_interface_top
+ call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
+ xinterface_top(ipoint_current),zinterface_top(ipoint_current))
+ enddo
+
+ ! compute the spline for the bottom interface, impose the tangent on both edges
+ tang1 = (zinterface_bottom(2)-zinterface_bottom(1)) / (xinterface_bottom(2)-xinterface_bottom(1))
+ tangN = (zinterface_bottom(npoints_interface_bottom)-zinterface_bottom(npoints_interface_bottom-1)) / &
+ (xinterface_bottom(npoints_interface_bottom)-xinterface_bottom(npoints_interface_bottom-1))
+ call spline_construction(xinterface_bottom,zinterface_bottom,npoints_interface_bottom,tang1,tangN,coefs_interface_bottom)
+
+ ! compute the spline for the top interface, impose the tangent on both edges
+ tang1 = (zinterface_top(2)-zinterface_top(1)) / (xinterface_top(2)-xinterface_top(1))
+ tangN = (zinterface_top(npoints_interface_top)-zinterface_top(npoints_interface_top-1)) / &
+ (xinterface_top(npoints_interface_top)-xinterface_top(npoints_interface_top-1))
+ call spline_construction(xinterface_top,zinterface_top,npoints_interface_top,tang1,tangN,coefs_interface_top)
+
+ ! check if we are in the last layer, which contains topography,
+ ! and modify the position of the source accordingly if it is located exactly at the surface
+ do i_source=1,NSOURCES
+ if(source_surf(i_source) .and. ilayer == number_of_layers) &
+ zs(i_source) = value_spline(xs(i_source),xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+ enddo
+
+ ! compute the offset of this layer in terms of number of spectral elements below along Z
+ if(ilayer > 1) then
+ ioffset = sum(nz_layer(1:ilayer-1))
+ else
+ ioffset = 0
+ endif
+
+ !--- definition of the mesh
+
+ do ix = 0,nx
+
+ ! evenly spaced points along X
+ absx = xmin + (xmax - xmin) * dble(ix) / dble(nx)
+
+ ! value of the bottom and top splines
+ bot0 = value_spline(absx,xinterface_bottom,zinterface_bottom,coefs_interface_bottom,npoints_interface_bottom)
+ top0 = value_spline(absx,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+
+ do iz = 0,nz_layer(ilayer)
+
+ ! linear interpolation between bottom and top
+ gamma = dble(iz) / dble(nz_layer(ilayer))
+ a00 = 1.d0 - gamma
+ a01 = gamma
+
+ ! coordinates of the grid points
+ x(ix,iz + ioffset) = absx
+ z(ix,iz + ioffset) = a00*bot0 + a01*top0
+
+ enddo
+
+ enddo
+
+ ! the top interface becomes the bottom interface before switching to the next layer
+ npoints_interface_bottom = npoints_interface_top
+ xinterface_bottom(:) = xinterface_top(:)
+ zinterface_bottom(:) = zinterface_top(:)
+
+ enddo
+
+ close(IIN_INTERFACES)
+
+ nnodes = (nz+1)*(nx+1)
+ allocate(nodes_coords(2,nnodes))
+ if ( ngnod == 4 ) then
+ do j = 0, nz
+ do i = 0, nx
+ num_node = num_4(i,j,nxread)
+ nodes_coords(1, num_node) = x(i,j)
+ nodes_coords(2, num_node) = z(i,j)
+
+ enddo
+ enddo
+
+ else
+ do j = 0, nz
+ do i = 0, nx
+ num_node = num_9(i,j,nxread,nzread)
+ nodes_coords(1, num_node) = x(i,j)
+ nodes_coords(2, num_node) = z(i,j)
+ enddo
+ enddo
+
+ endif
+ else
+ call read_nodes_coords(nodes_coords_file)
+ endif
+
+
+ if ( read_external_mesh ) then
+ call read_acoustic_surface(free_surface_file, num_material, &
+ ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
+
+ if ( any_abs ) then
+ call read_abs_surface(absorbing_surface_file, num_start)
+ endif
+
+ else
+
+ ! count the number of acoustic free-surface elements
+ nelem_acoustic_surface = 0
+
+ ! if the surface is absorbing, it cannot be free at the same time
+ if(.not. abstop) then
+ j = nzread
+ do i = 1,nxread
+ imaterial_number = num_material((j-1)*nxread+i)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ endif
+ enddo
+ endif
+ if(.not. absbottom) then
+ j = 1
+ do i = 1,nxread
+ imaterial_number = num_material((j-1)*nxread+i)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ endif
+ enddo
+ endif
+ if(.not. absleft) then
+ i = 1
+ do j = 1,nzread
+ imaterial_number = num_material((j-1)*nxread+i)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ endif
+ enddo
+ endif
+ if(.not. absright) then
+ i = nxread
+ do j = 1,nzread
+ imaterial_number = num_material((j-1)*nxread+i)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ endif
+ enddo
+ endif
+
+
+ allocate(acoustic_surface(4,nelem_acoustic_surface))
+
+ nelem_acoustic_surface = 0
+
+ if(.not. abstop) then
+ j = nzread
+ do i = 1,nxread
+ imaterial_number = num_material((j-1)*nxread+i)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >=1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ acoustic_surface(1,nelem_acoustic_surface) = (j-1)*nxread + (i-1)
+ acoustic_surface(2,nelem_acoustic_surface) = 2
+ acoustic_surface(3,nelem_acoustic_surface) = elmnts(3+ngnod*((j-1)*nxread+i-1))
+ acoustic_surface(4,nelem_acoustic_surface) = elmnts(2+ngnod*((j-1)*nxread+i-1))
+ endif
+ enddo
+ endif
+ if(.not. absbottom) then
+ j = 1
+ do i = 1,nxread
+ imaterial_number = num_material((j-1)*nxread+i)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >=1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ acoustic_surface(1,nelem_acoustic_surface) = (j-1)*nxread + (i-1)
+ acoustic_surface(2,nelem_acoustic_surface) = 2
+ acoustic_surface(3,nelem_acoustic_surface) = elmnts(0+ngnod*((j-1)*nxread+i-1))
+ acoustic_surface(4,nelem_acoustic_surface) = elmnts(1+ngnod*((j-1)*nxread+i-1))
+ endif
+ enddo
+ endif
+ if(.not. absleft) then
+ i = 1
+ do j = 1,nzread
+ imaterial_number = num_material((j-1)*nxread+i)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >=1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ acoustic_surface(1,nelem_acoustic_surface) = (j-1)*nxread + (i-1)
+ acoustic_surface(2,nelem_acoustic_surface) = 2
+ acoustic_surface(3,nelem_acoustic_surface) = elmnts(0+ngnod*((j-1)*nxread+i-1))
+ acoustic_surface(4,nelem_acoustic_surface) = elmnts(3+ngnod*((j-1)*nxread+i-1))
+ endif
+ enddo
+ endif
+ if(.not. absright) then
+ i = nxread
+ do j = 1,nzread
+ imaterial_number = num_material((j-1)*nxread+i)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >=1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ acoustic_surface(1,nelem_acoustic_surface) = (j-1)*nxread + (i-1)
+ acoustic_surface(2,nelem_acoustic_surface) = 2
+ acoustic_surface(3,nelem_acoustic_surface) = elmnts(1+ngnod*((j-1)*nxread+i-1))
+ acoustic_surface(4,nelem_acoustic_surface) = elmnts(2+ngnod*((j-1)*nxread+i-1))
+ endif
+ enddo
+ endif
+
+ !
+ !--- definition of absorbing boundaries
+ !
+ nelemabs = 0
+ if(absbottom) nelemabs = nelemabs + nxread
+ if(abstop) nelemabs = nelemabs + nxread
+ if(absleft) nelemabs = nelemabs + nzread
+ if(absright) nelemabs = nelemabs + nzread
+
+ allocate(abs_surface(4,nelemabs))
+
+ ! generate the list of absorbing elements
+ if(nelemabs > 0) then
+ nelemabs = 0
+ do iz = 1,nzread
+ do ix = 1,nxread
+ inumelem = (iz-1)*nxread + ix
+ if(absbottom .and. iz == 1) then
+ nelemabs = nelemabs + 1
+ abs_surface(1,nelemabs) = inumelem-1
+ abs_surface(2,nelemabs) = 2
+ abs_surface(3,nelemabs) = elmnts(0+ngnod*(inumelem-1))
+ abs_surface(4,nelemabs) = elmnts(1+ngnod*(inumelem-1))
+ endif
+ if(absright .and. ix == nxread) then
+ nelemabs = nelemabs + 1
+ abs_surface(1,nelemabs) = inumelem-1
+ abs_surface(2,nelemabs) = 2
+ abs_surface(3,nelemabs) = elmnts(1+ngnod*(inumelem-1))
+ abs_surface(4,nelemabs) = elmnts(2+ngnod*(inumelem-1))
+ endif
+ if(abstop .and. iz == nzread) then
+ nelemabs = nelemabs + 1
+ abs_surface(1,nelemabs) = inumelem-1
+ abs_surface(2,nelemabs) = 2
+ abs_surface(3,nelemabs) = elmnts(3+ngnod*(inumelem-1))
+ abs_surface(4,nelemabs) = elmnts(2+ngnod*(inumelem-1))
+ endif
+ if(absleft .and. ix == 1) then
+ nelemabs = nelemabs + 1
+ abs_surface(1,nelemabs) = inumelem-1
+ abs_surface(2,nelemabs) = 2
+ abs_surface(3,nelemabs) = elmnts(0+ngnod*(inumelem-1))
+ abs_surface(4,nelemabs) = elmnts(3+ngnod*(inumelem-1))
+ endif
+ enddo
+ enddo
+ endif
+
+ endif
+
+
+ ! compute min and max of X and Z in the grid
+ print *
+ print *,'Min and max value of X in the grid = ',minval(nodes_coords(1,:)),maxval(nodes_coords(1,:))
+ print *,'Min and max value of Z in the grid = ',minval(nodes_coords(2,:)),maxval(nodes_coords(2,:))
+ print *
+
+
+ ! ***
+ ! *** create a Gnuplot file that displays the grid
+ ! ***
+ if ( .not. read_external_mesh ) then
+ call save_gnuplot_file(ngnod,nx,nz,x,z)
+ endif
+
+
+ !*****************************
+ ! partitioning
+ !*****************************
+
+ ! allocates & initializes partioning of elements
+ allocate(part(0:nelmnts-1))
+ part(:) = -1
+
+ if( nproc > 1 ) then
+ allocate(xadj_g(0:nelmnts))
+ allocate(adjncy_g(0:MAX_NEIGHBORS*nelmnts-1))
+ xadj_g(:) = 0
+ adjncy_g(:) = -1
+ endif
+
+ ! construction of the graph
+
+ ! if ngnod == 9, we work on a subarray of elements that represents the elements with four nodes (four corners) only
+ ! because the adjacency of the mesh elements can be entirely determined from the knowledge of the four corners only
+ if ( ngnod == 9 ) then
+ allocate(elmnts_bis(0:NCORNERS*nelmnts-1))
+ do i = 0, nelmnts-1
+ elmnts_bis(i*NCORNERS:i*NCORNERS+NCORNERS-1) = elmnts(i*ngnod:i*ngnod+NCORNERS-1)
+ enddo
+
+ if ( nproc > 1 ) then
+
+!! DK DK fixed problem in the previous implementation by Nicolas Le Goff:
+!! DK DK (nxread+1)*(nzread+1) is OK for a regular internal mesh only, not for non structured external meshes
+!! DK DK call mesh2dual_ncommonnodes(nelmnts, (nxread+1)*(nzread+1), elmnts_bis, xadj, adjncy, nnodes_elmnts, nodes_elmnts,1)
+!! DK DK the subset of element corners is not renumbered therefore we must still use the nnodes computed for 9 nodes here
+ ! determines maximum neighbors based on 1 common node
+ call mesh2dual_ncommonnodes(elmnts_bis,1,xadj_g,adjncy_g)
+ endif
+
+ else
+ if ( nproc > 1 ) then
+ ! determines maximum neighbors based on 1 common node
+ call mesh2dual_ncommonnodes(elmnts,1,xadj_g,adjncy_g)
+ endif
+
+ endif
+
+
+ if ( nproc == 1 ) then
+ part(:) = 0 ! single process has rank 0
+ else
+
+ ! number of common edges
+ nb_edges = xadj_g(nelmnts)
+
+ ! giving weight to edges and vertices. Currently not used.
+ call read_weights()
+
+ ! partitioning
+ select case (partitioning_method)
+
+ case(1)
+
+ do iproc = 0, nproc-2
+ part(iproc*floor(real(nelmnts)/real(nproc)):(iproc+1)*floor(real(nelmnts)/real(nproc))-1) = iproc
+ enddo
+ part(floor(real(nelmnts)/real(nproc))*(nproc-1):nelmnts-1) = nproc - 1
+
+ case(2)
+
+!#ifdef USE_METIS
+! call Part_metis(nelmnts, xadj, adjncy, vwgt, adjwgt, nproc, nb_edges, edgecut, part, metis_options)
+!#else
+! print *, 'This version of SPECFEM was not compiled with support of METIS.'
+! print *, 'Please recompile with -DUSE_METIS in order to enable use of METIS.'
+! stop
+!#endif
+ stop 'support for the METIS graph partitioner has been discontinued, please use SCOTCH (option 3) instead'
+
+ case(3)
+
+#ifdef USE_SCOTCH
+ call Part_scotch(nproc, edgecut)
+#else
+ print *, 'This version of SPECFEM was not compiled with support of SCOTCH.'
+ print *, 'Please recompile with -DUSE_SCOTCH in order to enable use of SCOTCH.'
+ stop
+#endif
+
+ end select
+
+ endif
+
+ ! beware of fluid solid edges : coupled elements are transfered to the same partition
+ if ( ngnod == 9 ) then
+ call acoustic_elastic_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
+ else
+ call acoustic_elastic_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
+ endif
+ ! beware of fluid porous edges : coupled elements are transfered to the same partition
+ if ( ngnod == 9 ) then
+ call acoustic_poro_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
+ else
+ call acoustic_poro_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
+ endif
+ ! beware of porous solid edges : coupled elements are transfered to the same partition
+ if ( ngnod == 9 ) then
+ call poro_elastic_repartitioning (elmnts_bis, nb_materials, phi, num_material, nproc)
+ else
+ call poro_elastic_repartitioning (elmnts, nb_materials, phi, num_material, nproc)
+ endif
+
+ ! local number of each element for each partition
+ call Construct_glob2loc_elmnts(nproc)
+
+ if ( ngnod == 9 ) then
+ if( allocated(nnodes_elmnts) ) deallocate(nnodes_elmnts)
+ if( allocated(nodes_elmnts) ) deallocate(nodes_elmnts)
+ allocate(nnodes_elmnts(0:nnodes-1))
+ allocate(nodes_elmnts(0:nsize*nnodes-1))
+ nnodes_elmnts(:) = 0
+ nodes_elmnts(:) = 0
+ do i = 0, ngnod*nelmnts-1
+ nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
+ nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
+ enddo
+ else
+ if ( nproc < 2 ) then
+ if( .not. allocated(nnodes_elmnts) ) allocate(nnodes_elmnts(0:nnodes-1))
+ if( .not. allocated(nodes_elmnts) ) allocate(nodes_elmnts(0:nsize*nnodes-1))
+ nnodes_elmnts(:) = 0
+ nodes_elmnts(:) = 0
+ do i = 0, ngnod*nelmnts-1
+ nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
+ nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
+ enddo
+ endif
+ endif
+
+ ! local number of each node for each partition
+ call Construct_glob2loc_nodes(nproc)
+
+ ! construct the interfaces between partitions (used for MPI assembly)
+ if ( nproc /= 1 ) then
+ if ( ngnod == 9 ) then
+ call Construct_interfaces(nproc, elmnts_bis, &
+ nb_materials, phi, num_material)
+ else
+ call Construct_interfaces(nproc, elmnts, &
+ nb_materials, phi, num_material)
+ endif
+ allocate(my_interfaces(0:ninterfaces-1))
+ allocate(my_nb_interfaces(0:ninterfaces-1))
+ endif
+
+ ! setting absorbing boundaries by elements instead of edges
+ if ( any_abs ) then
+ call merge_abs_boundaries(nb_materials, phi, num_material, ngnod)
+ endif
+
+ ! *** generate the databases for the solver
+ call save_databases(nspec,num_material, &
+ my_interfaces,my_nb_interfaces, &
+ nnodes_tangential_curve,nodes_tangential_curve)
+
+ ! print position of the source
+ do i_source=1,NSOURCES
+ print *
+ print *,'Position (x,z) of the source = ',xs(i_source),zs(i_source)
+ print *
+ enddo
+
+ !--- compute position of the receivers and write the STATIONS file
+
+ if (generate_STATIONS) then
+ call save_stations_file(nreceiverlines,nrec,xdeb,zdeb,xfin,zfin,enreg_surf_same_vertical, &
+ xinterface_top,zinterface_top,coefs_interface_top, &
+ npoints_interface_top,max_npoints_interface)
+ endif
+
+ print *
+ if (nproc == 1) then
+ print *,'This will be a serial simulation'
+ else
+ print *,'This will be a parallel simulation on ',nproc,' processors'
+ endif
+ print *
+
+end program meshfem2D
Copied: seismo/2D/SPECFEM2D/trunk/src/netlib_specfun_erf.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/netlib_specfun_erf.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/netlib_specfun_erf.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/netlib_specfun_erf.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,318 @@
+
+ subroutine calerf(ARG,RESULT,JINT)
+
+!------------------------------------------------------------------
+!
+! This routine can be freely obtained from Netlib
+! at http://www.netlib.org/specfun/erf
+!
+! Most Netlib software packages have no restrictions on their use
+! but Netlib recommends that you check with the authors to be sure.
+! See http://www.netlib.org/misc/faq.html#2.3 for details.
+!
+!------------------------------------------------------------------
+!
+! This packet evaluates erf(x) for a real argument x.
+! It contains one FUNCTION type subprogram: ERF,
+! and one SUBROUTINE type subprogram, CALERF. The calling
+! statements for the primary entries are:
+!
+! Y = ERF(X)
+!
+! The routine CALERF is intended for internal packet use only,
+! all computations within the packet being concentrated in this
+! routine. The function subprograms invoke CALERF with the
+! statement
+!
+! call CALERF(ARG,RESULT,JINT)
+!
+! where the parameter usage is as follows
+!
+! Function Parameters for CALERF
+! call ARG Result JINT
+!
+! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0
+!
+! The main computation evaluates near-minimax approximations
+! from "Rational Chebyshev approximations for the error function"
+! by William J. Cody, Math. Comp., 1969, PP. 631-638. This
+! transportable program uses rational functions that theoretically
+! approximate erf(x) and erfc(x) to at least 18 significant
+! decimal digits. The accuracy achieved depends on the arithmetic
+! system, the compiler, the intrinsic functions, and proper
+! selection of the machine-dependent constants.
+!
+!*******************************************************************
+!*******************************************************************
+!
+! Explanation of machine-dependent constants
+!
+! XMIN = the smallest positive floating-point number.
+! XINF = the largest positive finite floating-point number.
+! XNEG = the largest negative argument acceptable to ERFCX;
+! the negative of the solution to the equation
+! 2*exp(x*x) = XINF.
+! XSMALL = argument below which erf(x) may be represented by
+! 2*x/sqrt(pi) and above which x*x will not underflow.
+! A conservative value is the largest machine number X
+! such that 1.0 + X = 1.0 to machine precision.
+! XBIG = largest argument acceptable to ERFC; solution to
+! the equation: W(x) * (1-0.5/x**2) = XMIN, where
+! W(x) = exp(-x*x)/[x*sqrt(pi)].
+! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to
+! machine precision. A conservative value is
+! 1/[2*sqrt(XSMALL)]
+! XMAX = largest acceptable argument to ERFCX; the minimum
+! of XINF and 1/[sqrt(pi)*XMIN].
+!
+! Approximate IEEE double precision values are defined below.
+!
+!*******************************************************************
+!*******************************************************************
+!
+! Error returns
+!
+! The program returns ERFC = 0 for ARG >= XBIG;
+!
+! Author: William J. Cody
+! Mathematics and Computer Science Division
+! Argonne National Laboratory
+! Argonne, IL 60439, USA
+!
+! Latest modification: March 19, 1990
+!
+! Converted to Fortran90 and slightly modified by
+! Dimitri Komatitsch, University of Pau, France, November 2007.
+!
+!------------------------------------------------------------------
+
+ implicit none
+
+ integer I,JINT
+ double precision A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEEN,SQRPI, &
+ TWO,THRESHOLD,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL, &
+ Y,YSQ,ZERO
+ dimension A(5),B(4),C(9),D(8),P(6),Q(5)
+
+!------------------------------------------------------------------
+! Mathematical constants
+!------------------------------------------------------------------
+ data FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/, &
+ SQRPI/5.6418958354775628695D-1/,THRESHOLD/0.46875D0/, &
+ SIXTEEN/16.0D0/
+
+!------------------------------------------------------------------
+! Machine-dependent constants
+!------------------------------------------------------------------
+ data XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/, &
+ XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erf in first interval
+!------------------------------------------------------------------
+ data A/3.16112374387056560D00,1.13864154151050156D02, &
+ 3.77485237685302021D02,3.20937758913846947D03, &
+ 1.85777706184603153D-1/
+ data B/2.36012909523441209D01,2.44024637934444173D02, &
+ 1.28261652607737228D03,2.84423683343917062D03/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erfc in second interval
+!------------------------------------------------------------------
+ data C/5.64188496988670089D-1,8.88314979438837594D0, &
+ 6.61191906371416295D01,2.98635138197400131D02, &
+ 8.81952221241769090D02,1.71204761263407058D03, &
+ 2.05107837782607147D03,1.23033935479799725D03, &
+ 2.15311535474403846D-8/
+ data D/1.57449261107098347D01,1.17693950891312499D02, &
+ 5.37181101862009858D02,1.62138957456669019D03, &
+ 3.29079923573345963D03,4.36261909014324716D03, &
+ 3.43936767414372164D03,1.23033935480374942D03/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erfc in third interval
+!------------------------------------------------------------------
+ data P/3.05326634961232344D-1,3.60344899949804439D-1, &
+ 1.25781726111229246D-1,1.60837851487422766D-2, &
+ 6.58749161529837803D-4,1.63153871373020978D-2/
+ data Q/2.56852019228982242D00,1.87295284992346047D00, &
+ 5.27905102951428412D-1,6.05183413124413191D-2, &
+ 2.33520497626869185D-3/
+
+ X = ARG
+ Y = ABS(X)
+ if (Y <= THRESHOLD) then
+
+!------------------------------------------------------------------
+! Evaluate erf for |X| <= 0.46875
+!------------------------------------------------------------------
+ YSQ = ZERO
+ if (Y > XSMALL) YSQ = Y * Y
+ XNUM = A(5)*YSQ
+ XDEN = YSQ
+
+ do I = 1, 3
+ XNUM = (XNUM + A(I)) * YSQ
+ XDEN = (XDEN + B(I)) * YSQ
+ enddo
+
+ RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
+ if (JINT /= 0) RESULT = ONE - RESULT
+ if (JINT == 2) RESULT = EXP(YSQ) * RESULT
+ goto 800
+
+!------------------------------------------------------------------
+! Evaluate erfc for 0.46875 <= |X| <= 4.0
+!------------------------------------------------------------------
+ else if (Y <= FOUR) then
+ XNUM = C(9)*Y
+ XDEN = Y
+
+ do I = 1, 7
+ XNUM = (XNUM + C(I)) * Y
+ XDEN = (XDEN + D(I)) * Y
+ enddo
+
+ RESULT = (XNUM + C(8)) / (XDEN + D(8))
+ if (JINT /= 2) then
+ YSQ = AINT(Y*SIXTEEN)/SIXTEEN
+ DEL = (Y-YSQ)*(Y+YSQ)
+ RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+ endif
+
+!------------------------------------------------------------------
+! Evaluate erfc for |X| > 4.0
+!------------------------------------------------------------------
+ else
+ RESULT = ZERO
+ if (Y >= XBIG) then
+ if (JINT /= 2 .OR. Y >= XMAX) goto 300
+ if (Y >= XHUGE) then
+ RESULT = SQRPI / Y
+ goto 300
+ endif
+ endif
+ YSQ = ONE / (Y * Y)
+ XNUM = P(6)*YSQ
+ XDEN = YSQ
+
+ do I = 1, 4
+ XNUM = (XNUM + P(I)) * YSQ
+ XDEN = (XDEN + Q(I)) * YSQ
+ enddo
+
+ RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
+ RESULT = (SQRPI - RESULT) / Y
+ if (JINT /= 2) then
+ YSQ = AINT(Y*SIXTEEN)/SIXTEEN
+ DEL = (Y-YSQ)*(Y+YSQ)
+ RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+ endif
+ endif
+
+!------------------------------------------------------------------
+! Fix up for negative argument, erf, etc.
+!------------------------------------------------------------------
+ 300 if (JINT == 0) then
+ RESULT = (HALF - RESULT) + HALF
+ if (X < ZERO) RESULT = -RESULT
+ else if (JINT == 1) then
+ if (X < ZERO) RESULT = TWO - RESULT
+ else
+ if (X < ZERO) then
+ if (X < XNEG) then
+ RESULT = XINF
+ else
+ YSQ = AINT(X*SIXTEEN)/SIXTEEN
+ DEL = (X-YSQ)*(X+YSQ)
+ Y = EXP(YSQ*YSQ) * EXP(DEL)
+ RESULT = (Y+Y) - RESULT
+ endif
+ endif
+ endif
+
+ 800 return
+
+ end subroutine calerf
+
+!--------------------------------------------------------------------
+
+ double precision function netlib_specfun_erf(X)
+
+! This subprogram computes approximate values for erf(x).
+! (see comments heading CALERF).
+!
+! Author/date: William J. Cody, January 8, 1985
+
+ implicit none
+
+ integer JINT
+ double precision X, RESULT
+
+ JINT = 0
+ call calerf(X,RESULT,JINT)
+ netlib_specfun_erf = RESULT
+
+ end function netlib_specfun_erf
+
+!
+! Subject: RE: Can one freely use and redistribute Fortran routines "specfun" from Netlib?
+! From: Jack Dongarra
+! Date: Wed, 21 Nov 2007 10:33:45 -0500
+! To: Rusty Lusk, Dimitri Komatitsch
+!
+! Yes the code can freely be used and incorporated into other software. You
+! should of course acknowledge the use of the software.
+!
+! Hope this helps,
+!
+! Jack Dongarra
+!
+! **********************************************************************
+! Prof. Jack Dongarra; Innovative Computing Laboratory; EECS Department;
+! 1122 Volunteer Blvd; University of Tennessee; Knoxville TN 37996-3450;
+! +1-865-974-8295; http://www.cs.utk.edu/~dongarra/
+!
+! -----Original Message-----
+! From: Rusty Lusk
+! Sent: Wednesday, November 21, 2007 10:29 AM
+! To: Dimitri Komatitsch
+! Cc: Jack Dongarra
+! Subject: Re: Can one freely use and redistribute Fortran routines "specfun"
+! from Netlib?
+!
+! Netlib is managed at the University of Tennesee, not Argonne at this
+! point. I have copied Jack Dongarra on this reply; he should be able
+! to answer questions about licensing issues for code from Netlib.
+!
+! Regards,
+! Rusty
+!
+! On Nov 21, 2007, at 8:36 AM, Dimitri Komatitsch wrote:
+!
+! >
+! > Dear Sir,
+! >
+! > Can one freely use and redistribute Fortran routines "specfun" from
+! > Netlib http://netlib2.cs.utk.edu/specfun/
+! > which were written back in 1985-1990 by William J. Cody
+! > from the Mathematics and Computer Science Division at Argonne?
+! >
+! > We use one of these routines (the error function, erf())
+! > in one of our source codes, which we would like to
+! > release as open source under GPL v2+, and we therefore
+! > wonder if we could include that erf() routine in the
+! > package in a separate file (of course saying in a comment in the
+! > header that it comes from Netlib and was written by William J. Cody from
+! > Argonne).
+! >
+! > Thank you,
+! > Best regards,
+! >
+! > Dimitri Komatitsch.
+! >
+! > --
+! > Dimitri Komatitsch - dimitri.komatitsch aT univ-pau.fr
+! > Professor, University of Pau, Institut universitaire de France
+! > and INRIA Magique3D, France http://www.univ-pau.fr/~dkomati1
+! >
Copied: seismo/2D/SPECFEM2D/trunk/src/paco_beyond_critical.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/paco_beyond_critical.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/paco_beyond_critical.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/paco_beyond_critical.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,605 @@
+!
+! This subroutine was written by Paco Sanchez-Sesma and his colleagues
+! from the Autonomous University of Mexico (UNAM), Mexico City, Mexico
+!
+! original name : DISTRAFF.f
+!
+! CALCULO DE DESPLAZAMIENTOS (UX, UZ) y TRACCIONES (TX, TZ) DE CAMPO LIBRE
+! EN UN SEMIESPACIO ELASTICO Y EN LA VECINDAD DE LA SUPERFICIE
+!
+! INCIDENCIA DE ONDAS P, SV Y DE RAYLEIGH
+!
+! 7 de febrero de 2007
+!
+! modified by Dimitri Komatitsch and Ronan Madec in March 2008
+! in particular, converted to Fortran90 and to double precision
+
+subroutine paco_beyond_critical(coord,npoin,deltat,NSTEP_global,angleforce,&
+ f0,cp_local,cs_local,INCLUDE_ATTENUATION,QD,source_type,v0x_left,v0z_left,v0x_right,v0z_right,&
+ v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot,left_bound,right_bound,&
+ bot_bound,nleft,nright,nbot,displ_elastic,veloc_elastic,accel_elastic)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: f0,cp_local,cs_local,deltat,dt,TP,angleforce,QD,delta_in_period
+ logical :: INCLUDE_ATTENUATION
+ integer :: npt,NSTEP_global,source_type,nleft,nright,nbot,npoin
+
+ integer, dimension(nleft) :: left_bound
+ integer, dimension(nright) :: right_bound
+ integer, dimension(nbot) :: bot_bound
+
+ double precision, dimension(nleft,NSTEP_global) :: v0x_left,v0z_left, t0x_left,t0z_left
+ double precision, dimension(nright,NSTEP_global) :: v0x_right,v0z_right, t0x_right,t0z_right
+ double precision, dimension(nbot,NSTEP_global) :: v0x_bot,v0z_bot, t0x_bot,t0z_bot
+
+ double precision, dimension(2,npoin) :: coord
+ double precision, dimension(2,npoin) :: displ_elastic
+ double precision, dimension(2,npoin) :: veloc_elastic
+ double precision, dimension(2,npoin) :: accel_elastic
+
+ integer, dimension(:),allocatable :: local_pt
+
+ double precision, dimension(:), allocatable :: temp_field
+
+ integer :: J, indice, NSTEP_local, FLAG, N, NFREC, NFREC1
+
+ double precision :: ANU,BEALF,ALFBE,RLM,VNX,VNZ,A1,B1,TOTO,FJ,AKA,AQA,GAMR
+
+! location of the point
+ double precision :: X, Z, xmin, xmax, zmin, zmax
+ integer :: inode
+
+ complex(selected_real_kind(15,300)) :: CAKA,CAQA,UI,UR
+ complex(selected_real_kind(15,300)) :: UX,UZ,SX,SZ,SXZ,A2,B2,AL,AK,AM
+
+ complex(selected_real_kind(15,300)) :: TX,TZ
+
+ complex(selected_real_kind(15,300)), dimension(:),allocatable::Field_Ux,Field_Uz,Field_Tx,Field_Tz
+
+ double precision :: TS
+
+! to move the place where the wave reflects on free surface (offset too)
+ double precision :: offset
+
+! size of the model
+ xmin=minval(coord(1,:))
+ xmax=maxval(coord(1,:))
+ zmin=minval(coord(2,:))
+ zmax=maxval(coord(2,:))
+
+! offset of the origin of time of the Ricker (equivalent to t0 in SPECFEM2D)
+ offset=4.d0*(xmax-xmin)/5.d0
+ TS=2.d0/f0
+
+! dominant period of the Ricker (equivalent to 1/f0 in SPECFEM2D)
+ TP=1.d0/f0
+
+! find optimal period
+! if period is too small, you should see several initial plane wave on your initial field
+ delta_in_period=2.d0
+ do while(delta_in_period<1.5*abs(xmax-xmin)/cs_local)
+ delta_in_period=2.d0*delta_in_period
+ end do
+
+! test Deltat compatibility
+ DT=256.d0
+ do while(DT>deltat)
+ DT=DT/2.d0
+ end do
+ if (abs(DT-deltat)>1.0d-13) then
+ print *, "you must take a deltat as a power of two (power can be negative)"
+ print *, "for example you can take", DT
+ stop "can't go further, restart with new deltat"
+ end if
+
+ DT=deltat/2.d0
+
+ N=2
+ do while(N<2*NSTEP_global+1)
+ N=2.d0*N
+ end do
+
+ do while(DT<(delta_in_period/N))
+ N=2.d0*N
+ end do
+
+ print *, 'N found to do frequency calcul :', N
+ print *,'number of discrete frequencies = ',N/2
+ print *,'delta in period (seconds) = ',delta_in_period
+ print *,'delta in frequency (Hz) = ',1.d0/delta_in_period
+ print *,'dt (here we need deltat/2) = ', DT
+
+ NFREC=N/2
+ NFREC1=NFREC+1
+
+
+!
+! FDT: FUNCION DE TRASFERENCIA
+!
+
+! calculation of Poisson's ratio
+ ANU = (cp_local*cp_local-2.d0*cs_local*cs_local)/(2.d0*(cp_local*cp_local-cs_local*cs_local))
+ print *,"Poisson's ratio = ",ANU
+
+ UI=(0.0d0, 1.0d0)
+ UR=(1.0d0, 0.0d0)
+
+! convert angle to radians
+ GAMR = angleforce
+
+ BEALF=SQRT((1.0d0-2.0d0*ANU)/(2.0d0*(1.0d0-ANU)))
+ ALFBE=1.0d0/BEALF
+ RLM=ALFBE**2-2.0d0
+
+! flags: interior=0, left=1, right=2, bottom=3
+ do FLAG=0,3
+
+ if (FLAG==0) then
+ print *, "calcul of the initial field for every point of the mesh"
+ npt=npoin
+ allocate(local_pt(npt))
+ do inode=1,npt
+ local_pt(inode)=inode
+ end do
+ NSTEP_local=1
+ else if(FLAG==1) then
+ print *, "calcul of every time step on the left absorbing boundary"
+ npt=nleft
+ allocate(local_pt(npt))
+ local_pt=left_bound
+ NSTEP_local=NSTEP_global
+ else if(FLAG==2) then
+ print *, "calcul of every time step on the right absorbing boundary"
+ npt=nright
+ allocate(local_pt(npt))
+ local_pt=right_bound
+ NSTEP_local=NSTEP_global
+ else if(FLAG==3) then
+ print *, "calcul of every time step on the bottom absorbing boundary"
+ npt=nbot
+ allocate(local_pt(npt))
+ local_pt=bot_bound
+ NSTEP_local=NSTEP_global
+ end if
+
+! to distinguish all model case and boundary case
+ allocate(temp_field(NSTEP_local))
+
+ allocate(Field_Ux(NFREC1))
+ allocate(Field_Uz(NFREC1))
+ allocate(Field_Tx(NFREC1))
+ allocate(Field_Tz(NFREC1))
+
+
+ if(mod(N,2) /= 0) stop 'N must be a multiple of 2'
+
+! normal vector to the edge at this grid point
+! therefore corners between two grid edges must be computed twice
+! because the normal will change
+ if (FLAG==1) then
+ VNZ = 0.d0
+ VNX = 1.d0
+ else if (FLAG==2) then
+ VNZ = 0.d0
+ VNX = 1.d0
+ else if (FLAG==3) then
+ VNZ = 1.d0
+ VNX = 0.d0
+ else
+ VNZ = 0.d0
+ VNX = 0.d0
+ end if
+
+
+ do indice=1,npt
+
+ if (FLAG==0) then
+ inode=indice
+ X=coord(1,indice)-offset
+! specfem coordinate axes are implemented from bottom to top whereas for this code
+! we need from top to bottom
+ Z=zmax-coord(2,indice)
+ else
+ inode=local_pt(indice)
+ X=coord(1,inode)-offset
+! specfem coordinate axes are implemented from bottom to top whereas for this code
+! we need from top to bottom
+ Z=zmax-coord(2,inode)
+ end if
+
+ if (mod(indice,500)==0) then
+ print *, indice, "points have been treated on ",npt," total points"
+ end if
+
+!
+! first handle the particular case of zero frequency
+!
+ TOTO=0.01d0
+ IF (source_type==1) CALL ONDASP(GAMR,0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+ IF (source_type==2) CALL ONDASS(GAMR,TOTO,0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+ IF (source_type==3) CALL ONDASR(0.01d0*BEALF,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+
+
+ TOTO=0.0d0
+ CALL DESFXY(TOTO,TOTO,source_type,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
+
+! write the frequency seismograms
+ TX = SX *VNX+SXZ*VNZ
+ TZ = SXZ*VNX+SZ *VNZ
+
+ Field_Ux(1)=UX
+ Field_Uz(1)=UZ
+ if (FLAG/=0) then
+ Field_Tx(1)=TX
+ Field_Tz(1)=TZ
+ end if
+
+!
+! then loop on all the other discrete frequencies
+!
+ do J=1,N/2
+
+! compute the value of the frequency (= index * delta in frequency = index * 1/delta in period)
+ FJ = dble(J) * 1.d0 / delta_in_period
+
+! pulsation (= 2 * PI * frequency)
+ AKA=2.0d0*PI*FJ
+
+ AQA=AKA*BEALF
+
+! exclude attenuation completely if needed
+ if(INCLUDE_ATTENUATION) then
+ CAKA=CMPLX(AKA,-AKA/(2.0d0*QD))
+ CAQA=CMPLX(AQA,-AQA/(2.0d0*QD))
+ else
+ CAKA=CMPLX(AKA,0)
+ CAQA=CMPLX(AQA,0)
+ endif
+
+ IF (source_type==1) CALL ONDASP(GAMR,AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+ IF (source_type==2) CALL ONDASS(GAMR,AKA,AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+ IF (source_type==3) CALL ONDASR(AQA,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+
+ CALL DESFXY(X,Z,source_type,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
+
+! write the frequency seismograms
+ TX = SX *VNX+SXZ*VNZ
+ TZ = SXZ*VNX+SZ *VNZ
+
+ Field_Ux(J+1)=UX
+ Field_Uz(J+1)=UZ
+ if (FLAG/=0) then
+ Field_Tx(J+1)=TX
+ Field_Tz(J+1)=TZ
+ end if
+
+ enddo
+
+! to convert frequency field in time field
+! (number at the end are unit numbers for writing in the good file,
+! in the case of the traction we fill only one file per call)
+
+! global model case for initial field
+ if (FLAG==0) then
+ call paco_convolve_fft(Field_Ux,1,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ displ_elastic(1,indice)=temp_field(1)
+ call paco_convolve_fft(Field_Uz,1,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ displ_elastic(2,indice)=temp_field(1)
+ call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ veloc_elastic(1,indice)=temp_field(1)
+ call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ veloc_elastic(2,indice)=temp_field(1)
+ call paco_convolve_fft(Field_Ux,3,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ accel_elastic(1,indice)=temp_field(1)
+ call paco_convolve_fft(Field_Uz,3,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ accel_elastic(2,indice)=temp_field(1)
+
+! absorbing boundaries
+
+! left case
+ else if (FLAG==1) then
+ call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0x_left(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0z_left(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0x_left(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0z_left(indice,:)=temp_field(:)
+
+! right case
+ else if (FLAG==2) then
+ call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0x_right(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0z_right(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0x_right(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0z_right(indice,:)=temp_field(:)
+
+! bottom case
+ else if (FLAG==3) then
+ call paco_convolve_fft(Field_Ux,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0x_bot(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Uz,2,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ v0z_bot(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tx,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0x_bot(indice,:)=temp_field(:)
+ call paco_convolve_fft(Field_Tz,4,NSTEP_local,dt,NFREC,temp_field,TP,TS)
+ t0z_bot(indice,:)=temp_field(:)
+ end if
+ enddo
+
+ deallocate(temp_field)
+ deallocate(local_pt)
+
+ deallocate(Field_Ux)
+ deallocate(Field_Uz)
+ deallocate(Field_Tx)
+ deallocate(Field_Tz)
+
+ end do
+
+end subroutine paco_beyond_critical
+
+!---
+
+SUBROUTINE DESFXY(X,Z,ICAS,UX,UZ,SX,SZ,SXZ,A1,B1,A2,B2,AL,AK,AM,RLM)
+
+ implicit none
+
+ double precision A1,B1,RLM,X,Z
+ integer ICAS
+ complex(selected_real_kind(15,300)) :: UX,UZ,SX,SZ,SXZ,A2,B2,AL,AK,AM
+ complex(selected_real_kind(15,300)) :: UI,FAC
+ complex(selected_real_kind(15,300)) :: AUX1,AUX2,FI1,FI2,PS1,PS2
+
+ UI=(0.0d0,1.0d0)
+ if (A1/=0.0d0) then
+ AUX1=A1*EXP(UI*(AM*Z-AL*X)) ! campo P incidente
+ else
+ AUX1=CMPLX(0.0d0)
+ end if
+ if (A2/=0.0d0) then
+ AUX2=A2*EXP(-UI*(AM*Z+AL*X)) *1.0d0 ! campo P reflejado
+ else
+ AUX2=CMPLX(0.0d0)
+ end if
+ FI1=AUX1+AUX2
+ FI2=AUX1-AUX2
+ if (B1/=0.0d0) then
+ AUX1=B1*EXP(UI*(AK*Z-AL*X)) ! campo S incidente
+ else
+ AUX1=CMPLX(0.0d0)
+ end if
+ if (B2/=0.0d0) then
+ AUX2=B2*EXP(-UI*(AK*Z+AL*X)) *1.0d0 ! campo S reflejado
+ else
+ AUX2=CMPLX(0.0d0)
+ end if
+ PS1=AUX1+AUX2
+ PS2=AUX1-AUX2
+
+!
+! FAC ES PARA TENER CONSISTENCIA CON AKI & RICHARDS (1980)
+!
+ FAC=UI
+ IF (ICAS==2)FAC=-UI
+
+ UX=(-UI*AL*FI1+UI*AK*PS2)*FAC
+
+ UZ=(UI*AM*FI2+UI*AL*PS1)*FAC
+! Paco's convention for vertical coordinate axis is inverted
+ UZ = - UZ
+
+ AUX1=AL*AL+AM*AM
+ SX=(-RLM*AUX1*FI1-2.0d0*AL*(AL*FI1-AK*PS2))*FAC
+ SZ=(-RLM*AUX1*FI1-2.0d0*(AM*AM*FI1+AK*AL*PS2))*FAC
+
+ SXZ=(2.0d0*AM*AL*FI2+(AL*AL-AK*AK)*PS1)*FAC
+! Paco's convention for vertical coordinate axis is inverted
+ SXZ = - SXZ
+
+END SUBROUTINE DESFXY
+
+SUBROUTINE FAFB(CA,CB,FA,FB)
+
+ implicit none
+
+ double precision CA,CB,A,B
+ complex(selected_real_kind(15,300)) :: FA,FB,ZER,UI
+
+ ZER=(0.0d0,0.0d0)
+ UI=(0.0d0,1.0d0)
+ A=CA*CA-1.0d0
+ B=CB*CB-1.0d0
+
+ IF (CA<1.0d0) then
+ FA=-UI*SQRT(-A)
+ else
+ FA=SQRT(A)+ZER
+ end IF
+
+ IF (CB<1.0d0) then
+ FB=-UI*SQRT(-B)
+ else
+ FB=CMPLX(SQRT(B),0.0d0)
+ end IF
+
+END SUBROUTINE FAFB
+
+SUBROUTINE A2B2(FA,FB,A2,B2)
+
+ implicit none
+
+ complex(selected_real_kind(15,300)) :: FA,FB,A2,B2,DEN,AUX
+
+ AUX=FB*FB-1.0d0
+ DEN=4.0d0*FA*FB+AUX*AUX
+ A2=(4.0d0*FA*FB-AUX*AUX)/DEN
+ B2=4.0d0*FA*AUX/DEN
+
+END SUBROUTINE A2B2
+
+! calculation of P waves
+SUBROUTINE ONDASP(GP,AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+
+ implicit none
+
+ double precision A1,B1,ANU,CA,CB,GP,AQB,BEALF
+ complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
+
+ ZER=(0.0d0,0.0d0)
+ BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
+ A1=1.0d0/AQB
+ B1=0.0d0
+
+ IF (GP==0.0d0) then
+ AL=ZER
+ AK=ZER
+ AM=AQB+ZER
+ A2=(-1.0d0+ZER)/AQB
+ B2=ZER
+ RETURN
+ end IF
+
+ CA=1.0d0/SIN(GP)
+ CB=CA/BEALF
+ AL=AQB/CA+ZER
+ CALL FAFB(CA,CB,FA,FB)
+ AK=AL*FB
+ AM=AL*FA
+ CALL A2B2(FA,FB,A2,B2)
+ A2=A2/AQB
+ B2=B2/AQB
+
+END SUBROUTINE ONDASP
+
+! calculation of S waves
+SUBROUTINE ONDASS(GS,AKB,AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+
+ implicit none
+
+ double precision A1,B1,ANU,CA,CB,GS,AQB,BEALF,AKB
+ complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
+
+ ZER=(0.0d0,0.0d0)
+ BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
+ A1=0.0d0
+ B1=1.0d0/AKB
+
+ IF (GS==0.0d0) then
+ AL=ZER
+ AK=AKB+ZER
+ AM=ZER
+ A2=ZER
+ B2=(-1.0d0+ZER)/AKB
+ return
+ end IF
+
+ CB=1.0d0/SIN(GS)
+ CA=CB*BEALF
+
+!
+! case of the critical angle
+!
+ IF (CA==1.d0) then
+ AL=AQB+ZER
+ AM=ZER
+ CALL FAFB(CA,CB,FA,FB)
+ AK=AL*FB
+ B2=-B1
+ A2=-4.0d0*COS(GS)*B1/(1./BEALF-2.*BEALF)
+
+! case of an angle that is not critical
+ ELSE
+ AL=AQB/CA+ZER
+ CALL FAFB(CA,CB,FA,FB)
+ AK=AL*FB
+ AM=AL*FA
+ CALL A2B2(FA,FB,B2,A2)
+ A2=-A2*FB/FA
+ A2=A2/AKB
+ B2=B2/AKB
+ endif
+
+END SUBROUTINE ONDASS
+
+! calculation of Rayleigh waves
+SUBROUTINE ONDASR(AQB,A1,B1,A2,B2,AL,AK,AM,ANU,BEALF)
+
+ implicit none
+
+ double precision A1,B1,ANU,CA,CB,AQB,BEALF,ba2
+ complex(selected_real_kind(15,300)) :: A2,B2,FA,FB,ZER,AL,AK,AM
+
+ double precision, external :: crb
+
+ ZER=(0.0d0,0.0d0)
+ A1=0.0d0
+ B1=0.0d0
+ B2=1.0d0+ZER
+ BEALF=SQRT((1.0d0-2.0d0*ANU)/2.0d0/(1.0d0-ANU))
+ BA2=BEALF*BEALF
+ CB=CRB(BEALF)
+ CA=CB*BEALF
+ AL=AQB/CA+ZER
+
+ CALL FAFB(CA,CB,FA,FB)
+
+ AK=AL*FB
+ AM=AL*FA
+ A2=2.0d0*FB/(FB*FB-1.0d0)*B2
+ B2=B2/(AL*A2+AK)
+ A2=A2*B2
+
+END SUBROUTINE ONDASR
+
+FUNCTION CRB(BEALF)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision U3,BA2,P,Q,FIND,F1,F2,F12,FACT,CRB,BEALF
+
+ U3=1.0d0/3.0d0
+ BA2=BEALF*BEALF
+ P=8.0d0/3.0d0-16.0d0*BA2
+ Q=272.0d0/27.0d0-80.0d0/3.0d0*BA2
+ FIND=Q*Q/4.0d0+P*P*P/27.0d0
+ IF (FIND>=0.0d0) then
+ F1=SQRT(FIND)-Q/2.0d0
+ IF (F1>0.0d0) then
+ F1=F1**U3
+ else
+ F1=-(-F1)**U3
+ end IF
+ F2=-SQRT(FIND)-Q/2.0d0
+ IF (F2>0.0d0) then
+ F2=F2**U3
+ else
+ F2=-(-F2)**U3
+ end IF
+ FACT=F1+F2+8.0d0/3.0d0
+ CRB=SQRT(FACT)
+ else
+ F1=-27.0d0*Q*Q/(4.0d0*P*P*P)
+ F1=SQRT(F1)
+ IF (Q<0.0d0) then
+ F1=COS((PI-ACOS(F1))/3.0d0)
+ else
+ F1=COS(ACOS(F1)/3.0d0)
+ end IF
+ F2=-P/3.0d0
+ F2=SQRT(F2)
+ F12=-2.0d0*F1*F2+8.0d0/3.0d0
+ CRB=SQRT(F12)
+ end IF
+
+END FUNCTION CRB
+
Copied: seismo/2D/SPECFEM2D/trunk/src/paco_convolve_fft.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/paco_convolve_fft.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/paco_convolve_fft.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/paco_convolve_fft.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,230 @@
+!
+! This subroutine was written by Paco Sanchez-Sesma and his colleagues
+! from the Autonomous University of Mexico (UNAM), Mexico City, Mexico
+!
+! PROGRAMA PARA CALCULAR SISMOGRAMAS SINTETICOS DADA LA
+! FUNCION DE TRANSFERENCIA PARA COMPONENTES Ux, Uz, R2
+! Tx y Tz SOLUCION DE CAMPO LIBRE Caso P-SV, RAYLEIGH
+!
+! modified by Dimitri Komatitsch and Ronan Madec in March 2008
+! in particular, converted to Fortran90 and to double precision
+
+subroutine paco_convolve_fft(Field,label,NSTEP,dt,NFREC,output_field,tp,ts)
+
+ implicit none
+
+ integer :: NFREC,N,NSTEP
+
+ complex(selected_real_kind(15,300)), dimension(NFREC+1) :: Field
+
+ complex(selected_real_kind(15,300)) :: CR(2*NFREC)
+
+ double precision, dimension(NSTEP) :: output_field
+
+ integer :: J,label
+
+ double precision :: AN,FUN,RAIZ,dt,tp,ts
+
+ double precision, external :: RIC, deRIC, de2RIC
+
+ N=2*NFREC
+
+ AN = N
+
+!
+! label=1 <=> champ U en entree =>convolution par un ricker pour U
+! label=2 <=> champ U en entree =>convolution par la derivee de ricker pour V
+! label=3 <=> champ U en entree =>convolution par la derivee seconde de ricker pour A
+! label=4 <=> champ T en entree =>convolution par un ricker
+!
+! flag=0 on a besoin de U, V et A (pas T)
+! flag/=0 on a besoin de T et V (pas U ni A)
+!
+! NSTEP==1 <=> FLAG==0 (flags: interior=0, left=1, right=2, bottom=3)
+!
+
+ do j=1,N
+ if (label==1 .or. label==4) FUN=ric(j,tp,ts,dt)
+ if (label==2) FUN=deric(j,tp,ts,dt)
+ if (label==3) FUN=de2ric(j,tp,ts,dt)
+ CR(j)=CMPLX(FUN,0.0d0)
+ enddo
+
+ CALL fourier_transform(N,CR,-1.0d0)
+
+ RAIZ = SQRT(AN)
+
+ CALL SINTER(Field,output_field,NSTEP,CR,RAIZ,NFREC,label,dt)
+
+END subroutine paco_convolve_fft
+
+SUBROUTINE SINTER(V,output_field,NSTEP,CR,RAIZ,NFREC,label,dt)
+
+ implicit none
+
+ integer NSTEP, j,jn,N,label,nfrec,mult,delay
+
+ double precision :: RAIZ
+
+ complex(selected_real_kind(15,300)) :: VC
+
+ double precision VT(2*NFREC)
+
+ double precision :: filt,dt
+
+ double precision, dimension(NSTEP) :: output_field
+
+ complex(selected_real_kind(15,300)), dimension(NFREC+1) :: V
+
+ complex(selected_real_kind(15,300)) :: CY(2*NFREC),CR(2*NFREC)
+
+ N=2*NFREC
+
+ CY(1) = CR(1) * V(1) * RAIZ * dt
+
+ DO J=2,N/2+1
+ FILT = 1.0d0
+ VC = V(J)
+ CY(J)= CR(J)*VC * RAIZ * dt/ FILT
+ JN = N-J+2
+ CY(JN)=CONJG(CY(J))
+ enddo
+
+ CALL fourier_transform(N,CY,1.0d0)
+
+ if (label==1 .or. label==3 .or. (label==2 .and. NSTEP==1)) then
+! coefficients to take time steps needed (t=0: first time step)
+ mult=1
+ delay=0
+ else if(label==2 .and. NSTEP>1) then
+! coefficients to take time steps needed (t=i*deltat+1/2: one step on two starting at 1/2)
+ mult=2
+ delay=0
+ else if(label==4) then
+! coefficients to take time steps needed (t=i*deltat+1: one step on two starting at 1)
+ mult=2
+ delay=1
+ end if
+
+ do J=1,NSTEP
+ CY(mult*J+delay)=CY(mult*J+delay)/RAIZ/dt
+ VT(mult*J+delay)=REAL(CY(mult*J+delay))
+ output_field(J)=VT(mult*J+delay)
+ enddo
+
+END SUBROUTINE SINTER
+
+!
+! Ricker time function
+!
+FUNCTION RIC(J,tp,ts,dt)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: A,RIC,tp,ts,dt
+
+ integer j
+
+ A=PI*(dt*(J-1)-ts)/tp
+ A=A*A
+ RIC=0.0d0
+ IF(A>30.0d0) RETURN
+ RIC=(A-0.5)*EXP(-A)
+
+END FUNCTION RIC
+
+!
+! first time derivative of Ricker time function
+!
+FUNCTION deRIC(J,tp,ts,dt)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: A,A_dot,deRIC,tp,ts,dt
+ integer :: j
+
+ A=PI*(dt*(J-1)-ts)/tp
+ A=A*A
+ A_dot=2*(PI/tp)**2*(dt*(J-1)-ts)
+ deRIC=0.0d0
+ IF(A>30.0d0) RETURN
+ deRIC=A_dot*(1.5-A)*EXP(-A)
+
+END FUNCTION deRIC
+
+!
+! second time derivative of Ricker time function
+!
+FUNCTION de2RIC(J,tp,ts,dt)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: A,A_dot,A_dot_dot,de2RIC,tp,ts,dt
+ integer j
+
+ A=PI*(dt*(J-1)-ts)/tp
+ A=A*A
+ A_dot=2*(PI/tp)**2*(dt*(J-1)-ts)
+ A_dot_dot=2*(PI/tp)**2
+ de2RIC=0.0d0
+ IF(A>30.0d0) RETURN
+ de2RIC=(A_dot_dot*(1.5-A)-A_dot*A_dot-A_dot*(1.5-A)*A_dot)*EXP(-A)
+
+END FUNCTION de2RIC
+
+
+! Fourier transform
+SUBROUTINE fourier_transform(LX,CX,SIGNI)
+
+ implicit none
+
+ include "constants.h"
+
+ integer LX,i,j,l,istep,m
+
+ double precision SC
+
+ complex(selected_real_kind(15,300)) :: CX(LX),CARG,CW,CTEMP
+
+ double precision SIGNI
+
+ J=1
+ SC=SQRT(1.0d0/LX)
+ DO I=1,LX
+ IF (I<=J) then
+ CTEMP=CX(J)*SC
+ CX(J)=CX(I)*SC
+ CX(I)=CTEMP
+ end IF
+ M=LX/2
+ do while (M>=1 .and. M<J)
+ J=J-M
+ M=M/2
+ end do
+ J=J+M
+ end DO
+ L=1
+
+ do while(L<LX)
+ ISTEP=2*L
+ DO M=1,L
+ CARG=(0.0d0,1.0d0)*(PI*SIGNI*(M-1))/L
+ CW=EXP(CARG)
+ DO I=M,LX,ISTEP
+ CTEMP=CW*CX(I+L)
+ CX(I+L)=CX(I)-CTEMP
+ CX(I)=CX(I)+CTEMP
+ end DO
+ end DO
+
+ L=ISTEP
+ end do
+
+END SUBROUTINE fourier_transform
+
Copied: seismo/2D/SPECFEM2D/trunk/src/part_unstruct.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/part_unstruct.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/part_unstruct.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/part_unstruct.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,1654 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!
+! This module contains subroutines related to unstructured meshes and partitioning of the
+! corresponding graphs.
+!
+
+module part_unstruct
+
+ implicit none
+
+ integer :: nelmnts
+ integer, dimension(:), pointer :: elmnts
+ integer, dimension(:), allocatable :: elmnts_bis
+ integer, dimension(:), allocatable :: vwgt
+ integer, dimension(:), allocatable :: glob2loc_elmnts
+ integer, dimension(:), allocatable :: part
+
+ integer :: nb_edges
+ integer, dimension(:), allocatable :: adjwgt
+
+ integer, dimension(:), allocatable :: xadj_g
+ integer, dimension(:), allocatable :: adjncy_g
+
+ integer :: nnodes
+ double precision, dimension(:,:), allocatable :: nodes_coords
+ integer, dimension(:), allocatable :: nnodes_elmnts
+ integer, dimension(:), allocatable :: nodes_elmnts
+ integer, dimension(:), allocatable :: glob2loc_nodes_nparts
+ integer, dimension(:), allocatable :: glob2loc_nodes_parts
+ integer, dimension(:), allocatable :: glob2loc_nodes
+
+ ! interface data
+ integer :: ninterfaces
+ integer, dimension(:), allocatable :: tab_size_interfaces, tab_interfaces
+
+ integer :: nelem_acoustic_surface
+ integer, dimension(:,:), pointer :: acoustic_surface
+ integer :: nelem_acoustic_surface_loc
+
+ integer :: nelemabs
+ integer, dimension(:,:), allocatable :: abs_surface
+ logical, dimension(:,:), allocatable :: abs_surface_char
+ integer, dimension(:), allocatable :: abs_surface_merge
+ integer :: nelemabs_loc
+
+ integer :: nelemabs_merge
+ integer, dimension(:), allocatable :: ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
+ jbegin_left,jend_left,jbegin_right,jend_right
+
+ ! for acoustic/elastic coupled elements
+ integer :: nedges_coupled
+ integer, dimension(:,:), pointer :: edges_coupled
+
+ ! for acoustic/poroelastic coupled elements
+ integer :: nedges_acporo_coupled
+ integer, dimension(:,:), pointer :: edges_acporo_coupled
+
+ ! for poroelastic/elastic coupled elements
+ integer :: nedges_elporo_coupled
+ integer, dimension(:,:), pointer :: edges_elporo_coupled
+
+contains
+
+ !-----------------------------------------------
+ ! Read the mesh and storing it in array 'elmnts' (which is allocated here).
+ ! 'num_start' is used to have the numbering of the nodes starting at '0'.
+ ! 'nelmnts' is the number of elements, 'nnodes' is the number of nodes in the mesh.
+ !-----------------------------------------------
+ subroutine read_external_mesh_file(filename, num_start, ngnod)
+
+ implicit none
+ !include "constants.h"
+
+ character(len=256), intent(in) :: filename
+ integer, intent(out) :: num_start
+ integer, intent(in) :: ngnod
+
+ integer :: i,ier
+
+ open(unit=990, file=trim(filename), form='formatted' , status='old', action='read',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening file: ',trim(filename)
+ stop 'error read external mesh file'
+ endif
+
+ read(990,*) nelmnts
+
+ allocate(elmnts(0:ngnod*nelmnts-1))
+
+ do i = 0, nelmnts-1
+ if(ngnod == 4) then
+ read(990,*) elmnts(i*ngnod), elmnts(i*ngnod+1), elmnts(i*ngnod+2), elmnts(i*ngnod+3)
+ else if(ngnod == 9) then
+ read(990,*) elmnts(i*ngnod), elmnts(i*ngnod+1), elmnts(i*ngnod+2), elmnts(i*ngnod+3), &
+ elmnts(i*ngnod+4), elmnts(i*ngnod+5), elmnts(i*ngnod+6), elmnts(i*ngnod+7), elmnts(i*ngnod+8)
+ else
+ stop 'error, ngnod should be either 4 or 9 for external meshes'
+ endif
+ enddo
+
+ close(990)
+
+ num_start = minval(elmnts)
+ elmnts(:) = elmnts(:) - num_start
+ nnodes = maxval(elmnts) + 1
+
+ end subroutine read_external_mesh_file
+
+ !-----------------------------------------------
+ ! Read the nodes coordinates and storing it in array 'nodes_coords'
+ !-----------------------------------------------
+ subroutine read_nodes_coords(filename)
+
+ implicit none
+
+ character(len=256), intent(in) :: filename
+
+ integer :: i,ier
+
+ open(unit=991, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening file: ',trim(filename)
+ stop 'error read external nodes coords file'
+ endif
+
+ read(991,*) nnodes
+ allocate(nodes_coords(2,nnodes))
+ do i = 1, nnodes
+ read(991,*) nodes_coords(1,i), nodes_coords(2,i)
+ enddo
+ close(991)
+
+ end subroutine read_nodes_coords
+
+
+ !-----------------------------------------------
+ ! Read the material for each element and storing it in array 'num_materials'
+ !-----------------------------------------------
+ subroutine read_mat(filename, num_material)
+
+ implicit none
+
+ character(len=256), intent(in) :: filename
+ integer, dimension(1:nelmnts), intent(out) :: num_material
+
+ integer :: i,ier
+
+ open(unit=992, file=trim(filename), form='formatted' , status='old', action='read',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening file: ',trim(filename)
+ stop 'error read external mat file'
+ endif
+
+ do i = 1, nelmnts
+ read(992,*) num_material(i)
+ enddo
+ close(992)
+
+ end subroutine read_mat
+
+
+ !-----------------------------------------------
+ ! Read free surface.
+ ! Edges from elastic elements are discarded.
+ ! 'acoustic_surface' contains 1/ element number, 2/ number of nodes that form the free surface,
+ ! 3/ first node on the free surface, 4/ second node on the free surface, if relevant (if 2/ is equal to 2)
+ !-----------------------------------------------
+ subroutine read_acoustic_surface(filename, num_material, &
+ ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
+
+ implicit none
+
+ !include "constants.h"
+
+ character(len=256), intent(in) :: filename
+ integer, dimension(0:nelmnts-1) :: num_material
+ integer, intent(in) :: ANISOTROPIC_MATERIAL
+ integer, intent(in) :: nb_materials
+ integer, dimension(1:nb_materials), intent(in) :: icodemat
+ double precision, dimension(1:nb_materials), intent(in) :: phi
+ integer, intent(in) :: num_start
+
+
+ integer, dimension(:,:), allocatable :: acoustic_surface_tmp
+ integer :: nelmnts_surface
+ integer :: i,ier
+ integer :: imaterial_number
+
+
+ open(unit=993, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error opening file: ',trim(filename)
+ stop 'error read acoustic surface file'
+ endif
+
+ read(993,*) nelmnts_surface
+
+ allocate(acoustic_surface_tmp(4,nelmnts_surface))
+
+ do i = 1, nelmnts_surface
+ read(993,*) acoustic_surface_tmp(1,i), acoustic_surface_tmp(2,i), acoustic_surface_tmp(3,i), acoustic_surface_tmp(4,i)
+
+ enddo
+
+ close(993)
+ acoustic_surface_tmp(1,:) = acoustic_surface_tmp(1,:) - num_start
+ acoustic_surface_tmp(3,:) = acoustic_surface_tmp(3,:) - num_start
+ acoustic_surface_tmp(4,:) = acoustic_surface_tmp(4,:) - num_start
+
+ nelem_acoustic_surface = 0
+ do i = 1, nelmnts_surface
+ imaterial_number = num_material(acoustic_surface_tmp(1,i))
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+
+ endif
+ enddo
+
+ allocate(acoustic_surface(4,nelem_acoustic_surface))
+
+ nelem_acoustic_surface = 0
+ do i = 1, nelmnts_surface
+ imaterial_number = num_material(acoustic_surface_tmp(1,i))
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
+ nelem_acoustic_surface = nelem_acoustic_surface + 1
+ acoustic_surface(:,nelem_acoustic_surface) = acoustic_surface_tmp(:,i)
+ endif
+ enddo
+
+ end subroutine read_acoustic_surface
+
+
+ !-----------------------------------------------
+ ! Read absorbing surface.
+ ! 'abs_surface' contains 1/ element number, 2/ number of nodes that form the absorbing edge
+ ! (which currently must always be equal to two, see comment below),
+ ! 3/ first node on the abs surface, 4/ second node on the abs surface
+ !-----------------------------------------------
+ subroutine read_abs_surface(filename, num_start)
+
+ implicit none
+ !include "constants.h"
+
+ character(len=256), intent(in) :: filename
+ integer, intent(in) :: num_start
+
+ integer :: i,ier
+
+ open(unit=994, file=trim(filename), form='formatted' , status='old', action='read', iostat=ier)
+ if( ier /= 0 ) then
+ print *,'error opening file: ',trim(filename)
+ stop 'error read absorbing surface file'
+ endif
+
+ read(994,*) nelemabs
+
+ allocate(abs_surface(4,nelemabs))
+
+ do i = 1, nelemabs
+ read(994,*) abs_surface(1,i), abs_surface(2,i), abs_surface(3,i), abs_surface(4,i)
+ if (abs_surface(2,i) /= 2) then
+ print *,'The input format is currently limited: only two nodes per element can be listed.'
+ print *,'If one of your elements has more than one edge along a given absorbing contour'
+ print *,'(e.g., if that contour has a corner) then list it twice,'
+ print *,'putting the first edge on the first line and the second edge on the second line.'
+ print *,'if one of your elements has a single point along the absording contour rather than a full edge, do NOT list it'
+ print *,'(it would have no weight in the contour integral anyway because it would consist of a single point).'
+ print *,'If you are using 9-node elements, list only the first and last points of the edge and not the intermediate point'
+ print *,'located around the middle of the edge; the right 9-node curvature will be restored automatically by the code.'
+ stop 'only two nodes per element should be listed for absorbing edges'
+ endif
+ enddo
+
+ close(994)
+
+ abs_surface(1,:) = abs_surface(1,:) - num_start
+ abs_surface(3,:) = abs_surface(3,:) - num_start
+ abs_surface(4,:) = abs_surface(4,:) - num_start
+
+ end subroutine read_abs_surface
+
+
+ !-----------------------------------------------
+ ! Creating dual graph (adjacency is defined by 'ncommonnodes' between two elements).
+ !-----------------------------------------------
+ subroutine mesh2dual_ncommonnodes(elmnts_l,ncommonnodes,xadj,adjncy)
+
+ implicit none
+ include "constants.h"
+
+ integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
+ integer, intent(in) :: ncommonnodes
+ integer, dimension(0:nelmnts),intent(out) :: xadj
+ integer, dimension(0:MAX_NEIGHBORS*nelmnts-1),intent(out) :: adjncy
+
+ ! local parameters
+ integer :: i, j, k, l, m, num_edges
+ logical :: is_neighbour
+ integer :: num_node, n
+ integer :: elem_base, elem_target
+ integer :: connectivity
+
+ ! allocates memory for arrays
+ if( .not. allocated(nnodes_elmnts) ) allocate(nnodes_elmnts(0:nnodes-1))
+ if( .not. allocated(nodes_elmnts) ) allocate(nodes_elmnts(0:nsize*nnodes-1))
+
+ ! initializes
+ xadj(:) = 0
+ adjncy(:) = 0
+ nnodes_elmnts(:) = 0
+ nodes_elmnts(:) = 0
+ num_edges = 0
+
+ ! list of elements per node
+ do i = 0, NCORNERS*nelmnts-1
+ nodes_elmnts(elmnts_l(i)*nsize + nnodes_elmnts(elmnts_l(i))) = i/NCORNERS
+ nnodes_elmnts(elmnts_l(i)) = nnodes_elmnts(elmnts_l(i)) + 1
+ enddo
+
+ ! checking which elements are neighbours ('ncommonnodes' criteria)
+ do j = 0, nnodes-1
+ do k = 0, nnodes_elmnts(j)-1
+ do l = k+1, nnodes_elmnts(j)-1
+
+ connectivity = 0
+ elem_base = nodes_elmnts(k+j*nsize)
+ elem_target = nodes_elmnts(l+j*nsize)
+ do n = 1, NCORNERS
+ num_node = elmnts_l(NCORNERS*elem_base+n-1)
+ do m = 0, nnodes_elmnts(num_node)-1
+ if ( nodes_elmnts(m+num_node*nsize) == elem_target ) then
+ connectivity = connectivity + 1
+ endif
+ enddo
+ enddo
+
+ ! sets adjacency (adjncy) and number of neighbors (xadj)
+ ! according to ncommonnodes criteria
+ if ( connectivity >= ncommonnodes) then
+
+ is_neighbour = .false.
+
+ do m = 0, xadj(nodes_elmnts(k+j*nsize))
+ if ( .not.is_neighbour ) then
+ if ( adjncy(nodes_elmnts(k+j*nsize)*MAX_NEIGHBORS+m) == nodes_elmnts(l+j*nsize) ) then
+ is_neighbour = .true.
+ endif
+ endif
+ enddo
+ if ( .not.is_neighbour ) then
+ adjncy(nodes_elmnts(k+j*nsize)*MAX_NEIGHBORS &
+ + xadj(nodes_elmnts(k+j*nsize))) = nodes_elmnts(l+j*nsize)
+
+ xadj(nodes_elmnts(k+j*nsize)) = xadj(nodes_elmnts(k+j*nsize)) + 1
+ if (xadj(nodes_elmnts(k+j*nsize)) > MAX_NEIGHBORS) &
+ stop 'ERROR : too much neighbours per element, modify the mesh.'
+
+ adjncy(nodes_elmnts(l+j*nsize)*MAX_NEIGHBORS &
+ + xadj(nodes_elmnts(l+j*nsize))) = nodes_elmnts(k+j*nsize)
+
+ xadj(nodes_elmnts(l+j*nsize)) = xadj(nodes_elmnts(l+j*nsize)) + 1
+ if (xadj(nodes_elmnts(l+j*nsize))>MAX_NEIGHBORS) &
+ stop 'ERROR : too much neighbours per element, modify the mesh.'
+
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! making adjacency arrays compact (to be used for partitioning)
+ do i = 0, nelmnts-1
+ k = xadj(i)
+ xadj(i) = num_edges
+ do j = 0, k-1
+ adjncy(num_edges) = adjncy(i*MAX_NEIGHBORS+j)
+ num_edges = num_edges + 1
+ enddo
+ enddo
+
+ xadj(nelmnts) = num_edges
+
+ end subroutine mesh2dual_ncommonnodes
+
+
+ !-----------------------------------------------
+ ! Read the weight for each vertices and edges of the graph (not curretly used)
+ !-----------------------------------------------
+ subroutine read_weights()
+
+ implicit none
+
+ allocate(vwgt(0:nelmnts-1))
+ allocate(adjwgt(0:nb_edges-1))
+
+ vwgt(:) = 1
+ adjwgt(:) = 1
+
+ end subroutine read_weights
+
+
+ !--------------------------------------------------
+ ! construct local numbering for the elements in each partition
+ !--------------------------------------------------
+ subroutine Construct_glob2loc_elmnts(nparts)
+
+ implicit none
+ integer, intent(in) :: nparts
+
+ integer :: num_glob, num_part
+ integer, dimension(0:nparts-1) :: num_loc
+
+
+ allocate(glob2loc_elmnts(0:nelmnts-1))
+
+ ! initializes number of local elements per partition
+ do num_part = 0, nparts-1
+ num_loc(num_part) = 0
+ enddo
+
+ ! local numbering
+ do num_glob = 0, nelmnts-1
+ num_part = part(num_glob)
+ glob2loc_elmnts(num_glob) = num_loc(num_part)
+ num_loc(num_part) = num_loc(num_part) + 1
+ enddo
+
+ end subroutine Construct_glob2loc_elmnts
+
+
+ !--------------------------------------------------
+ ! construct local numbering for the nodes in each partition
+ !--------------------------------------------------
+ subroutine Construct_glob2loc_nodes(nparts)
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: nparts
+
+ integer :: num_node
+ integer :: el
+ integer :: num_part
+ integer :: size_glob2loc_nodes
+ integer, dimension(0:nparts-1) :: parts_node
+ integer, dimension(0:nparts-1) :: num_parts
+
+ allocate(glob2loc_nodes_nparts(0:nnodes))
+
+ size_glob2loc_nodes = 0
+
+ parts_node(:) = 0
+
+
+ do num_node = 0, nnodes-1
+ glob2loc_nodes_nparts(num_node) = size_glob2loc_nodes
+ do el = 0, nnodes_elmnts(num_node)-1
+ parts_node(part(nodes_elmnts(el+nsize*num_node))) = 1
+ enddo
+
+ do num_part = 0, nparts-1
+ if ( parts_node(num_part) == 1 ) then
+ size_glob2loc_nodes = size_glob2loc_nodes + 1
+ parts_node(num_part) = 0
+ endif
+ enddo
+
+ enddo
+
+ glob2loc_nodes_nparts(nnodes) = size_glob2loc_nodes
+
+ allocate(glob2loc_nodes_parts(0:glob2loc_nodes_nparts(nnodes)-1))
+ allocate(glob2loc_nodes(0:glob2loc_nodes_nparts(nnodes)-1))
+
+ glob2loc_nodes(0) = 0
+
+ parts_node(:) = 0
+ num_parts(:) = 0
+ size_glob2loc_nodes = 0
+
+
+ do num_node = 0, nnodes-1
+ do el = 0, nnodes_elmnts(num_node)-1
+ parts_node(part(nodes_elmnts(el+nsize*num_node))) = 1
+ enddo
+ do num_part = 0, nparts-1
+
+ if ( parts_node(num_part) == 1 ) then
+ glob2loc_nodes_parts(size_glob2loc_nodes) = num_part
+ glob2loc_nodes(size_glob2loc_nodes) = num_parts(num_part)
+ size_glob2loc_nodes = size_glob2loc_nodes + 1
+ num_parts(num_part) = num_parts(num_part) + 1
+ parts_node(num_part) = 0
+ endif
+
+ enddo
+ enddo
+
+ end subroutine Construct_glob2loc_nodes
+
+
+ !--------------------------------------------------
+ ! Construct interfaces between each partitions.
+ ! Two adjacent elements in distinct partitions make an entry in array tab_interfaces :
+ ! 1/ first element, 2/ second element, 3/ number of common nodes, 4/ first node,
+ ! 5/ second node, if relevant.
+ ! No interface between acoustic, elastic, and poroelastic elements.
+ !--------------------------------------------------
+ subroutine Construct_interfaces(nparts, elmnts_l, &
+ nb_materials, phi_material, num_material)
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: nparts
+ integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+ integer, intent(in) :: nb_materials
+ double precision, dimension(1:nb_materials), intent(in) :: phi_material
+
+ integer :: num_part, num_part_bis, el, el_adj, num_interface, num_edge, ncommon_nodes, &
+ num_node, num_node_bis
+ integer :: i, j
+ logical :: is_acoustic_el, is_acoustic_el_adj, is_elastic_el, is_elastic_el_adj
+
+ ninterfaces = 0
+ do i = 0, nparts-1
+ do j = i+1, nparts-1
+ ninterfaces = ninterfaces + 1
+ enddo
+ enddo
+
+ allocate(tab_size_interfaces(0:ninterfaces))
+ tab_size_interfaces(:) = 0
+
+ num_interface = 0
+ num_edge = 0
+
+ do num_part = 0, nparts-1
+ do num_part_bis = num_part+1, nparts-1
+ do el = 0, nelmnts-1
+ if ( part(el) == num_part ) then
+ ! sets material flag
+ if ( phi_material(num_material(el+1)) < TINYVAL) then
+ ! elastic element
+ is_acoustic_el = .false.
+ is_elastic_el = .true.
+ elseif ( phi_material(num_material(el+1)) >= 1.d0) then
+ ! acoustic element
+ is_acoustic_el = .true.
+ is_elastic_el = .false.
+ else
+ ! poroelastic element
+ is_acoustic_el = .false.
+ is_elastic_el = .false.
+ endif
+
+ ! looks at all neighbor elements
+ do el_adj = xadj_g(el), xadj_g(el+1)-1
+ ! sets neighbor material flag
+ if ( phi_material(num_material(adjncy_g(el_adj)+1)) < TINYVAL) then
+ is_acoustic_el_adj = .false.
+ is_elastic_el_adj = .true.
+ elseif ( phi_material(num_material(adjncy_g(el_adj)+1)) >= 1.d0) then
+ is_acoustic_el_adj = .true.
+ is_elastic_el_adj = .false.
+ else
+ is_acoustic_el_adj = .false.
+ is_elastic_el_adj = .false.
+ endif
+ ! adds element if neighbor element lies in next parition
+ ! and belongs to same material
+ if ( (part(adjncy_g(el_adj)) == num_part_bis) .and. &
+ (is_acoustic_el .eqv. is_acoustic_el_adj) .and. &
+ (is_elastic_el .eqv. is_elastic_el_adj) ) then
+ num_edge = num_edge + 1
+ endif
+ enddo
+ endif
+ enddo
+ ! stores number of elements at interface
+ tab_size_interfaces(num_interface+1) = tab_size_interfaces(num_interface) + num_edge
+ num_edge = 0
+ num_interface = num_interface + 1
+
+ enddo
+ enddo
+
+ ! stores element indices for elements from above search at each interface
+ num_interface = 0
+ num_edge = 0
+
+ allocate(tab_interfaces(0:(tab_size_interfaces(ninterfaces)*5-1)))
+ tab_interfaces(:) = 0
+
+ do num_part = 0, nparts-1
+ do num_part_bis = num_part+1, nparts-1
+ do el = 0, nelmnts-1
+ if ( part(el) == num_part ) then
+ if ( phi_material(num_material(el+1)) < TINYVAL) then
+ is_acoustic_el = .false.
+ is_elastic_el = .true.
+ elseif ( phi_material(num_material(el+1)) >= 1.d0) then
+ is_acoustic_el = .true.
+ is_elastic_el = .false.
+ else
+ is_acoustic_el = .false.
+ is_elastic_el = .false.
+ endif
+ do el_adj = xadj_g(el), xadj_g(el+1)-1
+ if ( phi_material(num_material(adjncy_g(el_adj)+1)) < TINYVAL) then
+ is_acoustic_el_adj = .false.
+ is_elastic_el_adj = .true.
+ elseif ( phi_material(num_material(adjncy_g(el_adj)+1)) >= 1.d0) then
+ is_acoustic_el_adj = .true.
+ is_elastic_el_adj = .false.
+ else
+ is_acoustic_el_adj = .false.
+ is_elastic_el_adj = .false.
+ endif
+ if ( (part(adjncy_g(el_adj)) == num_part_bis) .and. &
+ (is_acoustic_el .eqv. is_acoustic_el_adj) .and. &
+ (is_elastic_el .eqv. is_elastic_el_adj) ) then
+ tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+0) = el
+ tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+1) = adjncy_g(el_adj)
+ ncommon_nodes = 0
+ do num_node = 0, 4-1
+ do num_node_bis = 0, 4-1
+ if ( elmnts_l(el*NCORNERS+num_node) == &
+ elmnts_l(adjncy_g(el_adj)*NCORNERS+num_node_bis) ) then
+ tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+3+ncommon_nodes) &
+ = elmnts_l(el*NCORNERS+num_node)
+ ncommon_nodes = ncommon_nodes + 1
+ endif
+ enddo
+ enddo
+ if ( ncommon_nodes > 0 ) then
+ tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+2) = ncommon_nodes
+ else
+ print *, "Error while building interfaces!", ncommon_nodes
+ stop 'fatal error'
+ endif
+ num_edge = num_edge + 1
+ endif
+ enddo
+ endif
+
+ enddo
+ num_edge = 0
+ num_interface = num_interface + 1
+ enddo
+ enddo
+
+ end subroutine Construct_interfaces
+
+
+ !--------------------------------------------------
+ ! Write nodes (their coordinates) pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+ subroutine write_glob2loc_nodes_database(IIN_database, iproc, npgeo, num_phase)
+
+ implicit none
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc, num_phase
+ integer, intent(inout) :: npgeo
+
+ integer :: i, j
+
+ if ( num_phase == 1 ) then
+ npgeo = 0
+
+ do i = 0, nnodes-1
+ do j = glob2loc_nodes_nparts(i), glob2loc_nodes_nparts(i+1)-1
+ if ( glob2loc_nodes_parts(j) == iproc ) then
+ npgeo = npgeo + 1
+ endif
+ enddo
+ enddo
+ else
+ do i = 0, nnodes-1
+ do j = glob2loc_nodes_nparts(i), glob2loc_nodes_nparts(i+1)-1
+ if ( glob2loc_nodes_parts(j) == iproc ) then
+ write(IIN_database,*) glob2loc_nodes(j)+1, nodes_coords(1,i+1), nodes_coords(2,i+1)
+ endif
+ enddo
+ enddo
+ endif
+
+ end subroutine Write_glob2loc_nodes_database
+
+
+ !--------------------------------------------------
+ ! Write elements (their nodes) pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+ subroutine write_partition_database(IIN_database, iproc, nspec, &
+ num_modele, ngnod, num_phase)
+
+ implicit none
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: num_phase, iproc
+ integer, intent(inout) :: nspec
+ integer, dimension(:) :: num_modele
+ integer, intent(in) :: ngnod
+
+ integer :: i,j,k
+ integer, dimension(0:ngnod-1) :: loc_nodes
+
+ if (num_phase == 1) then
+
+ nspec = 0
+
+ do i = 0, nelmnts-1
+ if (part(i) == iproc) nspec = nspec + 1
+ enddo
+
+ else
+ do i = 0, nelmnts-1
+ if (part(i) == iproc) then
+
+ do j = 0, ngnod-1
+ do k = glob2loc_nodes_nparts(elmnts(i*ngnod+j)), glob2loc_nodes_nparts(elmnts(i*ngnod+j)+1)-1
+ if (glob2loc_nodes_parts(k) == iproc) loc_nodes(j) = glob2loc_nodes(k)
+ enddo
+ enddo
+ write(IIN_database,*) glob2loc_elmnts(i)+1, num_modele(i+1), (loc_nodes(k)+1, k=0,ngnod-1)
+ endif
+ enddo
+
+ endif
+
+ end subroutine write_partition_database
+
+
+ !--------------------------------------------------
+ ! Write interfaces (element and common nodes) pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+ subroutine Write_interfaces_database(IIN_database, nparts, iproc, &
+ my_ninterface, my_interfaces, my_nb_interfaces, num_phase)
+
+ implicit none
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc
+ integer, intent(in) :: nparts
+ integer, intent(inout) :: my_ninterface
+ integer, dimension(0:ninterfaces-1), intent(inout) :: my_interfaces
+ integer, dimension(0:ninterfaces-1), intent(inout) :: my_nb_interfaces
+
+ integer, dimension(2) :: local_nodes
+ integer :: local_elmnt
+ integer :: num_phase
+
+ integer :: i, j, k, l
+ integer :: num_interface
+
+ num_interface = 0
+
+ if ( num_phase == 1 ) then
+
+ my_interfaces(:) = 0
+ my_nb_interfaces(:) = 0
+
+ do i = 0, nparts-1
+ do j = i+1, nparts-1
+ if ( (tab_size_interfaces(num_interface) < tab_size_interfaces(num_interface+1)) .and. &
+ (i == iproc .or. j == iproc) ) then
+ my_interfaces(num_interface) = 1
+ my_nb_interfaces(num_interface) = tab_size_interfaces(num_interface+1) &
+ - tab_size_interfaces(num_interface)
+ endif
+ num_interface = num_interface + 1
+ enddo
+ enddo
+ my_ninterface = sum(my_interfaces(:))
+
+ else
+
+ do i = 0, nparts-1
+ do j = i+1, nparts-1
+ if ( my_interfaces(num_interface) == 1 ) then
+ if ( i == iproc ) then
+ write(IIN_database,*) j, my_nb_interfaces(num_interface)
+ else
+ write(IIN_database,*) i, my_nb_interfaces(num_interface)
+ endif
+
+ do k = tab_size_interfaces(num_interface), tab_size_interfaces(num_interface+1)-1
+ if ( i == iproc ) then
+ local_elmnt = glob2loc_elmnts(tab_interfaces(k*5+0))+1
+ else
+ local_elmnt = glob2loc_elmnts(tab_interfaces(k*5+1))+1
+ endif
+
+ if ( tab_interfaces(k*5+2) == 1 ) then
+ ! common node (single point)
+ do l = glob2loc_nodes_nparts(tab_interfaces(k*5+3)), &
+ glob2loc_nodes_nparts(tab_interfaces(k*5+3)+1)-1
+ if ( glob2loc_nodes_parts(l) == iproc ) then
+ local_nodes(1) = glob2loc_nodes(l)+1
+ endif
+ enddo
+
+ write(IIN_database,*) local_elmnt, tab_interfaces(k*5+2), &
+ local_nodes(1), -1
+ else
+ if ( tab_interfaces(k*5+2) == 2 ) then
+ ! common edge (two nodes)
+ ! first node
+ do l = glob2loc_nodes_nparts(tab_interfaces(k*5+3)), &
+ glob2loc_nodes_nparts(tab_interfaces(k*5+3)+1)-1
+ if ( glob2loc_nodes_parts(l) == iproc ) then
+ local_nodes(1) = glob2loc_nodes(l)+1
+ endif
+ enddo
+ ! second node
+ do l = glob2loc_nodes_nparts(tab_interfaces(k*5+4)), &
+ glob2loc_nodes_nparts(tab_interfaces(k*5+4)+1)-1
+ if ( glob2loc_nodes_parts(l) == iproc ) then
+ local_nodes(2) = glob2loc_nodes(l)+1
+ endif
+ enddo
+
+ write(IIN_database,*) local_elmnt, tab_interfaces(k*5+2), &
+ local_nodes(1), local_nodes(2)
+ else
+ write(IIN_database,*) "erreur_write_interface_", tab_interfaces(k*5+2)
+ endif
+ endif
+ enddo
+
+ endif
+
+ num_interface = num_interface + 1
+ enddo
+ enddo
+
+ endif
+
+ end subroutine Write_interfaces_database
+
+
+ !--------------------------------------------------
+ ! Write a surface (elements and nodes on the surface) pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+ subroutine Write_surface_database(IIN_database, nsurface, surface, &
+ nsurface_loc, iproc, num_phase)
+
+ implicit none
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc
+ integer :: nsurface
+ integer :: nsurface_loc
+ integer, dimension(:,:), pointer :: surface
+
+ integer, dimension(2) :: local_nodes
+ integer :: local_elmnt
+ integer :: num_phase
+
+ integer :: i, l
+
+ if ( num_phase == 1 ) then
+
+ nsurface_loc = 0
+
+ do i = 1, nsurface
+ if ( part(surface(1,i)) == iproc ) then
+ nsurface_loc = nsurface_loc + 1
+ endif
+ enddo
+
+ else
+
+ nsurface_loc = 0
+
+ do i = 1, nsurface
+ if ( part(surface(1,i)) == iproc ) then
+ nsurface_loc = nsurface_loc + 1
+
+ local_elmnt = glob2loc_elmnts(surface(1,i)) + 1
+
+ if ( surface(2,i) == 1 ) then
+ do l = glob2loc_nodes_nparts(surface(3,i)), &
+ glob2loc_nodes_nparts(surface(3,i)+1)-1
+ if ( glob2loc_nodes_parts(l) == iproc ) then
+ local_nodes(1) = glob2loc_nodes(l)+1
+ endif
+ enddo
+
+ write(IIN_database,*) local_elmnt, surface(2,i), local_nodes(1), -1
+ endif
+
+ if ( surface(2,i) == 2 ) then
+ do l = glob2loc_nodes_nparts(surface(3,i)), &
+ glob2loc_nodes_nparts(surface(3,i)+1)-1
+ if ( glob2loc_nodes_parts(l) == iproc ) then
+ local_nodes(1) = glob2loc_nodes(l)+1
+ endif
+ enddo
+ do l = glob2loc_nodes_nparts(surface(4,i)), &
+ glob2loc_nodes_nparts(surface(4,i)+1)-1
+ if ( glob2loc_nodes_parts(l) == iproc ) then
+ local_nodes(2) = glob2loc_nodes(l)+1
+ endif
+ enddo
+
+ write(IIN_database,*) local_elmnt, surface(2,i), local_nodes(1), local_nodes(2)
+ endif
+
+ endif
+
+ enddo
+
+ endif
+
+ end subroutine Write_surface_database
+
+
+ !--------------------------------------------------
+ ! Set absorbing boundaries by elements instead of edges.
+ ! Excludes points that have both absorbing condition and coupled fluid/solid relation (this is the
+ ! reason arrays ibegin_..., iend_... were included here).
+ ! Under development : exluding points that have two different normals in two different elements.
+ !--------------------------------------------------
+
+ subroutine merge_abs_boundaries(nb_materials, phi_material, num_material, ngnod)
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: ngnod
+ integer :: nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+
+ logical, dimension(nb_materials) :: is_acoustic
+ integer :: num_edge, nedge_bound
+ integer :: match
+ integer :: nb_elmnts_abs
+ integer :: i
+ integer :: temp
+ integer :: iedge, inode1, inode2
+
+ allocate(abs_surface_char(4,nelemabs))
+ allocate(abs_surface_merge(nelemabs))
+ abs_surface_char(:,:) = .false.
+ abs_surface_merge(:) = -1
+
+ nedge_bound = nelemabs
+ nb_elmnts_abs = 0
+
+ do num_edge = 1, nedge_bound
+
+ match = 0
+ do i = 1, nb_elmnts_abs
+ if ( abs_surface(1,num_edge) == abs_surface_merge(i) ) then
+ match = i
+ exit
+ endif
+ enddo
+
+ if ( match == 0 ) then
+ nb_elmnts_abs = nb_elmnts_abs + 1
+ match = nb_elmnts_abs
+ endif
+
+ abs_surface_merge(match) = abs_surface(1,num_edge)
+
+
+ if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1)) ) then
+ abs_surface_char(1,match) = .true.
+
+ endif
+
+ if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
+ abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1)) ) then
+ temp = abs_surface(4,num_edge)
+ abs_surface(4,num_edge) = abs_surface(3,num_edge)
+ abs_surface(3,num_edge) = temp
+ abs_surface_char(1,match) = .true.
+
+ endif
+
+ if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
+ abs_surface_char(4,match) = .true.
+
+ endif
+
+ if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+0) .and. &
+ abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
+ temp = abs_surface(4,num_edge)
+ abs_surface(4,num_edge) = abs_surface(3,num_edge)
+ abs_surface(3,num_edge) = temp
+ abs_surface_char(4,match) = .true.
+
+ endif
+
+ if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2)) ) then
+ abs_surface_char(2,match) = .true.
+
+ endif
+
+ if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+1) .and. &
+ abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2)) ) then
+ temp = abs_surface(4,num_edge)
+ abs_surface(4,num_edge) = abs_surface(3,num_edge)
+ abs_surface(3,num_edge) = temp
+ abs_surface_char(2,match) = .true.
+
+ endif
+
+ if ( (abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
+ temp = abs_surface(4,num_edge)
+ abs_surface(4,num_edge) = abs_surface(3,num_edge)
+ abs_surface(3,num_edge) = temp
+ abs_surface_char(3,match) = .true.
+
+ endif
+
+ if ( (abs_surface(4,num_edge) == elmnts(ngnod*abs_surface_merge(match)+2) .and. &
+ abs_surface(3,num_edge) == elmnts(ngnod*abs_surface_merge(match)+3)) ) then
+ abs_surface_char(3,match) = .true.
+
+ endif
+
+ enddo
+
+ nelemabs_merge = nb_elmnts_abs
+
+ allocate(ibegin_bottom(nelemabs_merge))
+ allocate(iend_bottom(nelemabs_merge))
+ allocate(jbegin_right(nelemabs_merge))
+ allocate(jend_right(nelemabs_merge))
+ allocate(ibegin_top(nelemabs_merge))
+ allocate(iend_top(nelemabs_merge))
+ allocate(jbegin_left(nelemabs_merge))
+ allocate(jend_left(nelemabs_merge))
+
+ ibegin_bottom(:) = 1
+ jbegin_right(:) = 1
+ ibegin_top(:) = 1
+ jbegin_left(:) = 1
+ iend_bottom(:) = NGLLX
+ jend_right(:) = NGLLZ
+ iend_top(:) = NGLLX
+ jend_left(:) = NGLLZ
+
+ is_acoustic(:) = .false.
+
+ do i = 1, nb_materials
+ if (phi_material(i) >= 1.d0) then
+ is_acoustic(i) = .true.
+ endif
+ enddo
+
+ do num_edge = 1, nedge_bound
+
+ match = 0
+ do i = 1, nelemabs_merge
+ if ( abs_surface(1,num_edge) == abs_surface_merge(i) ) then
+ match = i
+ exit
+ endif
+ enddo
+
+ if ( is_acoustic(num_material(abs_surface(1,num_edge)+1)) ) then
+
+ do iedge = 1, nedges_coupled
+
+ do inode1 = 0, 3
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_coupled(1,iedge)+inode1) ) then
+ do inode2 = 0, 3
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*edges_coupled(2,iedge)+inode2) ) then
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) ) then
+ ibegin_bottom(match) = 2
+
+ endif
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ jbegin_right(match) = 2
+
+ endif
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ ibegin_top(match) = 2
+
+ endif
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) ) then
+ jbegin_left(match) = 2
+
+ endif
+
+ endif
+ enddo
+
+ endif
+
+ if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_coupled(1,iedge)+inode1) ) then
+ do inode2 = 0, 3
+ if ( abs_surface(4,num_edge) == elmnts(ngnod*edges_coupled(2,iedge)+inode2) ) then
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) ) then
+ iend_bottom(match) = NGLLX - 1
+
+ endif
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+1) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ jend_right(match) = NGLLZ - 1
+
+ endif
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+2) ) then
+ iend_top(match) = NGLLX - 1
+
+ endif
+ if ( abs_surface(3,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+0) .and. &
+ abs_surface(4,num_edge) == elmnts(ngnod*abs_surface(1,num_edge)+3) ) then
+ jend_left(match) = NGLLZ - 1
+
+ endif
+ endif
+ enddo
+
+ endif
+
+ enddo
+
+
+ enddo
+
+ endif
+
+ enddo
+
+ end subroutine merge_abs_boundaries
+
+
+ !--------------------------------------------------
+ ! Write abs surface (elements and nodes on the surface) pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+
+ subroutine write_abs_merge_database(IIN_database, iproc, num_phase)
+
+ implicit none
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc
+ integer, intent(in) :: num_phase
+
+ integer :: i
+
+ if ( num_phase == 1 ) then
+ nelemabs_loc = 0
+ do i = 1, nelemabs_merge
+ if ( part(abs_surface_merge(i)) == iproc ) then
+ nelemabs_loc = nelemabs_loc + 1
+ endif
+ enddo
+ else
+ do i = 1, nelemabs_merge
+ if ( part(abs_surface_merge(i)) == iproc ) then
+
+ write(IIN_database,*) glob2loc_elmnts(abs_surface_merge(i))+1, abs_surface_char(1,i), &
+ abs_surface_char(2,i), abs_surface_char(3,i), abs_surface_char(4,i), &
+ ibegin_bottom(i), iend_bottom(i), &
+ jbegin_right(i), jend_right(i), &
+ ibegin_top(i), iend_top(i), &
+ jbegin_left(i), jend_left(i)
+
+ endif
+
+ enddo
+ endif
+
+ end subroutine write_abs_merge_database
+
+
+!! DK DK support for METIS now removed, we use SCOTCH instead
+!#ifdef USE_METIS
+! !--------------------------------------------------
+! ! Partitioning using METIS
+! !--------------------------------------------------
+! subroutine Part_metis(nelmnts, xadj, adjncy, vwgt, adjwgt, nparts, nb_edges, edgecut, part, metis_options)
+!
+! include "constants.h"
+!
+! integer, intent(in) :: nelmnts, nparts, nb_edges
+! integer, intent(inout) :: edgecut
+! integer, dimension(0:nelmnts), intent(in) :: xadj
+! integer, dimension(0:MAX_NEIGHBORS*nelmnts-1), intent(in) :: adjncy
+! integer, dimension(0:nelmnts-1), intent(in) :: vwgt
+! integer, dimension(0:nb_edges-1), intent(in) :: adjwgt
+! integer, dimension(:), pointer :: part
+! integer, dimension(0:4) :: metis_options
+!
+! integer :: wgtflag
+! integer :: num_start
+!
+! num_start = 0
+! wgtflag = 0
+!
+! call METIS_PartGraphRecursive(nelmnts, xadj(0), adjncy(0), vwgt(0), adjwgt(0), wgtflag, num_start, nparts, &
+! metis_options, edgecut, part(0));
+! !call METIS_PartGraphVKway(nelmnts, xadj(0), adjncy(0), vwgt(0), adjwgt(0), wgtflag, num_start, nparts, &
+! ! options, edgecut, part(0));
+!
+! end subroutine Part_metis
+!#endif
+
+
+#ifdef USE_SCOTCH
+ !--------------------------------------------------
+ ! Partitioning using SCOTCH
+ !--------------------------------------------------
+ subroutine Part_scotch(nparts, edgecut)
+
+ implicit none
+ include "constants.h"
+
+ include "scotchf.h"
+
+ integer, intent(in) :: nparts
+ integer, intent(inout) :: edgecut
+
+ double precision, dimension(SCOTCH_GRAPHDIM) :: SCOTCHGRAPH
+ double precision, dimension(SCOTCH_STRATDIM) :: SCOTCHSTRAT
+ integer :: IERR
+
+ edgecut = vwgt(0)
+ edgecut = 0
+
+ ! we use default strategy for partitioning, thus omit specifing explicit strategy .
+ call scotchfstratinit (SCOTCHSTRAT(1), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot initialize strat'
+ STOP
+ ENDIF
+
+ CALL SCOTCHFGRAPHINIT (SCOTCHGRAPH (1), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot initialize graph'
+ STOP
+ ENDIF
+
+ ! fills graph structure : see user manual (scotch_user5.1.pdf, page 72/73)
+ ! arguments: #(1) graph_structure #(2) baseval(either 0/1) #(3) number_of_vertices
+ ! #(4) adjacency_index_array #(5) adjacency_end_index_array (optional)
+ ! #(6) vertex_load_array (optional) #(7) vertex_label_array
+ ! #(7) number_of_arcs #(8) adjacency_array
+ ! #(9) arc_load_array (optional) #(10) ierror
+ CALL SCOTCHFGRAPHBUILD (SCOTCHGRAPH (1), 0, nelmnts, &
+ xadj_g(0), xadj_g(0), &
+ xadj_g(0), xadj_g(0), &
+ nb_edges, &
+ adjncy_g(0), adjwgt (0), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot build graph'
+ STOP
+ ENDIF
+
+ CALL SCOTCHFGRAPHCHECK (SCOTCHGRAPH (1), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Invalid check'
+ STOP
+ ENDIF
+
+ call scotchfgraphpart (SCOTCHGRAPH (1), nparts, SCOTCHSTRAT(1), part(0), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot part graph'
+ STOP
+ ENDIF
+
+ CALL SCOTCHFGRAPHEXIT (SCOTCHGRAPH (1), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot destroy graph'
+ STOP
+ ENDIF
+
+ call scotchfstratexit (SCOTCHSTRAT(1), IERR)
+ IF (IERR .NE. 0) THEN
+ PRINT *, 'ERROR : MAIN : Cannot destroy strat'
+ STOP
+ ENDIF
+
+ end subroutine Part_scotch
+#endif
+
+
+ !--------------------------------------------------
+ ! Repartitioning : two coupled acoustic/elastic elements are transfered to the same partition
+ !--------------------------------------------------
+
+ subroutine acoustic_elastic_repartitioning (elmnts_l, nb_materials, &
+ phi_material, num_material, nproc)
+
+ implicit none
+ include "constants.h"
+
+ integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
+ integer, intent(in) :: nproc, nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+
+ ! local parameters
+ integer, dimension(:), allocatable :: xadj_l
+ integer, dimension(:), allocatable :: adjncy_l
+ logical, dimension(nb_materials) :: is_acoustic, is_elastic
+ integer :: i, num_edge
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ allocate(xadj_l(0:nelmnts))
+ allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
+
+ is_acoustic(:) = .false.
+ is_elastic(:) = .false.
+
+ do i = 1, nb_materials
+ if (phi_material(i) >= 1.d0) then
+ is_acoustic(i) = .true.
+ endif
+ if (phi_material(i) < TINYVAL) then
+ is_elastic(i) = .true.
+ endif
+ enddo
+
+ ! determines maximum neighbors based on 2 common nodes (common edge)
+ call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
+
+ nedges_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_coupled = nedges_coupled + 1
+ endif
+ enddo
+ endif
+ enddo
+
+ allocate(edges_coupled(2,nedges_coupled))
+
+ nedges_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_coupled = nedges_coupled + 1
+ edges_coupled(1,nedges_coupled) = el
+ edges_coupled(2,nedges_coupled) = adjncy_l(el_adj)
+ endif
+
+ enddo
+ endif
+ enddo
+
+ do i = 1, nedges_coupled*nproc
+ is_repartitioned = .false.
+ do num_edge = 1, nedges_coupled
+ if ( part(edges_coupled(1,num_edge)) /= part(edges_coupled(2,num_edge)) ) then
+ if ( part(edges_coupled(1,num_edge)) < part(edges_coupled(2,num_edge)) ) then
+ part(edges_coupled(2,num_edge)) = part(edges_coupled(1,num_edge))
+ else
+ part(edges_coupled(1,num_edge)) = part(edges_coupled(2,num_edge))
+ endif
+ is_repartitioned = .true.
+ endif
+
+ enddo
+ if ( .not. is_repartitioned ) then
+ exit
+ endif
+ enddo
+
+ deallocate(xadj_l,adjncy_l)
+
+ end subroutine acoustic_elastic_repartitioning
+
+
+ !--------------------------------------------------
+ ! Repartitioning : two coupled acoustic/poroelastic elements are transfered to the same partition
+ !--------------------------------------------------
+
+ subroutine acoustic_poro_repartitioning (elmnts_l, nb_materials, &
+ phi_material, num_material, nproc)
+
+ implicit none
+ include "constants.h"
+
+ integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
+ integer, intent(in) :: nproc, nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+
+ ! local parameters
+ integer, dimension(:), allocatable :: xadj_l
+ integer, dimension(:), allocatable :: adjncy_l
+ logical, dimension(nb_materials) :: is_acoustic,is_poroelastic
+ integer :: i, num_edge
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ allocate(xadj_l(0:nelmnts))
+ allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
+
+ is_acoustic(:) = .false.
+ is_poroelastic(:) = .false.
+
+ do i = 1, nb_materials
+ if (phi_material(i) >=1.d0) then
+ is_acoustic(i) = .true.
+ endif
+ if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
+ is_poroelastic(i) = .true.
+ endif
+ enddo
+
+ ! determines maximum neighbors based on 2 common nodes (common edge)
+ call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
+
+ nedges_acporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_poroelastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_acporo_coupled = nedges_acporo_coupled + 1
+ endif
+
+ enddo
+ endif
+ enddo
+
+ print *, 'nedges_coupled (acoustic/poroelastic)', nedges_acporo_coupled
+
+ allocate(edges_acporo_coupled(2,nedges_acporo_coupled))
+
+ nedges_acporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_poroelastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_acporo_coupled = nedges_acporo_coupled + 1
+ edges_acporo_coupled(1,nedges_acporo_coupled) = el
+ edges_acporo_coupled(2,nedges_acporo_coupled) = adjncy_l(el_adj)
+ endif
+
+ enddo
+ endif
+ enddo
+
+ do i = 1, nedges_acporo_coupled*nproc
+ is_repartitioned = .false.
+ do num_edge = 1, nedges_acporo_coupled
+ if ( part(edges_acporo_coupled(1,num_edge)) /= part(edges_acporo_coupled(2,num_edge)) ) then
+ if ( part(edges_acporo_coupled(1,num_edge)) < part(edges_acporo_coupled(2,num_edge)) ) then
+ part(edges_acporo_coupled(2,num_edge)) = part(edges_acporo_coupled(1,num_edge))
+ else
+ part(edges_acporo_coupled(1,num_edge)) = part(edges_acporo_coupled(2,num_edge))
+ endif
+ is_repartitioned = .true.
+ endif
+
+ enddo
+ if ( .not. is_repartitioned ) then
+ exit
+ endif
+ enddo
+
+ deallocate(xadj_l,adjncy_l)
+
+ end subroutine acoustic_poro_repartitioning
+
+
+ !--------------------------------------------------
+ ! Repartitioning : two coupled poroelastic/elastic elements are transfered to the same partition
+ !--------------------------------------------------
+
+ subroutine poro_elastic_repartitioning (elmnts_l, nb_materials, &
+ phi_material, num_material, nproc)
+
+ implicit none
+ include "constants.h"
+
+ integer, dimension(0:NCORNERS*nelmnts-1), intent(in) :: elmnts_l
+ integer, intent(in) :: nproc, nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+
+ ! local parameters
+ integer, dimension(:), allocatable :: xadj_l
+ integer, dimension(:), allocatable :: adjncy_l
+ logical, dimension(nb_materials) :: is_elastic,is_poroelastic
+ integer :: i, num_edge
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ allocate(xadj_l(0:nelmnts))
+ allocate(adjncy_l(0:MAX_NEIGHBORS*nelmnts-1))
+
+ is_elastic(:) = .false.
+ is_poroelastic(:) = .false.
+
+ do i = 1, nb_materials
+ if (phi_material(i) < TINYVAL) then
+ is_elastic(i) = .true.
+ endif
+ if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
+ is_poroelastic(i) = .true.
+ endif
+ enddo
+
+ ! determines maximum neighbors based on 2 common nodes (common edge)
+ call mesh2dual_ncommonnodes(elmnts_l, 2, xadj_l, adjncy_l)
+
+ nedges_elporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_poroelastic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_elporo_coupled = nedges_elporo_coupled + 1
+ endif
+
+ enddo
+ endif
+ enddo
+
+ print *, 'nedges_coupled (poroelastic/elastic)', nedges_elporo_coupled
+
+ allocate(edges_elporo_coupled(2,nedges_elporo_coupled))
+
+ nedges_elporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_poroelastic(num_material(el+1)) ) then
+ do el_adj = xadj_l(el), xadj_l(el+1) - 1
+ if ( is_elastic(num_material(adjncy_l(el_adj)+1)) ) then
+ nedges_elporo_coupled = nedges_elporo_coupled + 1
+ edges_elporo_coupled(1,nedges_elporo_coupled) = el
+ edges_elporo_coupled(2,nedges_elporo_coupled) = adjncy_l(el_adj)
+ endif
+
+ enddo
+ endif
+ enddo
+
+ do i = 1, nedges_elporo_coupled*nproc
+ is_repartitioned = .false.
+ do num_edge = 1, nedges_elporo_coupled
+ if ( part(edges_elporo_coupled(1,num_edge)) /= part(edges_elporo_coupled(2,num_edge)) ) then
+ if ( part(edges_elporo_coupled(1,num_edge)) < part(edges_elporo_coupled(2,num_edge)) ) then
+ part(edges_elporo_coupled(2,num_edge)) = part(edges_elporo_coupled(1,num_edge))
+ else
+ part(edges_elporo_coupled(1,num_edge)) = part(edges_elporo_coupled(2,num_edge))
+ endif
+ is_repartitioned = .true.
+ endif
+
+ enddo
+ if ( .not. is_repartitioned ) then
+ exit
+ endif
+ enddo
+
+ deallocate(xadj_l,adjncy_l)
+
+ end subroutine poro_elastic_repartitioning
+
+
+ !--------------------------------------------------
+ ! Write fluid/solid edges (fluid (or porous) elements and corresponding solid (or porous) elements)
+ ! pertaining to iproc partition in the corresponding Database
+ !--------------------------------------------------
+
+ subroutine write_fluidsolid_edges_database(IIN_database, nedges_coupled_bis, nedges_coupled_loc_bis, &
+ edges_coupled_bis, iproc, num_phase)
+
+ implicit none
+
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: nedges_coupled_bis
+ integer, intent(inout) :: nedges_coupled_loc_bis
+ integer, dimension(:,:), pointer :: edges_coupled_bis
+ integer, intent(in) :: iproc
+ integer, intent(in) :: num_phase
+
+ integer :: i
+
+ if ( num_phase == 1 ) then
+ nedges_coupled_loc_bis = 0
+ do i = 1, nedges_coupled_bis
+ if ( part(edges_coupled_bis(1,i)) == iproc ) then
+ nedges_coupled_loc_bis = nedges_coupled_loc_bis + 1
+ endif
+ enddo
+ else
+ do i = 1, nedges_coupled_bis
+ if ( part(edges_coupled_bis(1,i)) == iproc ) then
+ write(IIN_database,*) glob2loc_elmnts(edges_coupled_bis(1,i))+1, glob2loc_elmnts(edges_coupled_bis(2,i))+1
+ endif
+ enddo
+ endif
+
+ end subroutine write_fluidsolid_edges_database
+
+end module part_unstruct
Copied: seismo/2D/SPECFEM2D/trunk/src/plotgll.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/plotgll.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/plotgll.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/plotgll.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,258 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
+
+! output the Gauss-Lobatto-Legendre mesh in a gnuplot file
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec,iy,ix,iglobnum,iglobnum2,ibloc,inode,npoin,npgeo,ngnod,nspec
+
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLX,nspec)
+
+ double precision coorg(NDIM,npgeo),coord(NDIM,npoin)
+
+! coordinates of the nodes for Gnuplot file
+ integer, parameter :: MAXNGNOD = 9
+ double precision xval(MAXNGNOD),zval(MAXNGNOD)
+
+ character(len=70) name
+
+!
+!---- output the GLL mesh in a Gnuplot file
+!
+
+ write(iout,*)
+ write(iout,*) 'Generating gnuplot meshes...'
+ write(iout,*)
+
+! create non empty files for the case of 4-node elements
+
+ name='macros1.gnu'
+ open(unit=30,file=name,status='unknown')
+
+ name='macros2.gnu'
+ open(unit=31,file=name,status='unknown')
+ write(31,"('')")
+
+ name='gllmesh1.gnu'
+ open(unit=20,file=name,status='unknown')
+
+ name='gllmesh2.gnu'
+ open(unit=21,file=name,status='unknown')
+ write(21,"('')")
+
+ do ispec = 1,nspec
+
+!
+!---- plot the lines in xi-direction
+!
+ do iy = 1,NGLLZ
+ do ix = 1,NGLLX-1
+!
+!---- get the global point number
+!
+ iglobnum = ibool(ix,iy,ispec)
+!
+!---- do the same for next point on horizontal line
+!
+ iglobnum2 = ibool(ix+1,iy,ispec)
+
+ write(20,*) coord(1,iglobnum),coord(2,iglobnum)
+ write(20,*) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(20,"('')")
+
+ if(iy == 1 .or. iy == NGLLZ) then
+ write(21,*) coord(1,iglobnum),coord(2,iglobnum)
+ write(21,*) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(21,"('')")
+ endif
+
+ enddo
+ enddo
+
+!
+!---- plot the lines in eta-direction
+!
+ do ix = 1,NGLLX
+ do iy = 1,NGLLZ-1
+!
+!---- get the global point number
+!
+ iglobnum = ibool(ix,iy,ispec)
+!
+!---- do the same for next point on vertical line
+!
+ iglobnum2 = ibool(ix,iy+1,ispec)
+
+ write(20,*) coord(1,iglobnum),coord(2,iglobnum)
+ write(20,*) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(20,"('')")
+
+ if(ix == 1 .or. ix == NGLLX) then
+ write(21,*) coord(1,iglobnum),coord(2,iglobnum)
+ write(21,*) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(21,"('')")
+ endif
+
+ enddo
+ enddo
+ enddo
+
+!
+!---- plot the macrobloc mesh using Gnuplot
+!
+ do ibloc = 1,nspec
+ do inode = 1,ngnod
+
+ xval(inode) = coorg(1,knods(inode,ibloc))
+ zval(inode) = coorg(2,knods(inode,ibloc))
+
+ enddo
+
+ if(ngnod == 4) then
+!
+!---- 4-node rectangular element
+!
+
+! draw the edges of the element using one color
+ write(30,*) xval(1),zval(1)
+ write(30,*) xval(2),zval(2)
+ write(30,"('')")
+ write(30,*) xval(2),zval(2)
+ write(30,*) xval(3),zval(3)
+ write(30,"('')")
+ write(30,*) xval(3),zval(3)
+ write(30,*) xval(4),zval(4)
+ write(30,"('')")
+ write(30,*) xval(4),zval(4)
+ write(30,*) xval(1),zval(1)
+ write(30,"('')")
+
+ else
+
+!
+!---- 9-node rectangular element
+!
+
+! draw the edges of the element using one color
+ write(30,*) xval(1),zval(1)
+ write(30,*) xval(5),zval(5)
+ write(30,"('')")
+ write(30,*) xval(5),zval(5)
+ write(30,*) xval(2),zval(2)
+ write(30,"('')")
+ write(30,*) xval(2),zval(2)
+ write(30,*) xval(6),zval(6)
+ write(30,"('')")
+ write(30,*) xval(6),zval(6)
+ write(30,*) xval(3),zval(3)
+ write(30,"('')")
+ write(30,*) xval(3),zval(3)
+ write(30,*) xval(7),zval(7)
+ write(30,"('')")
+ write(30,*) xval(7),zval(7)
+ write(30,*) xval(4),zval(4)
+ write(30,"('')")
+ write(30,*) xval(4),zval(4)
+ write(30,*) xval(8),zval(8)
+ write(30,"('')")
+ write(30,*) xval(8),zval(8)
+ write(30,*) xval(1),zval(1)
+ write(30,"('')")
+
+! draw middle lines using another color
+ write(31,*) xval(5),zval(5)
+ write(31,*) xval(9),zval(9)
+ write(31,"('')")
+ write(31,*) xval(9),zval(9)
+ write(31,*) xval(7),zval(7)
+ write(31,"('')")
+ write(31,*) xval(8),zval(8)
+ write(31,*) xval(9),zval(9)
+ write(31,"('')")
+ write(31,*) xval(9),zval(9)
+ write(31,*) xval(6),zval(6)
+ write(31,"('')")
+
+ endif
+
+ enddo
+
+ close(20)
+ close(21)
+
+ close(30)
+ close(31)
+
+!
+!---- generate the command file for Gnuplot
+!
+ open(unit=20,file='plotall_gll_mesh.gnu',status='unknown')
+ write(20,*) 'set term x11'
+ write(20,*) '# set term postscript landscape color solid "Helvetica" 22'
+ write(20,*) '# set output "gll_mesh.ps"'
+ write(20,*) 'set xlabel "X"'
+ write(20,*) 'set ylabel "Y"'
+ write(20,*) 'set title "Gauss-Lobatto-Legendre Mesh"'
+ write(20,*) 'plot "gllmesh1.gnu" title '''' w l 2, "gllmesh2.gnu" title '''' w linesp 1 3'
+ write(20,*) 'pause -1 "Hit any key to exit..."'
+ close(20)
+
+ open(unit=20,file='plotall_macro_mesh.gnu',status='unknown')
+ write(20,*) 'set term x11'
+ write(20,*) '# set term postscript landscape color solid "Helvetica" 22'
+ write(20,*) '# set output "macro_mesh.ps"'
+ write(20,*) 'set xlabel "X"'
+ write(20,*) 'set ylabel "Y"'
+ write(20,*) 'set title "Spectral Element (Macrobloc) Mesh"'
+ write(20,*) 'plot "macros2.gnu" title '''' w l 2, "macros1.gnu" title '''' w linesp 1 3'
+ write(20,*) 'pause -1 "Hit any key to exit..."'
+ close(20)
+
+ end subroutine plotgll
+
Copied: seismo/2D/SPECFEM2D/trunk/src/plotpost.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/plotpost.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/plotpost.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/plotpost.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,3070 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine plotpost(displ,coord,vpext,x_source,z_source,st_xval,st_zval,it,dt,coorg, &
+ xinterp,zinterp,shapeint,Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,nelem_acoustic_surface, acoustic_edges, &
+ simulation_title,npoin,npgeo,vpmin,vpmax,nrec,NSOURCES, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier, &
+ d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
+ d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
+ coorg_send_ps_velocity_model,RGB_send_ps_velocity_model, &
+ coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model,&
+ d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
+ d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
+ coorg_send_ps_element_mesh,color_send_ps_element_mesh, &
+ coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
+ d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs, &
+ d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
+ coorg_send_ps_abs,coorg_recv_ps_abs, &
+ d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface, &
+ d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
+ coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
+ d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field, &
+ d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
+ coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
+
+!
+! PostScript display routine
+!
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+! color palette
+ integer, parameter :: NUM_COLORS = 236
+ double precision, dimension(NUM_COLORS) :: red,green,blue
+
+ integer it,nrec,nelemabs,numat,pointsdisp,pointsdisp_loop,nspec
+ integer i,npoin,npgeo,ngnod,NSOURCES
+
+ integer kmato(nspec),knods(ngnod,nspec)
+ integer ibool(NGLLX,NGLLZ,nspec)
+
+ double precision xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
+ double precision shapeint(ngnod,pointsdisp,pointsdisp)
+ double precision Uxinterp(pointsdisp,pointsdisp)
+ double precision Uzinterp(pointsdisp,pointsdisp)
+ double precision flagrange(NGLLX,pointsdisp)
+ double precision density(2,numat),poroelastcoef(4,3,numat),porosity(numat),tortuosity(numat)
+
+ double precision dt,timeval
+ double precision, dimension(NSOURCES) :: x_source,z_source
+ double precision displ(3,npoin),coord(NDIM,npoin)
+ double precision vpext(NGLLX,NGLLZ,nspec)
+
+ double precision coorg(NDIM,npgeo)
+ double precision, dimension(nrec) :: st_xval,st_zval
+
+ integer numabs(nelemabs),codeabs(4,nelemabs)
+ logical anyabs,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only
+
+! for fluid/solid edge detection
+ integer :: num_fluid_solid_edges,num_fluid_poro_edges,num_solid_poro_edges
+ integer, dimension(num_fluid_solid_edges) :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge
+ integer, dimension(num_fluid_poro_edges) :: fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge
+ integer, dimension(num_solid_poro_edges) :: solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge
+
+ double precision xmax,zmax,height,xw,zw,usoffset,sizex,sizez,vpmin,vpmax
+
+! for the file name
+ character(len=100) :: file_name
+
+! to suppress useless white spaces in postscript lines
+ character(len=100) :: postscript_line
+ character(len=1), dimension(100) :: ch1,ch2
+ equivalence (postscript_line,ch1)
+ logical :: first
+
+ double precision convert,x1,cpIloc,xa,za,xb,zb
+ double precision z1,x2,z2,d,d1,d2,dummy,theta,thetaup,thetadown
+
+ double precision :: mul_s,kappal_s,rhol_s
+ double precision :: kappal_f,rhol_f
+ double precision :: mul_fr,kappal_fr,phil,tortl
+ double precision :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,rhol_bar
+ double precision :: cpIsquare
+
+ integer k,j,ispec,material,is,ir,imat,icol,l,line_length
+ integer index_char,ii,ipoin,in,nnum,inum,ideb,ifin,iedge
+
+ integer colors,numbers,subsamp,imagetype
+ logical interpol,meshvect,modelvect,boundvect,assign_external_model
+ double precision cutsnaps,sizemax_arrows
+
+ double precision ratio_page,dispmax,xmin,zmin
+
+! title of the plot
+ character(len=60) simulation_title
+
+! for free surface output
+ integer :: nelem_acoustic_surface
+ integer, dimension(4,max(1,nelem_acoustic_surface)) :: acoustic_edges
+
+#ifdef USE_MPI
+ double precision :: xmin_glob, xmax_glob, zmin_glob, zmax_glob
+ double precision :: dispmax_glob
+#endif
+
+ double precision, dimension(:,:), allocatable :: coorg_send
+ double precision, dimension(:,:), allocatable :: coorg_recv
+ integer :: nspec_recv
+ integer :: buffer_offset, RGB_offset
+
+ integer :: nb_coorg_per_elem, nb_color_per_elem
+ integer :: iproc, num_spec
+ integer :: ier
+ logical :: anyabs_glob, coupled_acoustic_elastic_glob, coupled_acoustic_poro_glob, &
+ coupled_elastic_poro_glob
+#ifdef USE_MPI
+ integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
+#endif
+ integer :: myrank, nproc
+
+! plotpost arrays for postscript output
+ integer :: d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
+ d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model
+ double precision, dimension(d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model) :: &
+coorg_send_ps_velocity_model
+ double precision, dimension(d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model) :: &
+coorg_recv_ps_velocity_model
+ double precision, dimension(d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model) :: &
+RGB_send_ps_velocity_model
+ double precision, dimension(d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model) :: &
+RGB_recv_ps_velocity_model
+ integer :: d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
+ d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh, &
+ d1_color_recv_ps_element_mesh
+ double precision, dimension(d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh) :: &
+coorg_send_ps_element_mesh
+ double precision, dimension(d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh) :: &
+coorg_recv_ps_element_mesh
+ integer, dimension(d1_color_send_ps_element_mesh) :: &
+color_send_ps_element_mesh
+ integer, dimension(d1_color_recv_ps_element_mesh) :: &
+color_recv_ps_element_mesh
+ integer :: d1_coorg_send_ps_abs, d1_coorg_recv_ps_abs, &
+ d2_coorg_send_ps_abs, d2_coorg_recv_ps_abs
+ double precision, dimension(d1_coorg_send_ps_abs,d2_coorg_send_ps_abs) :: &
+coorg_send_ps_abs
+ double precision, dimension(d1_coorg_recv_ps_abs,d2_coorg_recv_ps_abs) :: &
+coorg_recv_ps_abs
+ integer :: d1_coorg_send_ps_free_surface, d1_coorg_recv_ps_free_surface, &
+ d2_coorg_send_ps_free_surface, d2_coorg_recv_ps_free_surface
+ double precision, dimension(d1_coorg_send_ps_free_surface,d2_coorg_send_ps_free_surface) :: &
+coorg_send_ps_free_surface
+ double precision, dimension(d1_coorg_recv_ps_free_surface,d2_coorg_recv_ps_free_surface) :: &
+coorg_recv_ps_free_surface
+ integer :: d1_coorg_send_ps_vector_field, d1_coorg_recv_ps_vector_field, &
+ d2_coorg_send_ps_vector_field, d2_coorg_recv_ps_vector_field
+ double precision, dimension(d1_coorg_send_ps_vector_field,d2_coorg_send_ps_vector_field) :: &
+coorg_send_ps_vector_field
+ double precision, dimension(d1_coorg_recv_ps_vector_field,d2_coorg_recv_ps_vector_field) :: &
+coorg_recv_ps_vector_field
+
+#ifndef USE_MPI
+! this to avoid warnings by the compiler about unused variables in the case
+! of a serial code, therefore use them once and do nothing: just set them to zero
+ nspec_recv = 0
+ nb_coorg_per_elem = 0
+ nb_color_per_elem = 0
+ ier = 0
+ num_spec = 0
+ iproc = nproc
+ coorg_recv_ps_velocity_model = 0
+ RGB_recv_ps_velocity_model = 0
+ coorg_recv_ps_element_mesh = 0
+ color_recv_ps_element_mesh = 0
+ coorg_recv_ps_abs = 0
+ coorg_recv_ps_free_surface = 0
+ coorg_recv_ps_vector_field = 0
+ allocate(coorg_recv(1,1))
+ deallocate(coorg_recv)
+#endif
+
+! A4 or US letter paper
+ if(US_LETTER) then
+ usoffset = 1.75d0
+ sizex = 27.94d0
+ sizez = 21.59d0
+ else
+ usoffset = 0.d0
+ sizex = 29.7d0
+ sizez = 21.d0
+ endif
+
+! height of domain numbers in centimeters
+ height = 0.25d0
+
+! define color palette in random order
+
+! red
+ red(1) = 1.00000000000000
+ green(1) = 0.000000000000000E+000
+ blue(1) = 0.000000000000000E+000
+
+! DodgerBlue2
+ red(2) = 0.109803921568627
+ green(2) = 0.525490196078431
+ blue(2) = 0.933333333333333
+
+! gold
+ red(3) = 1.00000000000000
+ green(3) = 0.840000000000000
+ blue(3) = 0.000000000000000E+000
+
+! springgreen
+ red(4) = 0.000000000000000E+000
+ green(4) = 1.00000000000000
+ blue(4) = 0.500000000000000
+
+! NavajoWhite
+ red(5) = 1.00000000000000
+ green(5) = 0.870588235294118
+ blue(5) = 0.678431372549020
+
+! SteelBlue3
+ red(6) = 0.309803921568627
+ green(6) = 0.580392156862745
+ blue(6) = 0.803921568627451
+
+! Ivory3
+ red(7) = 0.803921568627451
+ green(7) = 0.803921568627451
+ blue(7) = 0.756862745098039
+
+! SkyBlue4
+ red(8) = 0.290196078431373
+ green(8) = 0.439215686274510
+ blue(8) = 0.545098039215686
+
+! Snow
+ red(9) = 0.980392156862745
+ green(9) = 0.980392156862745
+ blue(9) = 0.980392156862745
+
+! SteelBlue
+ red(10) = 0.274509803921569
+ green(10) = 0.509803921568627
+ blue(10) = 0.705882352941177
+
+! Bisque3
+ red(11) = 0.803921568627451
+ green(11) = 0.717647058823529
+ blue(11) = 0.619607843137255
+
+! Salmon
+ red(12) = 0.980392156862745
+ green(12) = 0.501960784313725
+ blue(12) = 0.447058823529412
+
+! SlateBlue2
+ red(13) = 0.478431372549020
+ green(13) = 0.403921568627451
+ blue(13) = 0.933333333333333
+
+! NavajoWhite2
+ red(14) = 0.933333333333333
+ green(14) = 0.811764705882353
+ blue(14) = 0.631372549019608
+
+! MediumBlue
+ red(15) = 0.000000000000000E+000
+ green(15) = 0.000000000000000E+000
+ blue(15) = 0.803921568627451
+
+! LightCoral
+ red(16) = 0.941176470588235
+ green(16) = 0.501960784313725
+ blue(16) = 0.501960784313725
+
+! FloralWhite
+ red(17) = 1.00000000000000
+ green(17) = 0.980392156862745
+ blue(17) = 0.941176470588235
+
+! Cornsilk3
+ red(18) = 0.803921568627451
+ green(18) = 0.784313725490196
+ blue(18) = 0.694117647058824
+
+! GhostWhite
+ red(19) = 0.972549019607843
+ green(19) = 0.972549019607843
+ blue(19) = 1.00000000000000
+
+! blue
+ red(20) = 0.000000000000000E+000
+ green(20) = 0.000000000000000E+000
+ blue(20) = 1.00000000000000
+
+! Linen
+ red(21) = 0.980392156862745
+ green(21) = 0.941176470588235
+ blue(21) = 0.901960784313726
+
+! peachpuff
+ red(22) = 1.00000000000000
+ green(22) = 0.850000000000000
+ blue(22) = 0.730000000000000
+
+! Cornsilk1
+ red(23) = 1.00000000000000
+ green(23) = 0.972549019607843
+ blue(23) = 0.862745098039216
+
+! LightSalmon
+ red(24) = 1.00000000000000
+ green(24) = 0.627450980392157
+ blue(24) = 0.478431372549020
+
+! DeepSkyBlue1
+ red(25) = 0.000000000000000E+000
+ green(25) = 0.749019607843137
+ blue(25) = 1.00000000000000
+
+! LemonChiffon4
+ red(26) = 0.545098039215686
+ green(26) = 0.537254901960784
+ blue(26) = 0.439215686274510
+
+! PeachPuff1
+ red(27) = 1.00000000000000
+ green(27) = 0.854901960784314
+ blue(27) = 0.725490196078431
+
+! BlanchedAlmond
+ red(28) = 1.00000000000000
+ green(28) = 0.921568627450980
+ blue(28) = 0.803921568627451
+
+! SlateBlue3
+ red(29) = 0.411764705882353
+ green(29) = 0.349019607843137
+ blue(29) = 0.803921568627451
+
+! LightSkyBlue1
+ red(30) = 0.690196078431373
+ green(30) = 0.886274509803922
+ blue(30) = 1.00000000000000
+
+! DarkViolet
+ red(31) = 0.580392156862745
+ green(31) = 0.000000000000000E+000
+ blue(31) = 0.827450980392157
+
+! Azure3
+ red(32) = 0.756862745098039
+ green(32) = 0.803921568627451
+ blue(32) = 0.803921568627451
+
+! LavenderBlush3
+ red(33) = 0.803921568627451
+ green(33) = 0.756862745098039
+ blue(33) = 0.772549019607843
+
+! Honeydew1
+ red(34) = 0.941176470588235
+ green(34) = 1.00000000000000
+ blue(34) = 0.941176470588235
+
+! Ivory2
+ red(35) = 0.933333333333333
+ green(35) = 0.933333333333333
+ blue(35) = 0.878431372549020
+
+! RosyBrown
+ red(36) = 0.737254901960784
+ green(36) = 0.560784313725490
+ blue(36) = 0.560784313725490
+
+! Thistle
+ red(37) = 0.847058823529412
+ green(37) = 0.749019607843137
+ blue(37) = 0.847058823529412
+
+! Orange
+ red(38) = 1.00000000000000
+ green(38) = 0.647058823529412
+ blue(38) = 0.000000000000000E+000
+
+! DarkSeaGreen
+ red(39) = 0.560784313725490
+ green(39) = 0.737254901960784
+ blue(39) = 0.560784313725490
+
+! Moccasin
+ red(40) = 1.00000000000000
+ green(40) = 0.894117647058824
+ blue(40) = 0.709803921568627
+
+! DeepSkyBlue2
+ red(41) = 0.000000000000000E+000
+ green(41) = 0.698039215686274
+ blue(41) = 0.933333333333333
+
+! SlateGray4
+ red(42) = 0.423529411764706
+ green(42) = 0.482352941176471
+ blue(42) = 0.545098039215686
+
+! Beige
+ red(43) = 0.960784313725490
+ green(43) = 0.960784313725490
+ blue(43) = 0.862745098039216
+
+! Gold
+ red(44) = 1.00000000000000
+ green(44) = 0.843137254901961
+ blue(44) = 0.000000000000000E+000
+
+! SlateBlue
+ red(45) = 0.415686274509804
+ green(45) = 0.352941176470588
+ blue(45) = 0.803921568627451
+
+! SteelBlue1
+ red(46) = 0.388235294117647
+ green(46) = 0.721568627450980
+ blue(46) = 1.00000000000000
+
+! SaddleBrown
+ red(47) = 0.545098039215686
+ green(47) = 0.270588235294118
+ blue(47) = 7.450980392156863E-002
+
+! Pink
+ red(48) = 1.00000000000000
+ green(48) = 0.752941176470588
+ blue(48) = 0.796078431372549
+
+! Black
+ red(49) = 0.000000000000000E+000
+ green(49) = 0.000000000000000E+000
+ blue(49) = 0.000000000000000E+000
+
+! SlateGrey
+ red(50) = 0.439215686274510
+ green(50) = 0.501960784313725
+ blue(50) = 0.564705882352941
+
+! Ivory
+ red(51) = 1.00000000000000
+ green(51) = 1.00000000000000
+ blue(51) = 0.941176470588235
+
+! OliveDrab
+ red(52) = 0.419607843137255
+ green(52) = 0.556862745098039
+ blue(52) = 0.137254901960784
+
+! Ivory1
+ red(53) = 1.00000000000000
+ green(53) = 1.00000000000000
+ blue(53) = 0.941176470588235
+
+! SkyBlue
+ red(54) = 0.529411764705882
+ green(54) = 0.807843137254902
+ blue(54) = 0.921568627450980
+
+! MistyRose3
+ red(55) = 0.803921568627451
+ green(55) = 0.717647058823529
+ blue(55) = 0.709803921568627
+
+! LimeGreen
+ red(56) = 0.196078431372549
+ green(56) = 0.803921568627451
+ blue(56) = 0.196078431372549
+
+! Purple
+ red(57) = 0.627450980392157
+ green(57) = 0.125490196078431
+ blue(57) = 0.941176470588235
+
+! SkyBlue2
+ red(58) = 0.494117647058824
+ green(58) = 0.752941176470588
+ blue(58) = 0.933333333333333
+
+! Red
+ red(59) = 1.00000000000000
+ green(59) = 0.000000000000000E+000
+ blue(59) = 0.000000000000000E+000
+
+! DarkKhaki
+ red(60) = 0.741176470588235
+ green(60) = 0.717647058823529
+ blue(60) = 0.419607843137255
+
+! MediumTurquoise
+ red(61) = 0.282352941176471
+ green(61) = 0.819607843137255
+ blue(61) = 0.800000000000000
+
+! Grey
+ red(62) = 0.745098039215686
+ green(62) = 0.745098039215686
+ blue(62) = 0.745098039215686
+
+! Coral
+ red(63) = 1.00000000000000
+ green(63) = 0.498039215686275
+ blue(63) = 0.313725490196078
+
+! NavajoWhite4
+ red(64) = 0.545098039215686
+ green(64) = 0.474509803921569
+ blue(64) = 0.368627450980392
+
+! SlateBlue4
+ red(65) = 0.278431372549020
+ green(65) = 0.235294117647059
+ blue(65) = 0.545098039215686
+
+! RoyalBlue4
+ red(66) = 0.152941176470588
+ green(66) = 0.250980392156863
+ blue(66) = 0.545098039215686
+
+! YellowGreen
+ red(67) = 0.603921568627451
+ green(67) = 0.803921568627451
+ blue(67) = 0.196078431372549
+
+! DeepSkyBlue3
+ red(68) = 0.000000000000000E+000
+ green(68) = 0.603921568627451
+ blue(68) = 0.803921568627451
+
+! goldenrod
+ red(69) = 0.854901960784314
+ green(69) = 0.647058823529412
+ blue(69) = 0.125490196078431
+
+! AntiqueWhite4
+ red(70) = 0.545098039215686
+ green(70) = 0.513725490196078
+ blue(70) = 0.470588235294118
+
+! lemonchiffon
+ red(71) = 1.00000000000000
+ green(71) = 0.980000000000000
+ blue(71) = 0.800000000000000
+
+! GreenYellow
+ red(72) = 0.678431372549020
+ green(72) = 1.00000000000000
+ blue(72) = 0.184313725490196
+
+! LightSlateGray
+ red(73) = 0.466666666666667
+ green(73) = 0.533333333333333
+ blue(73) = 0.600000000000000
+
+! RoyalBlue
+ red(74) = 0.254901960784314
+ green(74) = 0.411764705882353
+ blue(74) = 0.882352941176471
+
+! DarkGreen
+ red(75) = 0.000000000000000E+000
+ green(75) = 0.392156862745098
+ blue(75) = 0.000000000000000E+000
+
+! NavajoWhite3
+ red(76) = 0.803921568627451
+ green(76) = 0.701960784313725
+ blue(76) = 0.545098039215686
+
+! Azure1
+ red(77) = 0.941176470588235
+ green(77) = 1.00000000000000
+ blue(77) = 1.00000000000000
+
+! PowderBlue
+ red(78) = 0.690196078431373
+ green(78) = 0.878431372549020
+ blue(78) = 0.901960784313726
+
+! slateblue
+ red(79) = 0.420000000000000
+ green(79) = 0.350000000000000
+ blue(79) = 0.800000000000000
+
+! MediumOrchid
+ red(80) = 0.729411764705882
+ green(80) = 0.333333333333333
+ blue(80) = 0.827450980392157
+
+! turquoise
+ red(81) = 0.250000000000000
+ green(81) = 0.880000000000000
+ blue(81) = 0.820000000000000
+
+! Snow1
+ red(82) = 1.00000000000000
+ green(82) = 0.980392156862745
+ blue(82) = 0.980392156862745
+
+! violet
+ red(83) = 0.930000000000000
+ green(83) = 0.510000000000000
+ blue(83) = 0.930000000000000
+
+! DeepPink
+ red(84) = 1.00000000000000
+ green(84) = 7.843137254901961E-002
+ blue(84) = 0.576470588235294
+
+! MistyRose4
+ red(85) = 0.545098039215686
+ green(85) = 0.490196078431373
+ blue(85) = 0.482352941176471
+
+! PeachPuff3
+ red(86) = 0.803921568627451
+ green(86) = 0.686274509803922
+ blue(86) = 0.584313725490196
+
+! MediumSeaGreen
+ red(87) = 0.235294117647059
+ green(87) = 0.701960784313725
+ blue(87) = 0.443137254901961
+
+! Honeydew4
+ red(88) = 0.513725490196078
+ green(88) = 0.545098039215686
+ blue(88) = 0.513725490196078
+
+! Tan
+ red(89) = 0.823529411764706
+ green(89) = 0.705882352941177
+ blue(89) = 0.549019607843137
+
+! DarkGoldenrod
+ red(90) = 0.721568627450980
+ green(90) = 0.525490196078431
+ blue(90) = 4.313725490196078E-002
+
+! Blue2
+ red(91) = 0.000000000000000E+000
+ green(91) = 0.000000000000000E+000
+ blue(91) = 0.933333333333333
+
+! Maroon
+ red(92) = 0.690196078431373
+ green(92) = 0.188235294117647
+ blue(92) = 0.376470588235294
+
+! LightSkyBlue3
+ red(93) = 0.552941176470588
+ green(93) = 0.713725490196078
+ blue(93) = 0.803921568627451
+
+! LemonChiffon2
+ red(94) = 0.933333333333333
+ green(94) = 0.913725490196078
+ blue(94) = 0.749019607843137
+
+! Snow3
+ red(95) = 0.803921568627451
+ green(95) = 0.788235294117647
+ blue(95) = 0.788235294117647
+
+! Ivory4
+ red(96) = 0.545098039215686
+ green(96) = 0.545098039215686
+ blue(96) = 0.513725490196078
+
+! AntiqueWhite3
+ red(97) = 0.803921568627451
+ green(97) = 0.752941176470588
+ blue(97) = 0.690196078431373
+
+! Bisque4
+ red(98) = 0.545098039215686
+ green(98) = 0.490196078431373
+ blue(98) = 0.419607843137255
+
+! Snow2
+ red(99) = 0.933333333333333
+ green(99) = 0.913725490196078
+ blue(99) = 0.913725490196078
+
+! SlateGray1
+ red(100) = 0.776470588235294
+ green(100) = 0.886274509803922
+ blue(100) = 1.00000000000000
+
+! Seashell2
+ red(101) = 0.933333333333333
+ green(101) = 0.898039215686275
+ blue(101) = 0.870588235294118
+
+! Aquamarine
+ red(102) = 0.498039215686275
+ green(102) = 1.00000000000000
+ blue(102) = 0.831372549019608
+
+! SlateGray2
+ red(103) = 0.725490196078431
+ green(103) = 0.827450980392157
+ blue(103) = 0.933333333333333
+
+! White
+ red(104) = 1.00000000000000
+ green(104) = 1.00000000000000
+ blue(104) = 1.00000000000000
+
+! LavenderBlush
+ red(105) = 1.00000000000000
+ green(105) = 0.941176470588235
+ blue(105) = 0.960784313725490
+
+! DodgerBlue3
+ red(106) = 9.411764705882353E-002
+ green(106) = 0.454901960784314
+ blue(106) = 0.803921568627451
+
+! RoyalBlue3
+ red(107) = 0.227450980392157
+ green(107) = 0.372549019607843
+ blue(107) = 0.803921568627451
+
+! LightYellow
+ red(108) = 1.00000000000000
+ green(108) = 1.00000000000000
+ blue(108) = 0.878431372549020
+
+! DeepSkyBlue
+ red(109) = 0.000000000000000E+000
+ green(109) = 0.749019607843137
+ blue(109) = 1.00000000000000
+
+! AntiqueWhite2
+ red(110) = 0.933333333333333
+ green(110) = 0.874509803921569
+ blue(110) = 0.800000000000000
+
+! CornflowerBlue
+ red(111) = 0.392156862745098
+ green(111) = 0.584313725490196
+ blue(111) = 0.929411764705882
+
+! PeachPuff4
+ red(112) = 0.545098039215686
+ green(112) = 0.466666666666667
+ blue(112) = 0.396078431372549
+
+! SpringGreen
+ red(113) = 0.000000000000000E+000
+ green(113) = 1.00000000000000
+ blue(113) = 0.498039215686275
+
+! Honeydew
+ red(114) = 0.941176470588235
+ green(114) = 1.00000000000000
+ blue(114) = 0.941176470588235
+
+! Honeydew2
+ red(115) = 0.878431372549020
+ green(115) = 0.933333333333333
+ blue(115) = 0.878431372549020
+
+! LightSeaGreen
+ red(116) = 0.125490196078431
+ green(116) = 0.698039215686274
+ blue(116) = 0.666666666666667
+
+! NavyBlue
+ red(117) = 0.000000000000000E+000
+ green(117) = 0.000000000000000E+000
+ blue(117) = 0.501960784313725
+
+! Azure4
+ red(118) = 0.513725490196078
+ green(118) = 0.545098039215686
+ blue(118) = 0.545098039215686
+
+! MediumAquamarine
+ red(119) = 0.400000000000000
+ green(119) = 0.803921568627451
+ blue(119) = 0.666666666666667
+
+! SkyBlue3
+ red(120) = 0.423529411764706
+ green(120) = 0.650980392156863
+ blue(120) = 0.803921568627451
+
+! LavenderBlush2
+ red(121) = 0.933333333333333
+ green(121) = 0.878431372549020
+ blue(121) = 0.898039215686275
+
+! Bisque1
+ red(122) = 1.00000000000000
+ green(122) = 0.894117647058824
+ blue(122) = 0.768627450980392
+
+! DarkOrange
+ red(123) = 1.00000000000000
+ green(123) = 0.549019607843137
+ blue(123) = 0.000000000000000E+000
+
+! LightSteelBlue
+ red(124) = 0.690196078431373
+ green(124) = 0.768627450980392
+ blue(124) = 0.870588235294118
+
+! SteelBlue2
+ red(125) = 0.360784313725490
+ green(125) = 0.674509803921569
+ blue(125) = 0.933333333333333
+
+! LemonChiffon3
+ red(126) = 0.803921568627451
+ green(126) = 0.788235294117647
+ blue(126) = 0.647058823529412
+
+! DarkSlateBlue
+ red(127) = 0.282352941176471
+ green(127) = 0.239215686274510
+ blue(127) = 0.545098039215686
+
+! Seashell
+ red(128) = 1.00000000000000
+ green(128) = 0.960784313725490
+ blue(128) = 0.933333333333333
+
+! Firebrick
+ red(129) = 0.698039215686274
+ green(129) = 0.133333333333333
+ blue(129) = 0.133333333333333
+
+! LightGray
+ red(130) = 0.827450980392157
+ green(130) = 0.827450980392157
+ blue(130) = 0.827450980392157
+
+! Blue
+ red(131) = 0.000000000000000E+000
+ green(131) = 0.000000000000000E+000
+ blue(131) = 1.00000000000000
+
+! Bisque2
+ red(132) = 0.933333333333333
+ green(132) = 0.835294117647059
+ blue(132) = 0.717647058823529
+
+! WhiteSmoke
+ red(133) = 0.960784313725490
+ green(133) = 0.960784313725490
+ blue(133) = 0.960784313725490
+
+! SeaGreen
+ red(134) = 0.180392156862745
+ green(134) = 0.545098039215686
+ blue(134) = 0.341176470588235
+
+! Burlywood
+ red(135) = 0.870588235294118
+ green(135) = 0.721568627450980
+ blue(135) = 0.529411764705882
+
+! RoyalBlue2
+ red(136) = 0.262745098039216
+ green(136) = 0.431372549019608
+ blue(136) = 0.933333333333333
+
+! RoyalBlue1
+ red(137) = 0.282352941176471
+ green(137) = 0.462745098039216
+ blue(137) = 1.00000000000000
+
+! SteelBlue4
+ red(138) = 0.211764705882353
+ green(138) = 0.392156862745098
+ blue(138) = 0.545098039215686
+
+! AliceBlue
+ red(139) = 0.941176470588235
+ green(139) = 0.972549019607843
+ blue(139) = 1.00000000000000
+
+! LightSlateBlue
+ red(140) = 0.517647058823529
+ green(140) = 0.439215686274510
+ blue(140) = 1.00000000000000
+
+! MistyRose1
+ red(141) = 1.00000000000000
+ green(141) = 0.894117647058824
+ blue(141) = 0.882352941176471
+
+! SandyBrown
+ red(142) = 0.956862745098039
+ green(142) = 0.643137254901961
+ blue(142) = 0.376470588235294
+
+! DarkOliveGreen
+ red(143) = 0.333333333333333
+ green(143) = 0.419607843137255
+ blue(143) = 0.184313725490196
+
+! Yellow
+ red(144) = 1.00000000000000
+ green(144) = 1.00000000000000
+ blue(144) = 0.000000000000000E+000
+
+! SlateGray3
+ red(145) = 0.623529411764706
+ green(145) = 0.713725490196078
+ blue(145) = 0.803921568627451
+
+! HotPink
+ red(146) = 1.00000000000000
+ green(146) = 0.411764705882353
+ blue(146) = 0.705882352941177
+
+! Violet
+ red(147) = 0.933333333333333
+ green(147) = 0.509803921568627
+ blue(147) = 0.933333333333333
+
+! LightSkyBlue
+ red(148) = 0.529411764705882
+ green(148) = 0.807843137254902
+ blue(148) = 0.980392156862745
+
+! Cornsilk2
+ red(149) = 0.933333333333333
+ green(149) = 0.909803921568627
+ blue(149) = 0.803921568627451
+
+! MidnightBlue
+ red(150) = 9.803921568627451E-002
+ green(150) = 9.803921568627451E-002
+ blue(150) = 0.439215686274510
+
+! AntiqueWhite
+ red(151) = 0.980392156862745
+ green(151) = 0.921568627450980
+ blue(151) = 0.843137254901961
+
+! PaleGreen
+ red(152) = 0.596078431372549
+ green(152) = 0.984313725490196
+ blue(152) = 0.596078431372549
+
+! MedSpringGreen
+ red(153) = 0.000000000000000E+000
+ green(153) = 0.980392156862745
+ blue(153) = 0.603921568627451
+
+! DodgerBlue1
+ red(154) = 0.117647058823529
+ green(154) = 0.564705882352941
+ blue(154) = 1.00000000000000
+
+! Blue3
+ red(155) = 0.000000000000000E+000
+ green(155) = 0.000000000000000E+000
+ blue(155) = 0.803921568627451
+
+! Cyan
+ red(156) = 0.000000000000000E+000
+ green(156) = 1.00000000000000
+ blue(156) = 1.00000000000000
+
+! LemonChiffon
+ red(157) = 1.00000000000000
+ green(157) = 0.980392156862745
+ blue(157) = 0.803921568627451
+
+! mediumorchid
+ red(158) = 0.730000000000000
+ green(158) = 0.330000000000000
+ blue(158) = 0.830000000000000
+
+! Turquoise
+ red(159) = 0.250980392156863
+ green(159) = 0.878431372549020
+ blue(159) = 0.815686274509804
+
+! IndianRed
+ red(160) = 0.803921568627451
+ green(160) = 0.360784313725490
+ blue(160) = 0.360784313725490
+
+! DodgerBlue
+ red(161) = 0.117647058823529
+ green(161) = 0.564705882352941
+ blue(161) = 1.00000000000000
+
+! Seashell3
+ red(162) = 0.803921568627451
+ green(162) = 0.772549019607843
+ blue(162) = 0.749019607843137
+
+! BlueViolet
+ red(163) = 0.541176470588235
+ green(163) = 0.168627450980392
+ blue(163) = 0.886274509803922
+
+! DeepSkyBlue4
+ red(164) = 0.000000000000000E+000
+ green(164) = 0.407843137254902
+ blue(164) = 0.545098039215686
+
+! PaleVioletRed
+ red(165) = 0.858823529411765
+ green(165) = 0.439215686274510
+ blue(165) = 0.576470588235294
+
+! Azure2
+ red(166) = 0.878431372549020
+ green(166) = 0.933333333333333
+ blue(166) = 0.933333333333333
+
+! greenyellow
+ red(167) = 0.680000000000000
+ green(167) = 1.00000000000000
+ blue(167) = 0.180000000000000
+
+! LightGoldenrod
+ red(168) = 0.933333333333333
+ green(168) = 0.866666666666667
+ blue(168) = 0.509803921568627
+
+! MistyRose
+ red(169) = 1.00000000000000
+ green(169) = 0.894117647058824
+ blue(169) = 0.882352941176471
+
+! LightSkyBlue4
+ red(170) = 0.376470588235294
+ green(170) = 0.482352941176471
+ blue(170) = 0.545098039215686
+
+! OrangeRed
+ red(171) = 1.00000000000000
+ green(171) = 0.270588235294118
+ blue(171) = 0.000000000000000E+000
+
+! DimGrey
+ red(172) = 0.411764705882353
+ green(172) = 0.411764705882353
+ blue(172) = 0.411764705882353
+
+! MediumVioletRed
+ red(173) = 0.780392156862745
+ green(173) = 8.235294117647059E-002
+ blue(173) = 0.521568627450980
+
+! DarkSlateGray
+ red(174) = 0.184313725490196
+ green(174) = 0.309803921568627
+ blue(174) = 0.309803921568627
+
+! yellow
+ red(175) = 1.00000000000000
+ green(175) = 1.00000000000000
+ blue(175) = 0.000000000000000E+000
+
+! Plum
+ red(176) = 0.866666666666667
+ green(176) = 0.627450980392157
+ blue(176) = 0.866666666666667
+
+! DarkTurquoise
+ red(177) = 0.000000000000000E+000
+ green(177) = 0.807843137254902
+ blue(177) = 0.819607843137255
+
+! DodgerBlue4
+ red(178) = 6.274509803921569E-002
+ green(178) = 0.305882352941176
+ blue(178) = 0.545098039215686
+
+! Cornsilk
+ red(179) = 1.00000000000000
+ green(179) = 0.972549019607843
+ blue(179) = 0.862745098039216
+
+! SkyBlue1
+ red(180) = 0.529411764705882
+ green(180) = 0.807843137254902
+ blue(180) = 1.00000000000000
+
+! Seashell1
+ red(181) = 1.00000000000000
+ green(181) = 0.960784313725490
+ blue(181) = 0.933333333333333
+
+! lavender
+ red(182) = 0.901960784313726
+ green(182) = 0.901960784313726
+ blue(182) = 0.980392156862745
+
+! Snow4
+ red(183) = 0.545098039215686
+ green(183) = 0.537254901960784
+ blue(183) = 0.537254901960784
+
+! Peru
+ red(184) = 0.803921568627451
+ green(184) = 0.521568627450980
+ blue(184) = 0.247058823529412
+
+! PeachPuff
+ red(185) = 1.00000000000000
+ green(185) = 0.854901960784314
+ blue(185) = 0.725490196078431
+
+! Green
+ red(186) = 0.000000000000000E+000
+ green(186) = 1.00000000000000
+ blue(186) = 0.000000000000000E+000
+
+! Blue1
+ red(187) = 0.000000000000000E+000
+ green(187) = 0.000000000000000E+000
+ blue(187) = 1.00000000000000
+
+! Seashell4
+ red(188) = 0.545098039215686
+ green(188) = 0.525490196078431
+ blue(188) = 0.509803921568627
+
+! dodgerblue
+ red(189) = 0.120000000000000
+ green(189) = 0.560000000000000
+ blue(189) = 1.00000000000000
+
+! MistyRose2
+ red(190) = 0.933333333333333
+ green(190) = 0.835294117647059
+ blue(190) = 0.823529411764706
+
+! Tomato
+ red(191) = 1.00000000000000
+ green(191) = 0.388235294117647
+ blue(191) = 0.278431372549020
+
+! Wheat
+ red(192) = 0.960784313725490
+ green(192) = 0.870588235294118
+ blue(192) = 0.701960784313725
+
+! LightBlue
+ red(193) = 0.678431372549020
+ green(193) = 0.847058823529412
+ blue(193) = 0.901960784313726
+
+! Chocolate
+ red(194) = 0.823529411764706
+ green(194) = 0.411764705882353
+ blue(194) = 0.117647058823529
+
+! Blue4
+ red(195) = 0.000000000000000E+000
+ green(195) = 0.000000000000000E+000
+ blue(195) = 0.545098039215686
+
+! LavenderBlush1
+ red(196) = 1.00000000000000
+ green(196) = 0.941176470588235
+ blue(196) = 0.960784313725490
+
+! Magenta
+ red(197) = 1.00000000000000
+ green(197) = 0.000000000000000E+000
+ blue(197) = 1.00000000000000
+
+! darkturquoise
+ red(198) = 0.000000000000000E+000
+ green(198) = 0.810000000000000
+ blue(198) = 0.820000000000000
+
+! blueviolet
+ red(199) = 0.540000000000000
+ green(199) = 0.170000000000000
+ blue(199) = 0.890000000000000
+
+! MintCream
+ red(200) = 0.960784313725490
+ green(200) = 1.00000000000000
+ blue(200) = 0.980392156862745
+
+! PaleGoldenrod
+ red(201) = 0.933333333333333
+ green(201) = 0.909803921568627
+ blue(201) = 0.666666666666667
+
+! MediumPurple
+ red(202) = 0.576470588235294
+ green(202) = 0.439215686274510
+ blue(202) = 0.858823529411765
+
+! PapayaWhip
+ red(203) = 1.00000000000000
+ green(203) = 0.937254901960784
+ blue(203) = 0.835294117647059
+
+! LavenderBlush4
+ red(204) = 0.545098039215686
+ green(204) = 0.513725490196078
+ blue(204) = 0.525490196078431
+
+! Cornsilk4
+ red(205) = 0.545098039215686
+ green(205) = 0.533333333333333
+ blue(205) = 0.470588235294118
+
+! LtGoldenrodYello
+ red(206) = 0.980392156862745
+ green(206) = 0.980392156862745
+ blue(206) = 0.823529411764706
+
+! limegreen
+ red(207) = 0.200000000000000
+ green(207) = 0.800000000000000
+ blue(207) = 0.200000000000000
+
+! LemonChiffon1
+ red(208) = 1.00000000000000
+ green(208) = 0.980392156862745
+ blue(208) = 0.803921568627451
+
+! DarkOrchid
+ red(209) = 0.600000000000000
+ green(209) = 0.196078431372549
+ blue(209) = 0.800000000000000
+
+! SlateBlue1
+ red(210) = 0.513725490196078
+ green(210) = 0.435294117647059
+ blue(210) = 1.00000000000000
+
+! chartreuse
+ red(211) = 0.500000000000000
+ green(211) = 1.00000000000000
+ blue(211) = 0.000000000000000E+000
+
+! PaleTurquoise
+ red(212) = 0.686274509803922
+ green(212) = 0.933333333333333
+ blue(212) = 0.933333333333333
+
+! NavajoWhite1
+ red(213) = 1.00000000000000
+ green(213) = 0.870588235294118
+ blue(213) = 0.678431372549020
+
+! LightSkyBlue2
+ red(214) = 0.643137254901961
+ green(214) = 0.827450980392157
+ blue(214) = 0.933333333333333
+
+! VioletRed
+ red(215) = 0.815686274509804
+ green(215) = 0.125490196078431
+ blue(215) = 0.564705882352941
+
+! mocassin
+ red(216) = 1.00000000000000
+ green(216) = 0.890000000000000
+ blue(216) = 0.710000000000000
+
+! OldLace
+ red(217) = 0.992156862745098
+ green(217) = 0.960784313725490
+ blue(217) = 0.901960784313726
+
+! deeppink
+ red(218) = 1.00000000000000
+ green(218) = 8.000000000000000E-002
+ blue(218) = 0.580000000000000
+
+! Honeydew3
+ red(219) = 0.756862745098039
+ green(219) = 0.803921568627451
+ blue(219) = 0.756862745098039
+
+! Gainsboro
+ red(220) = 0.862745098039216
+ green(220) = 0.862745098039216
+ blue(220) = 0.862745098039216
+
+! DarkSalmon
+ red(221) = 0.913725490196078
+ green(221) = 0.588235294117647
+ blue(221) = 0.478431372549020
+
+! AntiqueWhite1
+ red(222) = 1.00000000000000
+ green(222) = 0.937254901960784
+ blue(222) = 0.858823529411765
+
+! LightCyan
+ red(223) = 0.878431372549020
+ green(223) = 1.00000000000000
+ blue(223) = 1.00000000000000
+
+! ForestGreen
+ red(224) = 0.133333333333333
+ green(224) = 0.545098039215686
+ blue(224) = 0.133333333333333
+
+! Orchid
+ red(225) = 0.854901960784314
+ green(225) = 0.439215686274510
+ blue(225) = 0.839215686274510
+
+! PeachPuff2
+ red(226) = 0.933333333333333
+ green(226) = 0.796078431372549
+ blue(226) = 0.678431372549020
+
+! LightPink
+ red(227) = 1.00000000000000
+ green(227) = 0.713725490196078
+ blue(227) = 0.756862745098039
+
+! Sienna
+ red(228) = 0.627450980392157
+ green(228) = 0.321568627450980
+ blue(228) = 0.176470588235294
+
+! darkorchid
+ red(229) = 0.600000000000000
+ green(229) = 0.200000000000000
+ blue(229) = 0.800000000000000
+
+! MediumSlateBlue
+ red(230) = 0.482352941176471
+ green(230) = 0.407843137254902
+ blue(230) = 0.933333333333333
+
+! CadetBlue
+ red(231) = 0.372549019607843
+ green(231) = 0.619607843137255
+ blue(231) = 0.627450980392157
+
+! LawnGreen
+ red(232) = 0.486274509803922
+ green(232) = 0.988235294117647
+ blue(232) = 0.000000000000000E+000
+
+! Chartreuse
+ red(233) = 0.498039215686275
+ green(233) = 1.00000000000000
+ blue(233) = 0.000000000000000E+000
+
+! Brown
+ red(234) = 0.647058823529412
+ green(234) = 0.164705882352941
+ blue(234) = 0.164705882352941
+
+! Azure
+ red(235) = 0.941176470588235
+ green(235) = 1.00000000000000
+ blue(235) = 1.00000000000000
+
+! Bisque
+ red(236) = 1.00000000000000
+ green(236) = 0.894117647058824
+ blue(236) = 0.768627450980392
+
+! get minimum and maximum values of mesh coordinates
+ xmin = minval(coord(1,:))
+ zmin = minval(coord(2,:))
+ xmax = maxval(coord(1,:))
+ zmax = maxval(coord(2,:))
+
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (xmin, xmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (zmin, zmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (xmax, xmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (zmax, zmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ xmin = xmin_glob
+ zmin = zmin_glob
+ xmax = xmax_glob
+ zmax = zmax_glob
+#endif
+
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'X min, max = ',xmin,xmax
+ write(IOUT,*) 'Z min, max = ',zmin,zmax
+ endif
+
+! ratio of physical page size/size of the domain meshed
+ ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
+
+! compute the maximum of the norm of the vector
+ dispmax = maxval(sqrt(displ(1,:)**2 + displ(3,:)**2))
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (dispmax, dispmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ dispmax = dispmax_glob
+#endif
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Max norm = ',dispmax
+ endif
+
+!
+!---- open PostScript file
+!
+ if ( myrank == 0 ) then
+ write(file_name,"('OUTPUT_FILES/vect',i7.7,'.ps')") it
+ open(unit=24,file=file_name,status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% gray levels for the velocity model'
+ write(24,*) '/BK {setgray fill} def'
+ write(24,*) '% black and white version'
+ write(24,*) '%/BK {pop 1 setgray fill} def'
+ write(24,*) '%'
+ write(24,*) '% magenta for vectors'
+ write(24,*) '/Colvects {0 setlinewidth 1. 0. 1. RG} def'
+ write(24,*) '% black and white version'
+ write(24,*) '%/Colvects {0 setlinewidth 0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% chartreuse for macrobloc mesh'
+ write(24,*) '/Colmesh {0 setlinewidth 0.5 1. 0. RG} def'
+ write(24,*) '% black and white version'
+ write(24,*) '%/Colmesh {0 setlinewidth 0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% cyan for sources and receivers'
+ write(24,*) '/Colreceiv {0. 1. 1. RG} def'
+ write(24,*) '% black and white version'
+ write(24,*) '%/Colreceiv {0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw an arrow'
+ write(24,*) '/F {MV LR gsave LR ST grestore LR ST} def'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '0 setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '% uncomment this to zoom on parts of the mesh'
+ write(24,*) '% -32 CM -21 CM translate 3. 3. scale'
+ write(24,*) '% -52 CM -24 CM translate 4. 4. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '24. CM 1.2 CM MV'
+ write(24,610) usoffset,it
+ write(24,*) '%'
+
+ write(24,*) '24. CM 1.95 CM MV'
+ timeval = it*dt
+ if(timeval >= 1.d-3 .and. timeval < 1000.d0) then
+ write(24,600) usoffset,timeval
+ else
+ write(24,601) usoffset,timeval
+ endif
+ write(24,*) '%'
+ write(24,*) '24. CM 2.7 CM MV'
+ write(24,640) usoffset,dispmax
+ write(24,*) '%'
+ write(24,*) '24. CM 3.45 CM MV'
+ write(24,620) usoffset,cutsnaps*100.d0
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ if(colors == 1) write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Z axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM scalefont setfont'
+ if(colors == 1) write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ if(imagetype == 1) then
+ write(24,*) '(Displacement vector field) show'
+ else if(imagetype == 2) then
+ write(24,*) '(Velocity vector field) show'
+ else if(imagetype == 3) then
+ write(24,*) '(Acceleration vector field) show'
+ else
+ call exit_MPI('Bad field code in PostScript display')
+ endif
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+
+ if(coupled_acoustic_elastic) then
+ write(24,*) '(Coupled Acoustic/Elastic Wave 2D - SEM) show'
+ else if(coupled_acoustic_poro) then
+ write(24,*) '(Coupled Acoustic/Poroelastic Wave 2D - SEM) show'
+ else if(coupled_elastic_poro) then
+ write(24,*) '(Coupled Elastic/Poroelastic Wave 2D - SEM) show'
+ else if(any_acoustic) then
+ write(24,*) '(Acoustic Wave 2D - Spectral Element Method) show'
+ else if(any_poroelastic) then
+ write(24,*) '(Poroelastic Wave 2D - Spectral Element Method) show'
+ else
+ write(24,*) '(Elastic Wave 2D - Spectral Element Method) show'
+ endif
+
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- print the spectral elements mesh in PostScript
+!
+
+ endif
+
+
+ convert = PI / 180.d0
+
+!
+!---- draw the velocity model in background
+!
+ if(modelvect) then
+
+ buffer_offset = 0
+ RGB_offset = 0
+
+ do ispec=1,nspec
+ do i=1,NGLLX-subsamp,subsamp
+ do j=1,NGLLX-subsamp,subsamp
+
+ if((vpmax-vpmin)/vpmin > 0.02d0) then
+ if(assign_external_model) then
+ x1 = (vpext(i,j,ispec)-vpmin) / (vpmax-vpmin)
+ else
+ material = kmato(ispec)
+! get elastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = rhol_bar - phil/tortl*rhol_f
+ bfactor = H_biot + phil*rhol_bar/(tortl*rhol_f)*M_biot - 2.d0*phil/tortl*C_biot
+ cfactor = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIloc = sqrt(cpIsquare)
+ x1 = (cpIloc-vpmin)/(vpmax-vpmin)
+ endif
+ else
+ x1 = 0.5d0
+ endif
+
+! rescale to avoid very dark gray levels
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+! invert scale: white = vpmin, dark gray = vpmax
+ x1 = 1.d0 - x1
+
+ xw = coord(1,ibool(i,j,ispec))
+ zw = coord(2,ibool(i,j,ispec))
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ if ( myrank == 0 ) then
+ write(24,500) xw,zw
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_velocity_model(1,buffer_offset) = xw
+ coorg_send_ps_velocity_model(2,buffer_offset) = zw
+ endif
+
+ xw = coord(1,ibool(i+subsamp,j,ispec))
+ zw = coord(2,ibool(i+subsamp,j,ispec))
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ if ( myrank == 0 ) then
+ write(24,499) xw,zw
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_velocity_model(1,buffer_offset) = xw
+ coorg_send_ps_velocity_model(2,buffer_offset) = zw
+ endif
+
+ xw = coord(1,ibool(i+subsamp,j+subsamp,ispec))
+ zw = coord(2,ibool(i+subsamp,j+subsamp,ispec))
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ if ( myrank == 0 ) then
+ write(24,499) xw,zw
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_velocity_model(1,buffer_offset) = xw
+ coorg_send_ps_velocity_model(2,buffer_offset) = zw
+ endif
+
+ xw = coord(1,ibool(i,j+subsamp,ispec))
+ zw = coord(2,ibool(i,j+subsamp,ispec))
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ if ( myrank == 0 ) then
+ write(24,499) xw,zw
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_velocity_model(1,buffer_offset) = xw
+ coorg_send_ps_velocity_model(2,buffer_offset) = zw
+ endif
+
+! display P-velocity model using gray levels
+ if ( myrank == 0 ) then
+ write(24,604) x1
+ else
+ RGB_offset = RGB_offset + 1
+ RGB_send_ps_velocity_model(1,RGB_offset) = x1
+ endif
+
+ enddo
+ enddo
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ call MPI_RECV (coorg_recv_ps_velocity_model(1,1), &
+ 2*nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4, &
+ MPI_DOUBLE_PRECISION, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ call MPI_RECV (RGB_recv_ps_velocity_model(1,1), nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
+ MPI_DOUBLE_PRECISION, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ RGB_offset = 0
+ do ispec = 1, nspec_recv
+ do i=1,NGLLX-subsamp,subsamp
+ do j=1,NGLLX-subsamp,subsamp
+ buffer_offset = buffer_offset + 1
+ write(24,500) coorg_recv_ps_velocity_model(1,buffer_offset), &
+ coorg_recv_ps_velocity_model(2,buffer_offset)
+ buffer_offset = buffer_offset + 1
+ write(24,499) coorg_recv_ps_velocity_model(1,buffer_offset), &
+ coorg_recv_ps_velocity_model(2,buffer_offset)
+ buffer_offset = buffer_offset + 1
+ write(24,499) coorg_recv_ps_velocity_model(1,buffer_offset), &
+ coorg_recv_ps_velocity_model(2,buffer_offset)
+ buffer_offset = buffer_offset + 1
+ write(24,499) coorg_recv_ps_velocity_model(1,buffer_offset), &
+ coorg_recv_ps_velocity_model(2,buffer_offset)
+ RGB_offset = RGB_offset + 1
+ write(24,604) RGB_recv_ps_velocity_model(1,RGB_offset)
+ enddo
+ enddo
+ enddo
+
+ enddo
+ else
+ call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (coorg_send_ps_velocity_model(1,1), 2*nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4, &
+ MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
+ call MPI_SEND (RGB_send_ps_velocity_model(1,1), nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
+ MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
+ endif
+
+
+#endif
+
+
+ endif
+
+!
+!---- draw the spectral element mesh
+!
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ endif
+
+ buffer_offset = 0
+ RGB_offset = 0
+
+ do ispec=1,nspec
+
+ if ( myrank == 0 ) write(24,*) '% elem ',ispec
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ if ( myrank == 0 ) then
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x1
+ coorg_send_ps_element_mesh(2,buffer_offset) = z1
+ endif
+
+ if(ngnod == 4) then
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+
+ else
+
+! draw curved lines if elements have 9 nodes
+ do ir=2,pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+ enddo
+
+ ir=pointsdisp
+ do is=2,pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+ enddo
+
+ is=pointsdisp
+ do ir=pointsdisp-1,1,-1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+ enddo
+
+ ir=1
+ do is=pointsdisp-1,2,-1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,681) x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+ enddo
+
+ endif
+
+ if ( myrank == 0 ) then
+ write(24,*) 'CO'
+ endif
+
+ if(colors == 1) then
+
+! use a different color for each material set
+ imat = kmato(ispec)
+ icol = mod(imat - 1,NUM_COLORS) + 1
+
+ if ( myrank == 0 ) then
+ if(meshvect) then
+ write(24,680) red(icol),green(icol),blue(icol)
+ else
+ write(24,679) red(icol),green(icol),blue(icol)
+ endif
+ else
+ RGB_offset = RGB_offset + 1
+ color_send_ps_element_mesh(RGB_offset) = icol
+ endif
+
+ endif
+
+ if ( myrank == 0 ) then
+ if(meshvect) then
+ if(modelvect) then
+ write(24,*) 'Colmesh ST'
+ else
+ write(24,*) '0 setgray ST'
+ endif
+ endif
+ endif
+
+! write the element number, the group number and the material number inside the element
+ if(numbers == 1) then
+
+ xw = (coorg(1,knods(1,ispec)) + coorg(1,knods(2,ispec)) + coorg(1,knods(3,ispec)) + coorg(1,knods(4,ispec))) / 4.d0
+ zw = (coorg(2,knods(1,ispec)) + coorg(2,knods(2,ispec)) + coorg(2,knods(3,ispec)) + coorg(2,knods(4,ispec))) / 4.d0
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+
+ if ( myrank == 0 ) then
+ if(colors == 1) write(24,*) '1 setgray'
+ endif
+
+ if ( myrank == 0 ) then
+ write(24,500) xw,zw
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_element_mesh(1,buffer_offset) = x2
+ coorg_send_ps_element_mesh(2,buffer_offset) = z2
+ endif
+
+! write spectral element number
+ if ( myrank == 0 ) then
+ write(24,502) ispec
+ else
+ RGB_offset = RGB_offset + 1
+ color_send_ps_element_mesh(RGB_offset) = ispec
+ endif
+
+ endif
+
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
+ nb_coorg_per_elem = 1
+ if ( numbers == 1 ) then
+ nb_coorg_per_elem = nb_coorg_per_elem + 1
+ endif
+ if ( ngnod == 4 ) then
+ nb_coorg_per_elem = nb_coorg_per_elem + 4
+ else
+ nb_coorg_per_elem = nb_coorg_per_elem + 3*(pointsdisp-1)+(pointsdisp-2)
+ endif
+ nb_color_per_elem = 0
+ if ( colors == 1 ) then
+ nb_color_per_elem = nb_color_per_elem + 1
+ endif
+ if ( numbers == 1 ) then
+ nb_color_per_elem = nb_color_per_elem + 1
+ endif
+
+ call MPI_RECV (coorg_recv_ps_element_mesh(1,1), 2*nspec_recv*nb_coorg_per_elem, &
+ MPI_DOUBLE_PRECISION, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
+ call MPI_RECV (color_recv_ps_element_mesh(1), nspec_recv*nb_coorg_per_elem, &
+ MPI_INTEGER, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ RGB_offset = 0
+ num_spec = nspec
+ do ispec = 1, nspec_recv
+ num_spec = num_spec + 1
+ write(24,*) '% elem ',num_spec
+ buffer_offset = buffer_offset + 1
+ write(24,*) 'mark'
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ if ( ngnod == 4 ) then
+ buffer_offset = buffer_offset + 1
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ buffer_offset = buffer_offset + 1
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ buffer_offset = buffer_offset + 1
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ buffer_offset = buffer_offset + 1
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+
+ else
+ do ir=2,pointsdisp
+ buffer_offset = buffer_offset + 1
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ enddo
+ do is=2,pointsdisp
+ buffer_offset = buffer_offset + 1
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ enddo
+ do ir=pointsdisp-1,1,-1
+ buffer_offset = buffer_offset + 1
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ enddo
+ do is=pointsdisp-1,2,-1
+ buffer_offset = buffer_offset + 1
+ write(24,681) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ enddo
+
+ endif
+
+ write(24,*) 'CO'
+ if ( colors == 1 ) then
+ if(meshvect) then
+ RGB_offset = RGB_offset + 1
+ write(24,680) red(color_recv_ps_element_mesh(RGB_offset)),&
+ green(color_recv_ps_element_mesh(RGB_offset)),&
+ blue(color_recv_ps_element_mesh(RGB_offset))
+ else
+ RGB_offset = RGB_offset + 1
+ write(24,679) red(color_recv_ps_element_mesh(RGB_offset)),&
+ green(color_recv_ps_element_mesh(RGB_offset)),&
+ blue(color_recv_ps_element_mesh(RGB_offset))
+ endif
+ endif
+ if(meshvect) then
+ if(modelvect) then
+ write(24,*) 'Colmesh ST'
+ else
+ write(24,*) '0 setgray ST'
+ endif
+ endif
+ if(numbers == 1) then
+ if(colors == 1) write(24,*) '1 setgray'
+ buffer_offset = buffer_offset + 1
+ write(24,500) coorg_recv_ps_element_mesh(1,buffer_offset), coorg_recv_ps_element_mesh(2,buffer_offset)
+ RGB_offset = RGB_offset + 1
+ write(24,502) color_recv_ps_element_mesh(RGB_offset)
+ endif
+
+ enddo
+
+ enddo
+ else
+ call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 43, MPI_COMM_WORLD, ier)
+ nb_coorg_per_elem = 1
+ if ( numbers == 1 ) then
+ nb_coorg_per_elem = nb_coorg_per_elem + 1
+ endif
+ if ( ngnod == 4 ) then
+ nb_coorg_per_elem = nb_coorg_per_elem + 4
+ else
+ nb_coorg_per_elem = nb_coorg_per_elem + 3*(pointsdisp-1)+(pointsdisp-2)
+ endif
+ nb_color_per_elem = 0
+ if ( colors == 1 ) then
+ nb_color_per_elem = nb_color_per_elem + 1
+ endif
+ if ( numbers == 1 ) then
+ nb_color_per_elem = nb_color_per_elem + 1
+ endif
+ call MPI_SEND (coorg_send_ps_element_mesh(1,1), 2*nspec*nb_coorg_per_elem, &
+ MPI_DOUBLE_PRECISION, 0, 43, MPI_COMM_WORLD, ier)
+ if ( nb_color_per_elem > 0 ) then
+ call MPI_SEND (color_send_ps_element_mesh(1), nspec*nb_color_per_elem, &
+ MPI_INTEGER, 0, 43, MPI_COMM_WORLD, ier)
+ endif
+
+ endif
+
+#endif
+
+!
+!--- draw absorbing boundaries with a thick color line
+!
+ anyabs_glob = anyabs
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(anyabs, anyabs_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(anyabs_glob .and. boundvect) then
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% boundary conditions on the mesh'
+ write(24,*) '%'
+
+! use green color
+ write(24,*) '0 1 0 RG'
+
+ write(24,*) '0.02 CM setlinewidth'
+ endif
+
+ buffer_offset = 0
+
+ if ( anyabs ) then
+ do inum = 1,nelemabs
+ ispec = numabs(inum)
+
+ do iedge = 1,4
+
+ if(codeabs(iedge,inum) /= 0) then
+
+ if(iedge == ITOP) then
+ ideb = 3
+ ifin = 4
+ else if(iedge == IBOTTOM) then
+ ideb = 1
+ ifin = 2
+ else if(iedge == ILEFT) then
+ ideb = 4
+ ifin = 1
+ else if(iedge == IRIGHT) then
+ ideb = 2
+ ifin = 3
+ else
+ call exit_MPI('Wrong absorbing boundary code')
+ endif
+
+ x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
+ z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
+ x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
+ z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,602) x1,z1,x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_abs(1,buffer_offset) = x1
+ coorg_send_ps_abs(2,buffer_offset) = z1
+ coorg_send_ps_abs(3,buffer_offset) = x2
+ coorg_send_ps_abs(4,buffer_offset) = z2
+ endif
+
+ endif
+ enddo
+
+ enddo
+ endif
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ call MPI_RECV (coorg_recv_ps_abs(1,1), 4*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(24,602) coorg_recv_ps_abs(1,buffer_offset), coorg_recv_ps_abs(2,buffer_offset), &
+ coorg_recv_ps_abs(3,buffer_offset), coorg_recv_ps_abs(4,buffer_offset)
+ enddo
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 44, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send_ps_abs(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
+ endif
+
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0 setlinewidth'
+ endif
+
+ endif
+
+!
+!--- draw free surface with a thick color line
+!
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% free surface on the mesh'
+ write(24,*) '%'
+
+! use orange color
+ write(24,*) '1 0.66 0 RG'
+
+ write(24,*) '0.02 CM setlinewidth'
+ endif
+
+ buffer_offset = 0
+
+ if ( nelem_acoustic_surface > 0 ) then
+ do inum = 1,nelem_acoustic_surface
+ ispec = acoustic_edges(1,inum)
+
+ x1 = (coorg(1,acoustic_edges(3,inum))-xmin)*ratio_page + orig_x
+ z1 = (coorg(2,acoustic_edges(3,inum))-zmin)*ratio_page + orig_z
+ x2 = (coorg(1,acoustic_edges(4,inum))-xmin)*ratio_page + orig_x
+ z2 = (coorg(2,acoustic_edges(4,inum))-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,602) x1,z1,x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_free_surface(1,buffer_offset) = x1
+ coorg_send_ps_free_surface(2,buffer_offset) = z1
+ coorg_send_ps_free_surface(3,buffer_offset) = x2
+ coorg_send_ps_free_surface(4,buffer_offset) = z2
+ endif
+
+ enddo
+ endif
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ call MPI_RECV (coorg_recv_ps_free_surface(1,1), 4*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(24,602) coorg_recv_ps_free_surface(1,buffer_offset), coorg_recv_ps_free_surface(2,buffer_offset), &
+ coorg_recv_ps_free_surface(3,buffer_offset), coorg_recv_ps_free_surface(4,buffer_offset)
+ enddo
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 44, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send_ps_free_surface(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
+ endif
+
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0 setlinewidth'
+ endif
+
+!
+!---- draw the fluid-solid coupling edges with a thick color line
+!
+ coupled_acoustic_elastic_glob = coupled_acoustic_elastic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(coupled_acoustic_elastic, coupled_acoustic_elastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(coupled_acoustic_elastic_glob .and. boundvect) then
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% fluid-solid coupling edges in the mesh'
+ write(24,*) '%'
+
+ write(24,*) '0.02 CM setlinewidth'
+ endif
+
+ if ( myrank /= 0 .and. num_fluid_solid_edges > 0 ) allocate(coorg_send(4,num_fluid_solid_edges))
+ buffer_offset = 0
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec = fluid_solid_acoustic_ispec(inum)
+ iedge = fluid_solid_acoustic_iedge(inum)
+
+! use pink color
+ if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
+
+ if(iedge == ITOP) then
+ ideb = 3
+ ifin = 4
+ else if(iedge == IBOTTOM) then
+ ideb = 1
+ ifin = 2
+ else if(iedge == ILEFT) then
+ ideb = 4
+ ifin = 1
+ else if(iedge == IRIGHT) then
+ ideb = 2
+ ifin = 3
+ else
+ call exit_MPI('Wrong fluid-solid coupling edge code')
+ endif
+
+ x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
+ z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
+ x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
+ z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,602) x1,z1,x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send(1,buffer_offset) = x1
+ coorg_send(2,buffer_offset) = z1
+ coorg_send(3,buffer_offset) = x2
+ coorg_send(4,buffer_offset) = z2
+ endif
+
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ allocate(coorg_recv(4,nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(24,*) '1 0.75 0.8 RG'
+ write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
+ coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
+ enddo
+ deallocate(coorg_recv)
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
+ deallocate(coorg_send)
+ endif
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0 setlinewidth'
+ endif
+
+ endif
+
+!
+!---- draw the fluid-porous coupling edges with a thick color line
+!
+ coupled_acoustic_poro_glob = coupled_acoustic_poro
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(coupled_acoustic_poro, coupled_acoustic_poro_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(coupled_acoustic_poro_glob .and. boundvect) then
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% fluid-porous coupling edges in the mesh'
+ write(24,*) '%'
+
+ write(24,*) '0.02 CM setlinewidth'
+ endif
+
+ if ( myrank /= 0 .and. num_fluid_poro_edges > 0 ) allocate(coorg_send(4,num_fluid_poro_edges))
+ buffer_offset = 0
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec = fluid_poro_acoustic_ispec(inum)
+ iedge = fluid_poro_acoustic_iedge(inum)
+
+! use pink color
+ if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
+
+ if(iedge == ITOP) then
+ ideb = 3
+ ifin = 4
+ else if(iedge == IBOTTOM) then
+ ideb = 1
+ ifin = 2
+ else if(iedge == ILEFT) then
+ ideb = 4
+ ifin = 1
+ else if(iedge == IRIGHT) then
+ ideb = 2
+ ifin = 3
+ else
+ call exit_MPI('Wrong fluid-solid coupling edge code')
+ endif
+
+ x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
+ z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
+ x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
+ z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,602) x1,z1,x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send(1,buffer_offset) = x1
+ coorg_send(2,buffer_offset) = z1
+ coorg_send(3,buffer_offset) = x2
+ coorg_send(4,buffer_offset) = z2
+ endif
+
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ allocate(coorg_recv(4,nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(24,*) '1 0.75 0.8 RG'
+ write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
+ coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
+ enddo
+ deallocate(coorg_recv)
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
+ deallocate(coorg_send)
+ endif
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0 setlinewidth'
+ endif
+
+ endif
+
+!
+!---- draw the solid-porous coupling edges with a thick color line
+!
+ coupled_elastic_poro_glob = coupled_elastic_poro
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(coupled_elastic_poro, coupled_elastic_poro_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(coupled_elastic_poro_glob .and. boundvect) then
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% solid-porous coupling edges in the mesh'
+ write(24,*) '%'
+
+ write(24,*) '0.02 CM setlinewidth'
+ endif
+
+ if ( myrank /= 0 .and. num_solid_poro_edges > 0 ) allocate(coorg_send(4,num_solid_poro_edges))
+ buffer_offset = 0
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the poroelastic element
+ ispec = solid_poro_poroelastic_ispec(inum)
+ iedge = solid_poro_poroelastic_iedge(inum)
+
+! use pink color
+ if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
+
+ if(iedge == ITOP) then
+ ideb = 3
+ ifin = 4
+ else if(iedge == IBOTTOM) then
+ ideb = 1
+ ifin = 2
+ else if(iedge == ILEFT) then
+ ideb = 4
+ ifin = 1
+ else if(iedge == IRIGHT) then
+ ideb = 2
+ ifin = 3
+ else
+ call exit_MPI('Wrong fluid-solid coupling edge code')
+ endif
+
+ x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
+ z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
+ x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
+ z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,602) x1,z1,x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send(1,buffer_offset) = x1
+ coorg_send(2,buffer_offset) = z1
+ coorg_send(3,buffer_offset) = x2
+ coorg_send(4,buffer_offset) = z2
+ endif
+
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ allocate(coorg_recv(4,nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(24,*) '1 0.75 0.8 RG'
+ write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
+ coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
+ enddo
+ deallocate(coorg_recv)
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
+ deallocate(coorg_send)
+ endif
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0 setlinewidth'
+ endif
+
+ endif
+
+!
+!---- draw the normalized vector field
+!
+
+ if ( myrank == 0 ) then
+! return if the maximum vector equals zero (no source)
+ if(dispmax == 0.d0) then
+ write(IOUT,*) 'null vector: returning!'
+ return
+ endif
+
+ write(24,*) '%'
+ write(24,*) '% vector field'
+ write(24,*) '%'
+
+! color arrows if we draw the velocity model in the background
+ if(modelvect) then
+ write(24,*) 'Colvects'
+ else
+ write(24,*) '0 setgray'
+ endif
+ endif
+
+ if(interpol) then
+
+ if (myrank == 0) write(IOUT,*) 'Interpolating the vector field...'
+
+! option to plot only lowerleft corner value to avoid very large files if dense meshes
+ if(plot_lowerleft_corner_only) then
+ pointsdisp_loop = 1
+ else
+ pointsdisp_loop = pointsdisp
+ endif
+
+ buffer_offset = 0
+
+ do ispec=1,nspec
+
+! interpolation on a uniform grid
+#ifdef USE_MPI
+ if(myrank == 0 .and. mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec,' on processor 0'
+#else
+ if(mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec
+#endif
+
+ do i=1,pointsdisp_loop
+ do j=1,pointsdisp_loop
+
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+
+ Uxinterp(i,j) = 0.d0
+ Uzinterp(i,j) = 0.d0
+
+ do k=1,NGLLX
+ do l=1,NGLLX
+
+ Uxinterp(i,j) = Uxinterp(i,j) + displ(1,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
+ Uzinterp(i,j) = Uzinterp(i,j) + displ(3,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
+
+ enddo
+ enddo
+
+ x1 =(xinterp(i,j)-xmin)*ratio_page
+ z1 =(zinterp(i,j)-zmin)*ratio_page
+
+ x2 = Uxinterp(i,j)*sizemax_arrows/dispmax
+ z2 = Uzinterp(i,j)*sizemax_arrows/dispmax
+
+ d = sqrt(x2**2 + z2**2)
+
+! ignore if vector is too small
+ if(d > cutsnaps*sizemax_arrows) then
+
+ d1 = d * ARROW_RATIO
+ d2 = d1 * cos(ARROW_ANGLE*convert)
+
+ dummy = x2/d
+ if(dummy > 0.9999d0) dummy = 0.9999d0
+ if(dummy < -0.9999d0) dummy = -0.9999d0
+ theta = acos(dummy)
+
+ if(z2 < 0.d0) theta = 360.d0*convert - theta
+ thetaup = theta - ARROW_ANGLE*convert
+ thetadown = theta + ARROW_ANGLE*convert
+
+! draw the vector
+ x1 = (orig_x+x1) * centim
+ z1 = (orig_z+z1) * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ xa = -d2*cos(thetaup)
+ za = -d2*sin(thetaup)
+ xa = xa * centim
+ za = za * centim
+ xb = -d2*cos(thetadown)
+ zb = -d2*sin(thetadown)
+ xb = xb * centim
+ zb = zb * centim
+ if ( myrank == 0 ) then
+ write(postscript_line,700) xb,zb,xa,za,x2,z2,x1,z1
+
+! suppress useless white spaces to make PostScript file smaller
+! suppress leading white spaces again, if any
+ postscript_line = adjustl(postscript_line)
+
+ line_length = len_trim(postscript_line)
+ index_char = 1
+ first = .false.
+ do ii = 1,line_length-1
+ if(ch1(ii) /= ' ' .or. first) then
+ if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
+ ch2(index_char) = ch1(ii)
+ index_char = index_char + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(index_char) = ch1(line_length)
+ write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
+
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_vector_field(1,buffer_offset) = xb
+ coorg_send_ps_vector_field(2,buffer_offset) = zb
+ coorg_send_ps_vector_field(3,buffer_offset) = xa
+ coorg_send_ps_vector_field(4,buffer_offset) = za
+ coorg_send_ps_vector_field(5,buffer_offset) = x2
+ coorg_send_ps_vector_field(6,buffer_offset) = z2
+ coorg_send_ps_vector_field(7,buffer_offset) = x1
+ coorg_send_ps_vector_field(8,buffer_offset) = z1
+ endif
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 46, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ call MPI_RECV (coorg_recv_ps_vector_field(1,1), 8*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 46, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(postscript_line,700) coorg_recv_ps_vector_field(1,buffer_offset), &
+ coorg_recv_ps_vector_field(2,buffer_offset), &
+ coorg_recv_ps_vector_field(3,buffer_offset), coorg_recv_ps_vector_field(4,buffer_offset), &
+ coorg_recv_ps_vector_field(5,buffer_offset), coorg_recv_ps_vector_field(6,buffer_offset), &
+ coorg_recv_ps_vector_field(7,buffer_offset), coorg_recv_ps_vector_field(8,buffer_offset)
+
+ ! suppress useless white spaces to make PostScript file smaller
+ ! suppress leading white spaces again, if any
+ postscript_line = adjustl(postscript_line)
+
+ line_length = len_trim(postscript_line)
+ index_char = 1
+ first = .false.
+ do ii = 1,line_length-1
+ if(ch1(ii) /= ' ' .or. first) then
+ if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
+ ch2(index_char) = ch1(ii)
+ index_char = index_char + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(index_char) = ch1(line_length)
+ write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
+ enddo
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 46, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send_ps_vector_field(1,1), 8*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 46, MPI_COMM_WORLD, ier)
+ endif
+
+ endif
+
+#endif
+
+
+! draw the vectors at the nodes of the mesh if we do not interpolate the display on a regular grid
+ else
+
+ buffer_offset = 0
+
+ do ipoin=1,npoin
+
+ x1 =(coord(1,ipoin)-xmin)*ratio_page
+ z1 =(coord(2,ipoin)-zmin)*ratio_page
+
+ x2 = displ(1,ipoin)*sizemax_arrows/dispmax
+ z2 = displ(3,ipoin)*sizemax_arrows/dispmax
+
+ d = sqrt(x2**2 + z2**2)
+
+! ignore if vector is too small
+ if(d > cutsnaps*sizemax_arrows) then
+
+ d1 = d * ARROW_RATIO
+ d2 = d1 * cos(ARROW_ANGLE*convert)
+
+ dummy = x2/d
+ if(dummy > 0.9999d0) dummy = 0.9999d0
+ if(dummy < -0.9999d0) dummy = -0.9999d0
+ theta = acos(dummy)
+
+ if(z2 < 0.d0) theta = 360.d0*convert - theta
+ thetaup = theta - ARROW_ANGLE*convert
+ thetadown = theta + ARROW_ANGLE*convert
+
+! draw the vector
+ x1 = (orig_x+x1) * centim
+ z1 = (orig_z+z1) * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ xa = -d2*cos(thetaup)
+ za = -d2*sin(thetaup)
+ xa = xa * centim
+ za = za * centim
+ xb = -d2*cos(thetadown)
+ zb = -d2*sin(thetadown)
+ xb = xb * centim
+ zb = zb * centim
+ if ( myrank == 0 ) then
+ write(postscript_line,700) xb,zb,xa,za,x2,z2,x1,z1
+
+! suppress useless white spaces to make PostScript file smaller
+! suppress leading white spaces again, if any
+ postscript_line = adjustl(postscript_line)
+
+ line_length = len_trim(postscript_line)
+ index_char = 1
+ first = .false.
+ do ii = 1,line_length-1
+ if(ch1(ii) /= ' ' .or. first) then
+ if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
+ ch2(index_char) = ch1(ii)
+ index_char = index_char + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(index_char) = ch1(line_length)
+ write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
+
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send_ps_vector_field(1,buffer_offset) = xb
+ coorg_send_ps_vector_field(2,buffer_offset) = zb
+ coorg_send_ps_vector_field(3,buffer_offset) = xa
+ coorg_send_ps_vector_field(4,buffer_offset) = za
+ coorg_send_ps_vector_field(5,buffer_offset) = x2
+ coorg_send_ps_vector_field(6,buffer_offset) = z2
+ coorg_send_ps_vector_field(7,buffer_offset) = x1
+ coorg_send_ps_vector_field(8,buffer_offset) = z1
+ endif
+ endif
+
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 47, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ call MPI_RECV (coorg_recv_ps_vector_field(1,1), 8*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 47, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(postscript_line,700) coorg_recv_ps_vector_field(1,buffer_offset), &
+ coorg_recv_ps_vector_field(2,buffer_offset), &
+ coorg_recv_ps_vector_field(3,buffer_offset), coorg_recv_ps_vector_field(4,buffer_offset), &
+ coorg_recv_ps_vector_field(5,buffer_offset), coorg_recv_ps_vector_field(6,buffer_offset), &
+ coorg_recv_ps_vector_field(7,buffer_offset), coorg_recv_ps_vector_field(8,buffer_offset)
+
+ ! suppress useless white spaces to make PostScript file smaller
+ ! suppress leading white spaces again, if any
+ postscript_line = adjustl(postscript_line)
+
+ line_length = len_trim(postscript_line)
+ index_char = 1
+ first = .false.
+ do ii = 1,line_length-1
+ if(ch1(ii) /= ' ' .or. first) then
+ if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
+ ch2(index_char) = ch1(ii)
+ index_char = index_char + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(index_char) = ch1(line_length)
+ write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
+ enddo
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 47, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send_ps_vector_field(1,1), 8*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 47, MPI_COMM_WORLD, ier)
+ endif
+ endif
+
+#endif
+
+ endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+
+! sources and receivers in color if velocity model
+ if(modelvect) then
+ write(24,*) 'Colreceiv'
+ else
+ write(24,*) '0 setgray'
+ endif
+
+!
+!---- write position of the source
+!
+ do i=1,NSOURCES
+ if(i == 1) write(24,*) '% beginning of source line'
+ if(i == NSOURCES) write(24,*) '% end of source line'
+ xw = x_source(i)
+ zw = z_source(i)
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ write(24,500) xw,zw
+ write(24,*) 'Cross'
+ enddo
+
+!
+!---- write position of the receivers
+!
+ do i=1,nrec
+ if(i == 1) write(24,*) '% beginning of receiver line'
+ if(i == nrec) write(24,*) '% end of receiver line'
+
+ xw = st_xval(i)
+ zw = st_zval(i)
+
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ write(24,500) xw,zw
+ write(24,*) 'Diamond'
+ enddo
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+ endif
+
+ 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a100,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
+ 600 format(f6.3,' neg CM 0 MR (Time =',f8.3,' s) show')
+ 601 format(f6.3,' neg CM 0 MR (Time =',1pe12.3,' s) show')
+ 610 format(f6.3,' neg CM 0 MR (Time step = ',i7,') show')
+ 620 format(f6.3,' neg CM 0 MR (Cut =',f5.2,' \%) show')
+ 640 format(f6.3,' neg CM 0 MR (Max norm =',1pe12.3,') show')
+
+ 499 format(f8.3,1x,f8.3,' L')
+ 500 format(f8.3,1x,f8.3,' M')
+ 502 format('fN (',i4,') Cshow')
+ 679 format(f12.6,1x,f12.6,1x,f12.6,' RG fill stroke')
+ 680 format(f12.6,1x,f12.6,1x,f12.6,' RG GF')
+ 681 format(f6.2,1x,f6.2)
+ 602 format(f6.2,1x,f6.2,' M ',f6.2,1x,f6.2,' L ST')
+ 604 format('CP ',f12.6,' BK')
+ 700 format(8(f6.2,1x),'F')
+
+ end subroutine plotpost
+
Copied: seismo/2D/SPECFEM2D/trunk/src/prepare_absorb.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/prepare_absorb.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/prepare_absorb.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/prepare_absorb.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,522 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine prepare_absorb_files(myrank,any_elastic,any_poroelastic,any_acoustic, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,SIMULATION_TYPE)
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank,SIMULATION_TYPE
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ logical :: any_elastic,any_poroelastic,any_acoustic
+
+ ! local parameters
+ character(len=150) :: outputname,outputname2
+
+
+ if(any_elastic) then
+
+ !--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_left',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=35,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=35,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+ !--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_right',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=36,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=36,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+ !--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_bottom',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=37,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=37,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+ !--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_top',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=38,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=38,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif ! any_elastic
+
+ if(any_poroelastic) then
+
+ !--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_left',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_left',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=45,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=25,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=45,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=25,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+ !--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_right',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_right',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=46,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=26,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=46,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=26,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+ !--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_bottom',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_bottom',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=47,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=29,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=47,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=29,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+ !--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_top',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_top',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=48,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=28,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=48,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=28,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif !any_poroelastic
+
+ if(any_acoustic) then
+
+ !--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_left',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=65,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=65,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+ !--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_right',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=66,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=66,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+ !--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_bottom',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=67,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=67,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+ !--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_top',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ open(unit=68,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=68,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif !any_acoustic
+
+
+ end subroutine prepare_absorb_files
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_absorb_elastic(NSTEP,p_sv, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_elastic_left,b_absorb_elastic_right, &
+ b_absorb_elastic_bottom,b_absorb_elastic_top)
+
+ implicit none
+ include "constants.h"
+
+ logical :: p_sv
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer :: NSTEP
+ real(kind=CUSTOM_REAL) :: b_absorb_elastic_left(3,NGLLZ,nspec_xmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_elastic_right(3,NGLLZ,nspec_xmax,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_elastic_bottom(3,NGLLX,nspec_zmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_elastic_top(3,NGLLX,nspec_zmax,NSTEP)
+
+ ! local parameters
+ integer :: ispec,i,it
+
+ do it =1, NSTEP
+
+ !--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLZ
+ read(35) b_absorb_elastic_left(1,i,ispec,it)
+ enddo
+ do i=1,NGLLZ
+ read(35) b_absorb_elastic_left(3,i,ispec,it)
+ enddo
+ b_absorb_elastic_left(2,:,ispec,it) = ZERO
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ read(35) b_absorb_elastic_left(2,i,ispec,it)
+ enddo
+ b_absorb_elastic_left(1,:,ispec,it) = ZERO
+ b_absorb_elastic_left(3,:,ispec,it) = ZERO
+ endif
+
+ enddo
+ endif
+
+ !--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLZ
+ read(36) b_absorb_elastic_right(1,i,ispec,it)
+ enddo
+ do i=1,NGLLZ
+ read(36) b_absorb_elastic_right(3,i,ispec,it)
+ enddo
+ b_absorb_elastic_right(2,:,ispec,it) = ZERO
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ read(36) b_absorb_elastic_right(2,i,ispec,it)
+ enddo
+ b_absorb_elastic_right(1,:,ispec,it) = ZERO
+ b_absorb_elastic_right(3,:,ispec,it) = ZERO
+ endif
+
+ enddo
+ endif
+
+ !--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLX
+ read(37) b_absorb_elastic_bottom(1,i,ispec,it)
+ enddo
+ do i=1,NGLLX
+ read(37) b_absorb_elastic_bottom(3,i,ispec,it)
+ enddo
+ b_absorb_elastic_bottom(2,:,ispec,it) = ZERO
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ read(37) b_absorb_elastic_bottom(2,i,ispec,it)
+ enddo
+ b_absorb_elastic_bottom(1,:,ispec,it) = ZERO
+ b_absorb_elastic_bottom(3,:,ispec,it) = ZERO
+ endif
+
+ enddo
+ endif
+
+ !--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLX
+ read(38) b_absorb_elastic_top(1,i,ispec,it)
+ enddo
+ do i=1,NGLLX
+ read(38) b_absorb_elastic_top(3,i,ispec,it)
+ enddo
+ b_absorb_elastic_top(2,:,ispec,it) = ZERO
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ read(38) b_absorb_elastic_top(2,i,ispec,it)
+ enddo
+ b_absorb_elastic_top(1,:,ispec,it) = ZERO
+ b_absorb_elastic_top(3,:,ispec,it) = ZERO
+ endif
+
+ enddo
+ endif
+
+ enddo
+
+ end subroutine prepare_absorb_elastic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_absorb_poroelastic(NSTEP, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_poro_s_left,b_absorb_poro_w_left, &
+ b_absorb_poro_s_right,b_absorb_poro_w_right, &
+ b_absorb_poro_s_bottom,b_absorb_poro_w_bottom, &
+ b_absorb_poro_s_top,b_absorb_poro_w_top)
+
+ implicit none
+ include "constants.h"
+
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+
+ integer :: NSTEP
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_s_left(NDIM,NGLLZ,nspec_xmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_s_right(NDIM,NGLLZ,nspec_xmax,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_s_bottom(NDIM,NGLLX,nspec_zmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_s_top(NDIM,NGLLX,nspec_zmax,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_w_left(NDIM,NGLLZ,nspec_xmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_w_right(NDIM,NGLLZ,nspec_xmax,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_w_bottom(NDIM,NGLLX,nspec_zmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_poro_w_top(NDIM,NGLLX,nspec_zmax,NSTEP)
+
+ ! local parameters
+ integer :: ispec,i,it,id
+
+ do it =1, NSTEP
+
+ !--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ read(45) b_absorb_poro_s_left(id,i,ispec,it)
+ read(25) b_absorb_poro_w_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ !--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ read(46) b_absorb_poro_s_right(id,i,ispec,it)
+ read(26) b_absorb_poro_w_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ !--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ read(47) b_absorb_poro_s_bottom(id,i,ispec,it)
+ read(29) b_absorb_poro_w_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ !--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ read(48) b_absorb_poro_s_top(id,i,ispec,it)
+ read(28) b_absorb_poro_w_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ enddo
+
+ end subroutine prepare_absorb_poroelastic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_absorb_acoustic(NSTEP, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_acoustic_left,b_absorb_acoustic_right, &
+ b_absorb_acoustic_bottom,b_absorb_acoustic_top)
+
+ implicit none
+ include "constants.h"
+
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+
+ integer :: NSTEP
+ real(kind=CUSTOM_REAL) :: b_absorb_acoustic_left(NGLLZ,nspec_xmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_acoustic_right(NGLLZ,nspec_xmax,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_acoustic_bottom(NGLLX,nspec_zmin,NSTEP)
+ real(kind=CUSTOM_REAL) :: b_absorb_acoustic_top(NGLLX,nspec_zmax,NSTEP)
+
+
+ ! local parameters
+ integer :: ispec,i,it
+
+ do it =1, NSTEP
+
+ !--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do i=1,NGLLZ
+ read(65) b_absorb_acoustic_left(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+ !--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do i=1,NGLLZ
+ read(66) b_absorb_acoustic_right(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+ !--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do i=1,NGLLX
+ read(67) b_absorb_acoustic_bottom(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+ !--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do i=1,NGLLX
+ read(68) b_absorb_acoustic_top(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+ enddo
+
+ end subroutine prepare_absorb_acoustic
+
\ No newline at end of file
Copied: seismo/2D/SPECFEM2D/trunk/src/prepare_assemble_MPI.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/prepare_assemble_MPI.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/prepare_assemble_MPI.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/prepare_assemble_MPI.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,340 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!
+! This file contains subroutines related to assembling (of the mass matrix, potential_dot_dot and
+! accel_elastic, accels_poroelastic, accelw_poroelastic).
+! These subroutines are for the most part not used in the sequential version.
+!
+
+#ifdef USE_MPI
+
+!-----------------------------------------------
+! Determines the points that are on the interfaces with other partitions, to help
+! build the communication buffers, and determines which elements are considered 'inner'
+! (no points in common with other partitions) and 'outer' (at least one point in common
+! with neighbouring partitions).
+! We have both acoustic and (poro)elastic buffers, for coupling between acoustic and (poro)elastic elements
+! led us to have two sets of communications.
+!-----------------------------------------------
+ subroutine prepare_assemble_MPI(nspec,ibool,knods, ngnod,npoin, elastic, poroelastic, &
+ ninterface, max_interface_size, &
+ my_nelmnts_neighbours, my_interfaces, &
+ ibool_interfaces_acoustic, ibool_interfaces_elastic, &
+ ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic, nibool_interfaces_elastic, &
+ nibool_interfaces_poroelastic, &
+ inum_interfaces_acoustic, inum_interfaces_elastic, &
+ inum_interfaces_poroelastic, &
+ ninterface_acoustic, ninterface_elastic, ninterface_poroelastic, &
+ mask_ispec_inner_outer )
+
+ implicit none
+
+ include 'constants.h'
+
+ integer, intent(in) :: nspec, npoin, ngnod
+ logical, dimension(nspec), intent(in) :: elastic, poroelastic
+ integer, dimension(ngnod,nspec), intent(in) :: knods
+ integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
+
+ integer :: ninterface
+ integer :: max_interface_size
+ integer, dimension(ninterface) :: my_nelmnts_neighbours
+ integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
+ integer, dimension(NGLLX*max_interface_size,ninterface) :: &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(ninterface) :: &
+ nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
+
+ integer, dimension(ninterface), intent(out) :: &
+ inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
+ integer, intent(out) :: ninterface_acoustic, ninterface_elastic, ninterface_poroelastic
+
+ logical, dimension(nspec), intent(inout) :: mask_ispec_inner_outer
+
+ ! local parameters
+ integer :: num_interface
+ integer :: ispec_interface
+ logical, dimension(npoin) :: mask_ibool_acoustic
+ logical, dimension(npoin) :: mask_ibool_elastic
+ logical, dimension(npoin) :: mask_ibool_poroelastic
+ integer :: ixmin, ixmax, izmin, izmax, ix, iz
+ integer, dimension(ngnod) :: n
+ integer :: e1, e2, itype, ispec, k, sens, iglob
+ integer :: npoin_interface_acoustic
+ integer :: npoin_interface_elastic
+ integer :: npoin_interface_poroelastic
+
+ ! initializes
+ ibool_interfaces_acoustic(:,:) = 0
+ nibool_interfaces_acoustic(:) = 0
+ ibool_interfaces_elastic(:,:) = 0
+ nibool_interfaces_elastic(:) = 0
+ ibool_interfaces_poroelastic(:,:) = 0
+ nibool_interfaces_poroelastic(:) = 0
+
+ do num_interface = 1, ninterface
+ ! initializes interface point counters
+ npoin_interface_acoustic = 0
+ npoin_interface_elastic = 0
+ npoin_interface_poroelastic = 0
+ mask_ibool_acoustic(:) = .false.
+ mask_ibool_elastic(:) = .false.
+ mask_ibool_poroelastic(:) = .false.
+
+ do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
+ ! element id
+ ispec = my_interfaces(1,ispec_interface,num_interface)
+ ! type of interface: 1 = common point, 2 = common edge
+ itype = my_interfaces(2,ispec_interface,num_interface)
+ ! element control node ids
+ do k = 1, ngnod
+ n(k) = knods(k,ispec)
+ end do
+ ! common node ids
+ e1 = my_interfaces(3,ispec_interface,num_interface)
+ e2 = my_interfaces(4,ispec_interface,num_interface)
+
+ call get_edge(ngnod, n, itype, e1, e2, ixmin, ixmax, izmin, izmax, sens)
+
+ do iz = izmin, izmax, sens
+ do ix = ixmin, ixmax, sens
+ ! global index
+ iglob = ibool(ix,iz,ispec)
+
+ ! checks to which material this common interface belongs
+ if ( elastic(ispec) ) then
+ ! elastic element
+ if(.not. mask_ibool_elastic(iglob)) then
+ mask_ibool_elastic(iglob) = .true.
+ npoin_interface_elastic = npoin_interface_elastic + 1
+ ibool_interfaces_elastic(npoin_interface_elastic,num_interface) = iglob
+ end if
+ else if ( poroelastic(ispec) ) then
+ ! poroelastic element
+ if(.not. mask_ibool_poroelastic(iglob)) then
+ mask_ibool_poroelastic(iglob) = .true.
+ npoin_interface_poroelastic = npoin_interface_poroelastic + 1
+ ibool_interfaces_poroelastic(npoin_interface_poroelastic,num_interface) = iglob
+ end if
+ else
+ ! acoustic element
+ if(.not. mask_ibool_acoustic(iglob)) then
+ mask_ibool_acoustic(iglob) = .true.
+ npoin_interface_acoustic = npoin_interface_acoustic + 1
+ ibool_interfaces_acoustic(npoin_interface_acoustic,num_interface) = iglob
+ end if
+ end if
+ end do
+ end do
+
+ end do
+
+ ! stores counters for interface points
+ nibool_interfaces_acoustic(num_interface) = npoin_interface_acoustic
+ nibool_interfaces_elastic(num_interface) = npoin_interface_elastic
+ nibool_interfaces_poroelastic(num_interface) = npoin_interface_poroelastic
+
+ ! sets inner/outer element flags
+ do ispec = 1, nspec
+ do iz = 1, NGLLZ
+ do ix = 1, NGLLX
+ if ( mask_ibool_acoustic(ibool(ix,iz,ispec)) &
+ .or. mask_ibool_elastic(ibool(ix,iz,ispec)) &
+ .or. mask_ibool_poroelastic(ibool(ix,iz,ispec)) ) then
+ mask_ispec_inner_outer(ispec) = .true.
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end do
+
+ ! sets number of interfaces for each material domain
+ ninterface_acoustic = 0
+ ninterface_elastic = 0
+ ninterface_poroelastic = 0
+
+ ! loops over all MPI interfaces
+ do num_interface = 1, ninterface
+ ! sets acoustic MPI interface (local) indices in range [1,ninterface_acoustic]
+ if ( nibool_interfaces_acoustic(num_interface) > 0 ) then
+ ninterface_acoustic = ninterface_acoustic + 1
+ inum_interfaces_acoustic(ninterface_acoustic) = num_interface
+ end if
+ ! elastic
+ if ( nibool_interfaces_elastic(num_interface) > 0 ) then
+ ninterface_elastic = ninterface_elastic + 1
+ inum_interfaces_elastic(ninterface_elastic) = num_interface
+ end if
+ ! poroelastic
+ if ( nibool_interfaces_poroelastic(num_interface) > 0 ) then
+ ninterface_poroelastic = ninterface_poroelastic + 1
+ inum_interfaces_poroelastic(ninterface_poroelastic) = num_interface
+ end if
+ end do
+
+ end subroutine prepare_assemble_MPI
+
+
+!-----------------------------------------------
+! Get the points (ixmin, ixmax, izmin and izmax) on an node/edge for one element.
+! 'sens' is used to have DO loops with increment equal to 'sens' (-/+1).
+!-----------------------------------------------
+ subroutine get_edge ( ngnod, n, itype, e1, e2, ixmin, ixmax, izmin, izmax, sens )
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: ngnod
+ integer, dimension(ngnod), intent(in) :: n
+ integer, intent(in) :: itype, e1, e2
+ integer, intent(out) :: ixmin, ixmax, izmin, izmax
+ integer, intent(out) :: sens
+
+ if ( itype == 1 ) then
+
+ ! common single point
+
+ ! checks which corner point is given
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ ixmax = 1
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ ixmax = 1
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ sens = 1
+
+ else if( itype == 2 ) then
+
+ ! common edge
+
+ ! checks which edge and corner points are given
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ izmin = 1
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ izmax = 1
+ sens = 1
+ end if
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ izmax = NGLLZ
+ sens = 1
+ end if
+ end if
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ izmin = 1
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ izmax = NGLLZ
+ sens = 1
+ end if
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ izmax = 1
+ sens = -1
+ end if
+ end if
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ izmin = NGLLZ
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ izmax = NGLLZ
+ sens = -1
+ end if
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ izmax = 1
+ sens = -1
+ end if
+ end if
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ izmin = NGLLZ
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ izmax = 1
+ sens = -1
+ end if
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ izmax = NGLLZ
+ sens = 1
+ end if
+ end if
+
+ else
+
+ call exit_MPI('ERROR get_edge unknown type')
+
+ end if
+
+ end subroutine get_edge
+
+#endif
Copied: seismo/2D/SPECFEM2D/trunk/src/prepare_color_image.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/prepare_color_image.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/prepare_color_image.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/prepare_color_image.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,436 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine prepare_color_image_init(NX_IMAGE_color,NZ_IMAGE_color, &
+ xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image, &
+ coord,npoin,npgeo)
+
+ implicit none
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: NX_IMAGE_color,NZ_IMAGE_color
+
+ integer :: npoin,npgeo
+ double precision, dimension(NDIM,npoin) :: coord
+
+ double precision :: xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image
+
+ ! local parameters
+ integer :: npgeo_glob
+ double precision :: xmin_color_image_loc, xmax_color_image_loc, &
+ zmin_color_image_loc,zmax_color_image_loc
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+ ! horizontal size of the image
+ xmin_color_image_loc = minval(coord(1,:))
+ xmax_color_image_loc = maxval(coord(1,:))
+
+ ! vertical size of the image, slightly increase it to go beyond maximum topography
+ zmin_color_image_loc = minval(coord(2,:))
+ zmax_color_image_loc = maxval(coord(2,:))
+
+! global values
+ xmin_color_image = xmin_color_image_loc
+ xmax_color_image = xmax_color_image_loc
+ zmin_color_image = zmin_color_image_loc
+ zmax_color_image = zmax_color_image_loc
+ npgeo_glob = npgeo
+
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(xmin_color_image_loc, xmin_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE(xmax_color_image_loc, xmax_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE(zmin_color_image_loc, zmin_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE(zmax_color_image_loc, zmax_color_image, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE(npgeo, npgeo_glob, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ier)
+#endif
+
+ zmax_color_image = zmin_color_image + 1.05d0 * (zmax_color_image - zmin_color_image)
+
+ ! compute number of pixels in the horizontal direction based on typical number
+ ! of spectral elements in a given direction (may give bad results for very elongated models)
+ NX_IMAGE_color = nint(sqrt(dble(npgeo_glob))) * (NGLLX-1) + 1
+
+ ! compute number of pixels in the vertical direction based on ratio of sizes
+ NZ_IMAGE_color = nint(NX_IMAGE_color * (zmax_color_image - zmin_color_image) &
+ / (xmax_color_image - xmin_color_image))
+
+ ! convert pixel sizes to even numbers because easier to reduce size,
+ ! create MPEG movies in postprocessing
+ NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
+ NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
+
+ ! check that image size is not too big
+ if (NX_IMAGE_color > 99999) call exit_MPI('output image too big : NX_IMAGE_color > 99999.')
+ if (NZ_IMAGE_color > 99999) call exit_MPI('output image too big : NZ_IMAGE_color > 99999.')
+
+ end subroutine prepare_color_image_init
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_color_image_pixels(myrank,NX_IMAGE_color,NZ_IMAGE_color, &
+ xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image, &
+ coord,npoin,coorg,npgeo,nspec,ngnod,knods,ibool, &
+ nb_pixel_loc,iglob_image_color)
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank
+ integer :: NX_IMAGE_color,NZ_IMAGE_color
+ double precision :: xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image
+
+ integer :: npoin,nspec,npgeo,ngnod
+ double precision, dimension(NDIM,npoin) :: coord
+ double precision, dimension(NDIM,npgeo) :: coorg
+
+ integer, dimension(ngnod,nspec) :: knods
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ integer :: nb_pixel_loc
+ integer, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: iglob_image_color
+
+ ! local parameters
+ double precision :: size_pixel_horizontal,size_pixel_vertical
+ double precision, dimension(2,4) :: elmnt_coords
+ double precision :: i_coord, j_coord
+ double precision :: dist_pixel, dist_min_pixel
+ integer :: min_i, min_j, max_i, max_j
+ integer :: ispec,i,j,k,l,iglob
+ logical :: pixel_is_in
+
+ ! create all the pixels
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'locating all the pixels of color images'
+ endif
+
+ size_pixel_horizontal = (xmax_color_image - xmin_color_image) / dble(NX_IMAGE_color-1)
+ size_pixel_vertical = (zmax_color_image - zmin_color_image) / dble(NZ_IMAGE_color-1)
+
+ iglob_image_color(:,:) = -1
+
+ ! checking which pixels are inside each elements
+
+ nb_pixel_loc = 0
+ do ispec = 1, nspec
+
+ do k = 1, 4
+ elmnt_coords(1,k) = coorg(1,knods(k,ispec))
+ elmnt_coords(2,k) = coorg(2,knods(k,ispec))
+ enddo
+
+ ! avoid working on the whole pixel grid
+ min_i = floor(minval((elmnt_coords(1,:) - xmin_color_image))/size_pixel_horizontal) + 1
+ max_i = ceiling(maxval((elmnt_coords(1,:) - xmin_color_image))/size_pixel_horizontal) + 1
+ min_j = floor(minval((elmnt_coords(2,:) - zmin_color_image))/size_pixel_vertical) + 1
+ max_j = ceiling(maxval((elmnt_coords(2,:) - zmin_color_image))/size_pixel_vertical) + 1
+
+ ! avoid edge effects
+ if(min_i < 1) min_i = 1
+ if(min_j < 1) min_j = 1
+
+ if(max_i > NX_IMAGE_color) max_i = NX_IMAGE_color
+ if(max_j > NZ_IMAGE_color) max_j = NZ_IMAGE_color
+
+ do j = min_j, max_j
+ do i = min_i, max_i
+ i_coord = (i-1)*size_pixel_horizontal + xmin_color_image
+ j_coord = (j-1)*size_pixel_vertical + zmin_color_image
+
+ ! checking if the pixel is inside the element (must be a convex quadrilateral)
+ call is_in_convex_quadrilateral( elmnt_coords, i_coord, j_coord, pixel_is_in)
+
+ ! if inside, getting the nearest point inside the element!
+ if ( pixel_is_in ) then
+ dist_min_pixel = HUGEVAL
+ do k = 1, NGLLX
+ do l = 1, NGLLZ
+ iglob = ibool(k,l,ispec)
+ dist_pixel = (coord(1,iglob)-i_coord)**2 + (coord(2,iglob)-j_coord)**2
+ if (dist_pixel < dist_min_pixel) then
+ dist_min_pixel = dist_pixel
+ iglob_image_color(i,j) = iglob
+
+ endif
+
+ enddo
+ enddo
+ if ( dist_min_pixel >= HUGEVAL ) then
+ call exit_MPI('Error in detecting pixel for color image')
+
+ endif
+ nb_pixel_loc = nb_pixel_loc + 1
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine prepare_color_image_pixels
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine prepare_color_image_vp(npoin,image_color_vp_display,iglob_image_color, &
+ NX_IMAGE_color,NZ_IMAGE_color,nb_pixel_loc, &
+ num_pixel_loc,nspec,poroelastic,ibool,kmato, &
+ numat,density,poroelastcoef,porosity,tortuosity, &
+ nproc,myrank,assign_external_model,vpext)
+
+! stores P-velocity model in image_color_vp_display
+
+ implicit none
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: npoin,nspec
+ integer :: NX_IMAGE_color,NZ_IMAGE_color
+ double precision, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: image_color_vp_display
+ integer, dimension(NX_IMAGE_color,NZ_IMAGE_color) :: iglob_image_color
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+
+ logical, dimension(nspec) :: poroelastic
+
+ integer :: nb_pixel_loc
+ integer, dimension(nb_pixel_loc) :: num_pixel_loc
+
+ logical :: assign_external_model
+ integer :: nproc,myrank
+ integer :: numat
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext
+
+ ! local parameters
+ double precision, dimension(:), allocatable :: vp_display
+ double precision :: rhol,mul_relaxed,lambdal_relaxed
+ double precision :: rhol_s,rhol_f,rhol_bar,phil,tortl,mul_s,kappal_s,kappal_f, &
+ mul_fr,kappal_fr
+ double precision :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,&
+ M_biot,B_biot,cpIsquare,cpIIsquare,cssquare
+ double precision :: gamma1,gamma2,gamma3,gamma4,ratio
+ integer :: i,j,k,ispec
+#ifdef USE_MPI
+ double precision, dimension(:), allocatable :: data_pixel_recv
+ double precision, dimension(:), allocatable :: data_pixel_send
+ integer, dimension(:,:), allocatable :: num_pixel_recv
+ integer, dimension(:), allocatable :: nb_pixel_per_proc
+ integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
+ integer :: ier,iproc
+#else
+ integer :: dummy
+#endif
+
+ ! to display the P-velocity model in background on color images
+ allocate(vp_display(npoin))
+
+ do ispec = 1,nspec
+
+ if(poroelastic(ispec)) then
+ !get parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ !solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4.d0*mul_s/3.d0
+ rhol_s = density(1,kmato(ispec))
+ !fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ !frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4.d0*mul_fr/3.d0
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+ !Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) &
+ + kappal_fr + 4.d0*mul_fr/3.d0
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ B_biot = H_biot - 4.d0*mul_fr/3.d0
+ ! Approximated velocities (no viscous dissipation)
+ afactor = rhol_bar - phil/tortl*rhol_f
+ bfactor = H_biot + phil*rhol_bar/(tortl*rhol_f)*M_biot - TWO*phil/tortl*C_biot
+ cfactor = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cssquare = mul_fr/afactor
+
+ ! Approximated ratio r = amplitude "w" field/amplitude "s" field (no viscous dissipation)
+ ! used later for wavespeed kernels calculation, which are presently implemented for inviscid case,
+ ! contrary to primary and density-normalized kernels, which are consistent with viscous fluid case.
+ gamma1 = H_biot - phil/tortl*C_biot
+ gamma2 = C_biot - phil/tortl*M_biot
+ gamma3 = phil/tortl*( M_biot*(afactor/rhol_f + phil/tortl) - C_biot)
+ gamma4 = phil/tortl*( C_biot*(afactor/rhol_f + phil/tortl) - H_biot)
+ ratio = HALF*(gamma1 - gamma3)/gamma4 &
+ + HALF*sqrt((gamma1-gamma3)**2/gamma4**2 &
+ + 4.d0 * gamma2/gamma4)
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ vp_display(ibool(i,j,ispec)) = sqrt(cpIsquare)
+ enddo
+ enddo
+
+ else
+ ! get relaxed elastic parameters of current spectral element
+ rhol = density(1,kmato(ispec))
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ !--- if external medium, get elastic parameters of current grid point
+ if(assign_external_model) then
+ vp_display(ibool(i,j,ispec)) = vpext(i,j,ispec)
+ else
+ vp_display(ibool(i,j,ispec)) = sqrt((lambdal_relaxed + 2.d0*mul_relaxed) / rhol)
+ endif
+ enddo
+ enddo
+ endif !if(poroelastic(ispec)) then
+ enddo
+
+ ! getting velocity for each local pixels
+ image_color_vp_display(:,:) = 0.d0
+
+ do k = 1, nb_pixel_loc
+ j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
+ i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
+ image_color_vp_display(i,j) = vp_display(iglob_image_color(i,j))
+ enddo
+
+! assembling array image_color_vp_display on process zero for color output
+#ifdef USE_MPI
+
+ allocate(nb_pixel_per_proc(nproc))
+ nb_pixel_per_proc(:) = 0
+ call MPI_GATHER( nb_pixel_loc, 1, MPI_INTEGER, nb_pixel_per_proc(1), &
+ 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ier)
+
+
+ if ( myrank == 0 ) then
+ allocate(num_pixel_recv(maxval(nb_pixel_per_proc(:)),nproc))
+ allocate(data_pixel_recv(maxval(nb_pixel_per_proc(:))))
+ endif
+ allocate(data_pixel_send(nb_pixel_loc))
+
+ if (nproc > 1) then
+ if (myrank == 0) then
+ do iproc = 1, nproc-1
+
+ call MPI_RECV(num_pixel_recv(1,iproc+1),nb_pixel_per_proc(iproc+1), MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ call MPI_RECV(data_pixel_recv(1),nb_pixel_per_proc(iproc+1), MPI_DOUBLE_PRECISION, &
+ iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ do k = 1, nb_pixel_per_proc(iproc+1)
+ j = ceiling(real(num_pixel_recv(k,iproc+1)) / real(NX_IMAGE_color))
+ i = num_pixel_recv(k,iproc+1) - (j-1)*NX_IMAGE_color
+
+ ! checks bounds
+ if( i < 1 .or. i > NX_IMAGE_color .or. j < 1 .or. j > NZ_IMAGE_color ) then
+ print*,'image vp bounds:',myrank,iproc,k, &
+ num_pixel_recv(k,iproc+1),nb_pixel_per_proc(iproc+1)
+ print*,' i: ',i,NX_IMAGE_color
+ print*,' j: ',j,NZ_IMAGE_color
+ endif
+
+ image_color_vp_display(i,j) = data_pixel_recv(k)
+ enddo
+ enddo
+
+ else
+ do k = 1, nb_pixel_loc
+ j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
+ i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
+ data_pixel_send(k) = vp_display(iglob_image_color(i,j))
+ enddo
+
+ call MPI_SEND(num_pixel_loc(1),nb_pixel_loc,MPI_INTEGER, &
+ 0, 42, MPI_COMM_WORLD, ier)
+
+ call MPI_SEND(data_pixel_send(1),nb_pixel_loc,MPI_DOUBLE_PRECISION, &
+ 0, 43, MPI_COMM_WORLD, ier)
+
+ endif
+ endif
+
+ deallocate(nb_pixel_per_proc)
+ deallocate(data_pixel_send)
+ if( myrank == 0 ) then
+ deallocate(num_pixel_recv)
+ deallocate(data_pixel_recv)
+ endif
+#else
+ ! to avoid compiler warnings
+ dummy = myrank
+ dummy = nproc
+#endif
+
+ end subroutine prepare_color_image_vp
Copied: seismo/2D/SPECFEM2D/trunk/src/prepare_initialfield.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/prepare_initialfield.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/prepare_initialfield.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/prepare_initialfield.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,395 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine prepare_initialfield(myrank,any_acoustic,any_poroelastic,over_critical_angle, &
+ NSOURCES,source_type,angleforce,x_source,z_source,f0, &
+ npoin,numat,poroelastcoef,density,coord, &
+ angleforce_refl,c_inc,c_refl,cploc,csloc,time_offset, &
+ A_plane, B_plane, C_plane, &
+ accel_elastic,veloc_elastic,displ_elastic)
+
+ implicit none
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: myrank
+ logical :: any_acoustic,any_poroelastic
+
+ integer :: NSOURCES
+ integer, dimension(NSOURCES) :: source_type
+ double precision, dimension(NSOURCES) :: angleforce,x_source,z_source,f0
+
+ integer :: npoin,numat
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(NDIM,npoin) :: coord
+
+ double precision :: angleforce_refl,c_inc,c_refl,cploc,csloc
+ double precision :: time_offset,x0_source,z0_source
+ double precision, dimension(2) :: A_plane, B_plane, C_plane
+
+ real(kind=CUSTOM_REAL), dimension(3,npoin) :: accel_elastic,veloc_elastic,displ_elastic
+
+ logical :: over_critical_angle
+
+ ! local parameters
+ integer :: numat_local,i
+ double precision :: denst,lambdaplus2mu,mu,p
+ double precision :: PP,PS,SP,SS
+ double precision :: xmax, xmin, zmax, zmin,x,z,t
+#ifdef USE_MPI
+ double precision :: xmax_glob, xmin_glob, zmax_glob, zmin_glob
+ integer :: ier
+#endif
+ double precision, external :: ricker_Bielak_displ,ricker_Bielak_veloc,ricker_Bielak_accel
+
+ ! user output
+ if (myrank == 0) then
+ write(IOUT,*)
+ !! DK DK reading of an initial field from an external file has been suppressed
+ !! DK DK and replaced with the implementation of an analytical plane wave
+ !! DK DK write(IOUT,*) 'Reading initial fields from external file...'
+ write(IOUT,*) 'Implementing an analytical initial plane wave...'
+ write(IOUT,*)
+ endif
+
+ if(any_acoustic .or. any_poroelastic) &
+ call exit_MPI('initial field currently implemented for purely elastic simulation only')
+
+ !=======================================================================
+ !
+ ! Calculation of the initial field for a plane wave
+ !
+ !=======================================================================
+
+ if (myrank == 0) then
+ write(IOUT,*) 'Number of grid points: ',npoin
+ write(IOUT,*)
+ write(IOUT,*) '*** calculation of the initial plane wave ***'
+ write(IOUT,*)
+ write(IOUT,*) 'To change the initial plane wave, change source_type in DATA/SOURCE'
+ write(IOUT,*) 'and use 1 for a plane P wave, 2 for a plane SV wave, 3 for a Rayleigh wave'
+ write(IOUT,*)
+
+ ! only implemented for one source
+ if(NSOURCES > 1) call exit_MPI('calculation of the initial wave is only implemented for one source')
+ if (source_type(1) == 1) then
+ write(IOUT,*) 'initial P wave of', angleforce(1)*180.d0/pi, 'degrees introduced.'
+ else if (source_type(1) == 2) then
+ write(IOUT,*) 'initial SV wave of', angleforce(1)*180.d0/pi, ' degrees introduced.'
+
+ else if (source_type(1) == 3) then
+ write(IOUT,*) 'Rayleigh wave introduced.'
+ else
+ call exit_MPI('Unrecognized source_type: should be 1 for plane P waves, 2 for plane SV waves, 3 for Rayleigh wave')
+ endif
+
+ if ((angleforce(1) < 0.0d0 .or. angleforce(1) >= pi/2.d0) .and. source_type(1) /= 3) then
+ call exit_MPI("incorrect angleforce: must have 0 <= angleforce < 90")
+ endif
+ endif
+
+ ! only implemented for homogeneous media therefore only 1 material supported
+ numat_local = numat
+ if (numat /= 1) then
+ if (myrank == 0) write(IOUT,*) 'not possible to have several materials with a plane wave, using the first material'
+ numat_local = 1
+ endif
+
+ mu = poroelastcoef(2,1,numat_local)
+ lambdaplus2mu = poroelastcoef(3,1,numat_local)
+ denst = density(1,numat_local)
+
+ cploc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+
+ ! P wave case
+ if (source_type(1) == 1) then
+
+ p=sin(angleforce(1))/cploc
+ c_inc = cploc
+ c_refl = csloc
+
+ angleforce_refl = asin(p*c_refl)
+
+ ! from formulas (5.26) and (5.27) p 140 in Aki & Richards (1980)
+ PP = (- cos(2.d0*angleforce_refl)**2/csloc**3 &
+ + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc) / &
+ ( cos(2.d0*angleforce_refl)**2/csloc**3 &
+ + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc)
+
+ PS = 4.d0*p*cos(angleforce(1))*cos(2.d0*angleforce_refl) / &
+ (csloc**2*(cos(2.d0*angleforce_refl)**2/csloc**3 &
+ +4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc))
+
+ if (myrank == 0) then
+ write(IOUT,*) 'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi
+ endif
+
+ ! from Table 5.1 p141 in Aki & Richards (1980)
+ ! we put the opposite sign on z coefficients because z axis is oriented from bottom to top
+ A_plane(1) = sin(angleforce(1)); A_plane(2) = cos(angleforce(1))
+ B_plane(1) = PP * sin(angleforce(1)); B_plane(2) = - PP * cos(angleforce(1))
+ C_plane(1) = PS * cos(angleforce_refl); C_plane(2) = PS * sin(angleforce_refl)
+
+ ! SV wave case
+ else if (source_type(1) == 2) then
+
+ p=sin(angleforce(1))/csloc
+ c_inc = csloc
+ c_refl = cploc
+
+ ! if this coefficient is greater than 1, we are beyond the critical SV wave angle and there cannot be a converted P wave
+ if (p*c_refl<=1.d0) then
+ angleforce_refl = asin(p*c_refl)
+
+ ! from formulas (5.30) and (5.31) p 140 in Aki & Richards (1980)
+ SS = (cos(2.d0*angleforce(1))**2/csloc**3 &
+ - 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc) / &
+ (cos(2.d0*angleforce(1))**2/csloc**3 &
+ + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc)
+ SP = 4.d0*p*cos(angleforce(1))*cos(2*angleforce(1)) / &
+ (cploc*csloc*(cos(2.d0*angleforce(1))**2/csloc**3&
+ +4.d0*p**2*cos(angleforce_refl)*cos(angleforce(1))/cploc))
+
+ if (myrank == 0) then
+ write(IOUT,*) 'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi
+ endif
+
+ ! SV45 degree incident plane wave is a particular case
+ else if (angleforce(1)>pi/4.d0-1.0d-11 .and. angleforce(1)<pi/4.d0+1.0d-11) then
+ angleforce_refl = 0.d0
+ SS = -1.0d0
+ SP = 0.d0
+ else
+ over_critical_angle=.true.
+ angleforce_refl = 0.d0
+ SS = 0.0d0
+ SP = 0.d0
+ endif
+
+ ! from Table 5.1 p141 in Aki & Richards (1980)
+ ! we put the opposite sign on z coefficients because z axis is oriented from bottom to top
+ A_plane(1) = cos(angleforce(1)); A_plane(2) = - sin(angleforce(1))
+ B_plane(1) = SS * cos(angleforce(1)); B_plane(2) = SS * sin(angleforce(1))
+ C_plane(1) = SP * sin(angleforce_refl); C_plane(2) = - SP * cos(angleforce_refl)
+
+ ! Rayleigh case
+ else if (source_type(1) == 3) then
+ over_critical_angle=.true.
+ A_plane(1)=0.d0; A_plane(2)=0.d0
+ B_plane(1)=0.d0; B_plane(2)=0.d0
+ C_plane(1)=0.d0; C_plane(2)=0.d0
+ endif
+
+ ! get minimum and maximum values of mesh coordinates
+ xmin = minval(coord(1,:))
+ zmin = minval(coord(2,:))
+ xmax = maxval(coord(1,:))
+ zmax = maxval(coord(2,:))
+
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (xmin, xmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (zmin, zmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (xmax, xmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (zmax, zmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ xmin = xmin_glob
+ zmin = zmin_glob
+ xmax = xmax_glob
+ zmax = zmax_glob
+#endif
+
+ ! initialize the time offset to put the plane wave not too close to the irregularity on the free surface
+ if (abs(angleforce(1))<1.d0*pi/180.d0 .and. source_type(1)/=3) then
+ time_offset=-1.d0*(zmax-zmin)/2.d0/c_inc
+ else
+ time_offset=0.d0
+ endif
+
+ ! to correctly center the initial plane wave in the mesh
+ x0_source=x_source(1)
+ z0_source=z_source(1)
+
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'You can modify the location of the initial plane wave by changing xs and zs in DATA/Par_File.'
+ write(IOUT,*) ' for instance: xs=',x_source(1),' zs=',z_source(1), ' (zs must be the height of the free surface)'
+ write(IOUT,*)
+ endif
+
+ if (.not. over_critical_angle) then
+
+ do i = 1,npoin
+
+ x = coord(1,i)
+ z = coord(2,i)
+
+ ! z is from bottom to top therefore we take -z to make parallel with Aki & Richards
+ z = z0_source - z
+ x = x - x0_source
+
+ t = 0.d0 + time_offset
+
+ ! formulas for the initial displacement for a plane wave from Aki & Richards (1980)
+ displ_elastic(1,i) = &
+ A_plane(1) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(1) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(1) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+ displ_elastic(3,i) = &
+ A_plane(2) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(2) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(2) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+
+ ! formulas for the initial velocity for a plane wave (first derivative in time of the displacement)
+ veloc_elastic(1,i) = &
+ A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+ veloc_elastic(3,i) = &
+ A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+
+ ! formulas for the initial acceleration for a plane wave (second derivative in time of the displacement)
+ accel_elastic(1,i) = &
+ A_plane(1) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(1) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(1) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+ accel_elastic(3,i) = &
+ A_plane(2) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(2) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(2) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+
+ enddo
+
+ endif
+
+ end subroutine prepare_initialfield
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_initialfield_paco(myrank,nelemabs,left_bound,right_bound,bot_bound, &
+ numabs,codeabs,ibool,nspec, &
+ source_type,NSOURCES,c_inc,c_refl, &
+ count_bottom,count_left,count_right)
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank
+
+ integer :: nelemabs
+ integer :: left_bound(nelemabs*NGLLX)
+ integer :: right_bound(nelemabs*NGLLX)
+ integer :: bot_bound(nelemabs*NGLLZ)
+ integer,dimension(nelemabs) :: numabs
+ logical, dimension(4,nelemabs) :: codeabs
+
+ integer :: nspec
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ integer :: NSOURCES
+ integer :: source_type(NSOURCES)
+
+ double precision :: c_inc,c_refl
+
+ integer :: count_bottom,count_left,count_right
+
+ ! local parameters
+ integer :: ispecabs,ispec,i,j,iglob,ibegin,iend
+
+ if (myrank == 0) then
+ if (source_type(1) /= 3 ) &
+ write(IOUT,*) 'You are beyond the critical angle ( > ',asin(c_inc/c_refl)*180d0/pi,')'
+
+ write(IOUT,*) '*************'
+ write(IOUT,*) 'We have to compute the initial field in the frequency domain'
+ write(IOUT,*) 'and then convert it to the time domain (can be long... be patient...)'
+ write(IOUT,*) '*************'
+ endif
+
+ count_bottom=0
+ count_left=0
+ count_right=0
+ do ispecabs=1,nelemabs
+ ispec=numabs(ispecabs)
+ if(codeabs(ILEFT,ispecabs)) then
+ i = 1
+ do j = 1,NGLLZ
+ count_left=count_left+1
+ iglob = ibool(i,j,ispec)
+ left_bound(count_left)=iglob
+ enddo
+ endif
+ if(codeabs(IRIGHT,ispecabs)) then
+ i = NGLLX
+ do j = 1,NGLLZ
+ count_right=count_right+1
+ iglob = ibool(i,j,ispec)
+ right_bound(count_right)=iglob
+ enddo
+ endif
+ if(codeabs(IBOTTOM,ispecabs)) then
+ j = 1
+ ! exclude corners to make sure there is no contradiction regarding the normal
+ ibegin = 1
+ iend = NGLLX
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+ do i = ibegin,iend
+ count_bottom=count_bottom+1
+ iglob = ibool(i,j,ispec)
+ bot_bound(count_bottom)=iglob
+ enddo
+ endif
+ enddo
+
+ end subroutine prepare_initialfield_paco
+
Copied: seismo/2D/SPECFEM2D/trunk/src/prepare_source_time_function.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/prepare_source_time_function.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/prepare_source_time_function.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/prepare_source_time_function.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,160 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine prepare_source_time_function(myrank,NSTEP,NSOURCES,source_time_function, &
+ time_function_type,f0,tshift_src,factor,aval, &
+ t0,nb_proc_source,deltat)
+
+! prepares source_time_function array
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank,NSTEP
+
+ integer :: NSOURCES
+ integer, dimension(NSOURCES) :: time_function_type
+ double precision, dimension(NSOURCES) :: f0,tshift_src,factor
+ double precision, dimension(NSOURCES) :: aval
+ double precision :: t0
+ integer,dimension(NSOURCES) :: nb_proc_source
+ double precision :: deltat
+
+ real(kind=CUSTOM_REAL),dimension(NSOURCES,NSTEP) :: source_time_function
+
+ ! local parameters
+ double precision :: stf_used,time
+ double precision, dimension(NSOURCES) :: hdur,hdur_gauss
+ double precision, external :: netlib_specfun_erf
+ integer :: it,i_source
+
+
+ ! user output
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving the source time function in a text file...'
+ write(IOUT,*)
+ open(unit=55,file='OUTPUT_FILES/source.txt',status='unknown')
+ endif
+
+ ! ! loop on all the sources
+ ! do i_source=1,NSOURCES
+
+ ! loop on all the time steps
+ do it = 1,NSTEP
+
+ ! note: t0 is the simulation start time, tshift_src is the time shift of the source
+ ! relative to this start time
+
+ ! compute current time
+ time = (it-1)*deltat
+
+ stf_used = 0.d0
+
+ ! loop on all the sources
+ do i_source=1,NSOURCES
+
+ if( time_function_type(i_source) == 1 ) then
+
+ ! Ricker (second derivative of a Gaussian) source time function
+ source_time_function(i_source,it) = - factor(i_source) * &
+ (ONE-TWO*aval(i_source)*(time-t0-tshift_src(i_source))**2) * &
+ exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
+
+ ! source_time_function(i_source,it) = - factor(i_source) * &
+ ! TWO*aval(i_source)*sqrt(aval(i_source))*&
+ ! (time-t0-tshift_src(i_source))/pi * exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
+
+ else if( time_function_type(i_source) == 2 ) then
+
+ ! first derivative of a Gaussian source time function
+ source_time_function(i_source,it) = - factor(i_source) * &
+ TWO*aval(i_source)*(time-t0-tshift_src(i_source)) * &
+ exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
+
+ else if(time_function_type(i_source) == 3 .or. time_function_type(i_source) == 4) then
+
+ ! Gaussian or Dirac (we use a very thin Gaussian instead) source time function
+ source_time_function(i_source,it) = factor(i_source) * &
+ exp(-aval(i_source)*(time-t0-tshift_src(i_source))**2)
+
+ else if(time_function_type(i_source) == 5) then
+
+ ! Heaviside source time function (we use a very thin error function instead)
+ hdur(i_source) = 1.d0 / f0(i_source)
+ hdur_gauss(i_source) = hdur(i_source) * 5.d0 / 3.d0
+ source_time_function(i_source,it) = factor(i_source) * 0.5d0*(1.0d0 + &
+ netlib_specfun_erf(SOURCE_DECAY_MIMIC_TRIANGLE*(time-t0-tshift_src(i_source))/hdur_gauss(i_source)))
+
+ else
+ call exit_MPI('unknown source time function')
+ endif
+
+ stf_used = stf_used + source_time_function(i_source,it)
+
+ enddo
+
+ ! output relative time in third column, in case user wants to check it as well
+ ! if (myrank == 0 .and. i_source==1 ) write(55,*) sngl(time-t0-tshift_src(1)),real(source_time_function(1,it),4),sngl(time)
+ if (myrank == 0) then
+ ! note: earliest start time of the simulation is: (it-1)*deltat - t0
+ write(55,*) sngl(time-t0),sngl(stf_used),sngl(time)
+ endif
+
+ !enddo
+ enddo
+
+ if (myrank == 0) close(55)
+
+ ! nb_proc_source is the number of processes that own the source (the nearest point). It can be greater
+ ! than one if the nearest point is on the interface between several partitions with an explosive source.
+ ! since source contribution is linear, the source_time_function is cut down by that number (it would have been similar
+ ! if we just had elected one of those processes).
+ do i_source=1,NSOURCES
+ source_time_function(i_source,:) = source_time_function(i_source,:) / nb_proc_source(i_source)
+ enddo
+
+ end subroutine prepare_source_time_function
Copied: seismo/2D/SPECFEM2D/trunk/src/read_databases.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/read_databases.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_databases.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/read_databases.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,836 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine read_databases_init(myrank,ipass, &
+ simulation_title,SIMULATION_TYPE,SAVE_FORWARD,npgeo, &
+ gnuplot,interpol,NTSTEP_BETWEEN_OUTPUT_INFO, &
+ output_postscript_snapshot,output_color_image,colors,numbers, &
+ meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows, &
+ anglerec,initialfield,add_Bielak_conditions, &
+ seismotype,imagetype,assign_external_model,READ_EXTERNAL_SEP_FILE, &
+ outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON, &
+ TURN_VISCATTENUATION_ON,Q0,freq0,p_sv, &
+ NSTEP,deltat,NTSTEP_BETWEEN_OUTPUT_SEISMO,NSOURCES)
+
+! starts reading in parameters from input Database file
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank,ipass
+ character(len=60) simulation_title
+ integer :: SIMULATION_TYPE,npgeo
+ integer :: colors,numbers,subsamp,seismotype,imagetype
+ logical :: SAVE_FORWARD,gnuplot,interpol,output_postscript_snapshot, &
+ output_color_image
+ logical :: meshvect,modelvect,boundvect,initialfield,add_Bielak_conditions, &
+ assign_external_model,READ_EXTERNAL_SEP_FILE, &
+ outputgrid,OUTPUT_ENERGY,p_sv
+ logical :: TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON
+
+ double precision :: cutsnaps,sizemax_arrows,anglerec
+ double precision :: Q0,freq0
+ double precision :: deltat
+
+ integer :: NSTEP,NSOURCES
+ integer :: NTSTEP_BETWEEN_OUTPUT_INFO,NTSTEP_BETWEEN_OUTPUT_SEISMO
+
+ ! local parameters
+ integer :: ier
+ character(len=80) :: datlin
+ character(len=256) :: prname
+
+ ! opens Database file
+ write(prname,230) myrank
+ open(unit=IIN,file=prname,status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI('error opening file OUTPUT/Database***')
+
+ !--- read job title and skip remaining titles of the input file
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a50)") simulation_title
+
+ !---- print the date, time and start-up banner
+ if (myrank == 0 .and. ipass == 1) call datim(simulation_title)
+
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,*) '*********************'
+ write(IOUT,*) '**** ****'
+ write(IOUT,*) '**** SPECFEM2D ****'
+ write(IOUT,*) '**** ****'
+ write(IOUT,*) '*********************'
+ endif
+
+ !---- read parameters from input file
+ read(IIN,"(a80)") datlin
+ read(IIN,*) SIMULATION_TYPE, SAVE_FORWARD
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) npgeo
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) gnuplot,interpol
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) NTSTEP_BETWEEN_OUTPUT_INFO
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) output_postscript_snapshot,output_color_image,colors,numbers
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
+ cutsnaps = cutsnaps / 100.d0
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) anglerec
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) initialfield,add_Bielak_conditions
+ if(add_Bielak_conditions .and. .not. initialfield) &
+ stop 'need to have an initial field to add Bielak plane wave conditions'
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) seismotype,imagetype
+ if(seismotype < 1 .or. seismotype > 6) call exit_MPI('Wrong type for seismogram output')
+ if(imagetype < 1 .or. imagetype > 4) call exit_MPI('Wrong type for snapshots')
+
+ if(SAVE_FORWARD .and. (seismotype /= 1 .and. seismotype /= 6)) then
+ print*, '***** WARNING *****'
+ print*, 'seismotype =',seismotype
+ print*, 'Save forward wavefield => seismogram must be in displacement for (poro)elastic or potential for acoustic'
+ print*, 'Seismotype must be changed to 1 (elastic/poroelastic adjoint source) or 6 (acoustic adjoint source)'
+ stop
+ endif
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) assign_external_model,READ_EXTERNAL_SEP_FILE
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) TURN_VISCATTENUATION_ON,Q0,freq0
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) p_sv
+
+ !---- check parameters read
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,200) npgeo,NDIM
+ write(IOUT,600) NTSTEP_BETWEEN_OUTPUT_INFO,colors,numbers
+ write(IOUT,700) seismotype,anglerec
+ write(IOUT,750) initialfield,add_Bielak_conditions,assign_external_model,&
+ READ_EXTERNAL_SEP_FILE,TURN_ATTENUATION_ON, &
+ outputgrid,OUTPUT_ENERGY
+ write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
+ endif
+
+ !---- read time step
+ read(IIN,"(a80)") datlin
+ read(IIN,*) NSTEP,deltat
+ if (myrank == 0 .and. ipass == 1) write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+
+ if( SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. &
+ (TURN_ATTENUATION_ON .or. TURN_VISCATTENUATION_ON) ) then
+ print*, '*************** WARNING ***************'
+ print*, 'Anisotropy & Attenuation & Viscous damping are not presently implemented for adjoint calculations'
+ stop
+ endif
+
+ NTSTEP_BETWEEN_OUTPUT_SEISMO = min(NSTEP,NTSTEP_BETWEEN_OUTPUT_INFO)
+
+ !---- read source information
+ read(IIN,"(a80)") datlin
+ read(IIN,*) NSOURCES
+
+ ! output formats
+230 format('./OUTPUT_FILES/Database',i5.5)
+
+200 format(//1x,'C o n t r o l',/1x,13('='),//5x,&
+ 'Number of spectral element control nodes. . .(npgeo) =',i8/5x, &
+ 'Number of space dimensions. . . . . . . . . . (NDIM) =',i8)
+
+600 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Display frequency . . . (NTSTEP_BETWEEN_OUTPUT_INFO) = ',i6/ 5x, &
+ 'Color display . . . . . . . . . . . . . . . (colors) = ',i6/ 5x, &
+ ' == 0 black and white display ', / 5x, &
+ ' == 1 color display ', /5x, &
+ 'Numbered mesh . . . . . . . . . . . . . . .(numbers) = ',i6/ 5x, &
+ ' == 0 do not number the mesh ', /5x, &
+ ' == 1 number the mesh ')
+
+700 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Seismograms recording type . . . . . . .(seismotype) = ',i6/5x, &
+ 'Angle for first line of receivers. . . . .(anglerec) = ',f6.2)
+
+750 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Read external initial field. . . . . .(initialfield) = ',l6/5x, &
+ 'Add Bielak conditions . . . .(add_Bielak_conditions) = ',l6/5x, &
+ 'Assign external model . . . .(assign_external_model) = ',l6/5x, &
+ 'Read external SEP file . . .(READ_EXTERNAL_SEP_FILE) = ',l6/5x, &
+ 'Turn attenuation on or off. . .(TURN_ATTENUATION_ON) = ',l6/5x, &
+ 'Save grid in external file or not. . . .(outputgrid) = ',l6/5x, &
+ 'Save a file with total energy or not.(OUTPUT_ENERGY) = ',l6)
+
+800 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Vector display type . . . . . . . . . . .(imagetype) = ',i6/5x, &
+ 'Percentage of cut for vector plots . . . .(cutsnaps) = ',f6.2/5x, &
+ 'Subsampling for velocity model display. . .(subsamp) = ',i6)
+
+703 format(//' I t e r a t i o n s '/1x,19('='),//5x, &
+ 'Number of time iterations . . . . .(NSTEP) =',i8,/5x, &
+ 'Time step increment. . . . . . . .(deltat) =',1pe15.6,/5x, &
+ 'Total simulation duration . . . . . (ttot) =',1pe15.6)
+
+ end subroutine read_databases_init
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_sources(NSOURCES,source_type,time_function_type, &
+ x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce)
+
+! reads source parameters
+
+ implicit none
+ include "constants.h"
+
+ integer :: NSOURCES
+ integer, dimension(NSOURCES) :: source_type,time_function_type
+ double precision, dimension(NSOURCES) :: x_source,z_source, &
+ Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
+
+ ! local parameters
+ integer :: i_source
+ character(len=80) :: datlin
+
+ ! initializes
+ source_type(:) = 0
+ time_function_type(:) = 0
+ x_source(:) = 0.d0
+ z_source(:) = 0.d0
+ Mxx(:) = 0.d0
+ Mzz(:) = 0.d0
+ Mxz(:) = 0.d0
+ f0(:) = 0.d0
+ tshift_src(:) = 0.d0
+ factor(:) = 0.d0
+ angleforce(:) = 0.d0
+
+ ! reads in source info from Database file
+ do i_source=1,NSOURCES
+ read(IIN,"(a80)") datlin
+ read(IIN,*) source_type(i_source),time_function_type(i_source), &
+ x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
+ factor(i_source),angleforce(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
+ enddo
+
+ end subroutine read_databases_sources
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_atten(N_SLS,f0_attenuation)
+
+! reads attenuation information
+
+ implicit none
+ include "constants.h"
+
+ integer :: N_SLS
+ double precision :: f0_attenuation
+
+ ! local parameters
+ character(len=80) :: datlin
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) N_SLS, f0_attenuation
+
+ end subroutine read_databases_atten
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_coorg_elem(myrank,ipass,npgeo,coorg,numat,ngnod,nspec, &
+ pointsdisp,plot_lowerleft_corner_only, &
+ nelemabs,nelem_acoustic_surface, &
+ num_fluid_solid_edges,num_fluid_poro_edges, &
+ num_solid_poro_edges,nnodes_tangential_curve)
+
+! reads the spectral macrobloc nodal coordinates
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank,ipass,npgeo
+ double precision, dimension(NDIM,npgeo) :: coorg
+
+ integer :: numat,ngnod,nspec
+ integer :: pointsdisp
+ logical :: plot_lowerleft_corner_only
+ integer :: nelemabs,nelem_acoustic_surface, &
+ num_fluid_solid_edges,num_fluid_poro_edges, &
+ num_solid_poro_edges,nnodes_tangential_curve
+
+ ! local parameters
+ integer :: ipoin,ip,id
+ double precision, dimension(:), allocatable :: coorgread
+ character(len=80) :: datlin
+
+ ! initializes
+ coorg(:,:) = 0.d0
+
+ ! reads the spectral macrobloc nodal coordinates
+ read(IIN,"(a80)") datlin
+
+ ! reads in values
+ ipoin = 0
+ allocate(coorgread(NDIM))
+ do ip = 1,npgeo
+ ! reads coordinates
+ read(IIN,*) ipoin,(coorgread(id),id =1,NDIM)
+
+ if(ipoin<1 .or. ipoin>npgeo) call exit_MPI('Wrong control point number')
+
+ ! saves coordinate array
+ coorg(:,ipoin) = coorgread
+
+ enddo
+ deallocate(coorgread)
+
+ !---- read the basic properties of the spectral elements
+ read(IIN,"(a80)") datlin
+ read(IIN,*) numat,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
+
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,*) nelemabs,nelem_acoustic_surface,num_fluid_solid_edges,num_fluid_poro_edges,&
+ num_solid_poro_edges,nnodes_tangential_curve
+
+ !---- print element group main parameters
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,107)
+ write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
+ endif
+
+ ! output formats
+107 format(/5x,'--> Isoparametric Spectral Elements <--',//)
+
+207 format(5x,'Number of spectral elements . . . . . (nspec) =',i7,/5x, &
+ 'Number of control nodes per element . (ngnod) =',i7,/5x, &
+ 'Number of points in X-direction . . . (NGLLX) =',i7,/5x, &
+ 'Number of points in Y-direction . . . (NGLLZ) =',i7,/5x, &
+ 'Number of points per element. . .(NGLLX*NGLLZ) =',i7,/5x, &
+ 'Number of points for display . . .(pointsdisp) =',i7,/5x, &
+ 'Number of element material sets . . . (numat) =',i7,/5x, &
+ 'Number of absorbing elements . . . .(nelemabs) =',i7)
+
+ end subroutine read_databases_coorg_elem
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_mato(ipass,nspec,ngnod,kmato,knods, &
+ perm,antecedent_list)
+
+! reads spectral macrobloc data
+
+ implicit none
+ include "constants.h"
+
+ integer :: ipass,ngnod,nspec
+ integer, dimension(nspec) :: kmato
+ integer, dimension(ngnod,nspec) :: knods
+
+ integer, dimension(nspec) :: perm,antecedent_list
+
+ ! local parameters
+ integer :: n,k,ispec,kmato_read
+ integer, dimension(:), allocatable :: knods_read
+ character(len=80) :: datlin
+
+ ! initializes
+ kmato(:) = 0
+ knods(:,:) = 0
+
+ ! reads spectral macrobloc data
+ read(IIN,"(a80)") datlin
+
+ ! reads in values
+ allocate(knods_read(ngnod))
+ n = 0
+ do ispec = 1,nspec
+ ! format: #element_id #material_id #node_id1 #node_id2 #...
+ read(IIN,*) n,kmato_read,(knods_read(k), k=1,ngnod)
+ if(ipass == 1) then
+ ! material association
+ kmato(n) = kmato_read
+ ! element control node indices
+ knods(:,n)= knods_read(:)
+ else if(ipass == 2) then
+ kmato(perm(antecedent_list(n))) = kmato_read
+ knods(:,perm(antecedent_list(n)))= knods_read(:)
+ else
+ call exit_MPI('error: maximum is 2 passes')
+ endif
+ enddo
+ deallocate(knods_read)
+
+
+ end subroutine read_databases_mato
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_ninterface(ninterface,max_interface_size)
+
+! reads in interface dimensions
+
+ implicit none
+ include "constants.h"
+
+ integer :: ninterface,max_interface_size
+
+ ! local parameters
+ character(len=80) :: datlin
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) ninterface, max_interface_size
+
+ end subroutine read_databases_ninterface
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_interfaces(ipass,ninterface,nspec,max_interface_size, &
+ my_neighbours,my_nelmnts_neighbours,my_interfaces, &
+ perm,antecedent_list)
+
+! reads in interfaces
+
+ implicit none
+ include "constants.h"
+
+ integer :: ipass,nspec
+ integer :: ninterface,max_interface_size
+ integer, dimension(ninterface) :: my_neighbours,my_nelmnts_neighbours
+ integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
+
+ integer, dimension(nspec) :: perm,antecedent_list
+
+ ! local parameters
+ integer :: num_interface,ie,my_interfaces_read
+
+ ! initializes
+ my_neighbours(:) = -1
+ my_nelmnts_neighbours(:) = 0
+ my_interfaces(:,:,:) = -1
+
+ ! reads in interfaces
+ do num_interface = 1, ninterface
+ ! format: #process_interface_id #number_of_elements_on_interface
+ ! where
+ ! process_interface_id = rank of (neighbor) process to share MPI interface with
+ ! number_of_elements_on_interface = number of interface elements
+ read(IIN,*) my_neighbours(num_interface), my_nelmnts_neighbours(num_interface)
+
+ ! loops over interface elements
+ do ie = 1, my_nelmnts_neighbours(num_interface)
+ ! format: #(1)spectral_element_id #(2)interface_type #(3)node_id1 #(4)node_id2
+ !
+ ! interface types:
+ ! 1 - corner point only
+ ! 2 - element edge
+ read(IIN,*) my_interfaces_read, my_interfaces(2,ie,num_interface), &
+ my_interfaces(3,ie,num_interface), my_interfaces(4,ie,num_interface)
+
+ if(ipass == 1) then
+ my_interfaces(1,ie,num_interface) = my_interfaces_read
+ else if(ipass == 2) then
+ my_interfaces(1,ie,num_interface) = perm(antecedent_list(my_interfaces_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+
+ enddo
+ enddo
+
+ end subroutine read_databases_interfaces
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_absorbing(myrank,ipass,nelemabs,nspec,anyabs, &
+ ibegin_bottom,iend_bottom,jbegin_right,jend_right, &
+ ibegin_top,iend_top,jbegin_left,jend_left, &
+ numabs,codeabs,perm,antecedent_list, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ ib_right,ib_left,ib_bottom,ib_top)
+
+! reads in absorbing edges
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank,ipass,nspec
+ integer :: nelemabs
+ integer, dimension(nelemabs) :: numabs,ibegin_bottom,iend_bottom, &
+ ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
+ logical, dimension(4,nelemabs) :: codeabs
+ logical :: anyabs
+ integer, dimension(nspec) :: perm,antecedent_list
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+
+ integer, dimension(nelemabs) :: ib_right,ib_left,ib_bottom,ib_top
+
+ ! local parameters
+ integer :: inum,numabsread
+ logical :: codeabsread(4)
+ character(len=80) :: datlin
+
+ ! initializes
+ codeabs(:,:) = .false.
+
+ ibegin_bottom(:) = 0
+ iend_bottom(:) = 0
+ ibegin_top(:) = 0
+ iend_top(:) = 0
+
+ jbegin_left(:) = 0
+ jend_left(:) = 0
+ jbegin_right(:) = 0
+ jend_right(:) = 0
+
+ nspec_xmin = 0
+ nspec_xmax = 0
+ nspec_zmin = 0
+ nspec_zmax = 0
+
+ ib_right(:) = 0
+ ib_left(:) = 0
+ ib_bottom(:) = 0
+ ib_top(:) = 0
+
+ ! reads in absorbing edges
+ read(IIN,"(a80)") datlin
+
+ ! reads in values
+ if( anyabs ) then
+ ! reads absorbing boundaries
+ do inum = 1,nelemabs
+ read(IIN,*) numabsread,codeabsread(1),codeabsread(2),codeabsread(3),&
+ codeabsread(4), ibegin_bottom(inum), iend_bottom(inum), &
+ jbegin_right(inum), jend_right(inum), ibegin_top(inum), &
+ iend_top(inum), jbegin_left(inum), jend_left(inum)
+
+ if(numabsread < 1 .or. numabsread > nspec) &
+ call exit_MPI('Wrong absorbing element number')
+
+ if(ipass == 1) then
+ numabs(inum) = numabsread
+ else if(ipass == 2) then
+ numabs(inum) = perm(antecedent_list(numabsread))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+
+ codeabs(IBOTTOM,inum) = codeabsread(1)
+ codeabs(IRIGHT,inum) = codeabsread(2)
+ codeabs(ITOP,inum) = codeabsread(3)
+ codeabs(ILEFT,inum) = codeabsread(4)
+ enddo
+
+ ! boundary element numbering
+ do inum = 1,nelemabs
+ if (codeabs(IBOTTOM,inum)) then
+ nspec_zmin = nspec_zmin + 1
+ ib_bottom(inum) = nspec_zmin
+ endif
+ if (codeabs(IRIGHT,inum)) then
+ nspec_xmax = nspec_xmax + 1
+ ib_right(inum) = nspec_xmax
+ endif
+ if (codeabs(ITOP,inum)) then
+ nspec_zmax = nspec_zmax + 1
+ ib_top(inum) = nspec_zmax
+ endif
+ if (codeabs(ILEFT,inum)) then
+ nspec_xmin = nspec_xmin + 1
+ ib_left(inum) = nspec_xmin
+ endif
+ enddo
+
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Number of absorbing elements: ',nelemabs
+ write(IOUT,*) ' nspec_xmin = ',nspec_xmin
+ write(IOUT,*) ' nspec_xmax = ',nspec_xmax
+ write(IOUT,*) ' nspec_zmin = ',nspec_zmin
+ write(IOUT,*) ' nspec_zmax = ',nspec_zmax
+ write(IOUT,*)
+ endif
+
+ endif
+
+ end subroutine read_databases_absorbing
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_free_surf(ipass,nelem_acoustic_surface,nspec, &
+ acoustic_edges,perm,antecedent_list,any_acoustic_edges)
+
+! reads acoustic free surface data
+
+ implicit none
+ include "constants.h"
+
+ integer :: ipass,nspec
+ integer :: nelem_acoustic_surface
+ integer, dimension(4,nelem_acoustic_surface) :: acoustic_edges
+ logical :: any_acoustic_edges
+
+ integer, dimension(nspec) :: perm,antecedent_list
+
+ ! local parameters
+ integer :: inum,acoustic_edges_read
+ character(len=80) :: datlin
+
+ ! initializes
+ acoustic_edges(:,:) = 0
+
+ ! reads in any possible free surface edges
+ read(IIN,"(a80)") datlin
+
+ if( any_acoustic_edges ) then
+ do inum = 1,nelem_acoustic_surface
+ read(IIN,*) acoustic_edges_read, acoustic_edges(2,inum), acoustic_edges(3,inum), &
+ acoustic_edges(4,inum)
+
+ if(ipass == 1) then
+ acoustic_edges(1,inum) = acoustic_edges_read
+ else if(ipass == 2) then
+ acoustic_edges(1,inum) = perm(antecedent_list(acoustic_edges_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+
+ enddo
+
+ endif
+
+ end subroutine read_databases_free_surf
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_coupled(ipass,nspec,num_fluid_solid_edges,any_fluid_solid_edges, &
+ fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec, &
+ num_fluid_poro_edges,any_fluid_poro_edges, &
+ fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec, &
+ num_solid_poro_edges,any_solid_poro_edges, &
+ solid_poro_elastic_ispec,solid_poro_poroelastic_ispec, &
+ perm,antecedent_list)
+
+! reads acoustic elastic coupled edges
+! reads acoustic poroelastic coupled edges
+! reads poroelastic elastic coupled edges
+
+ implicit none
+ include "constants.h"
+
+ integer :: ipass,nspec
+
+ integer :: num_fluid_solid_edges
+ logical :: any_fluid_solid_edges
+ integer, dimension(num_fluid_solid_edges) :: fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec
+
+ integer :: num_fluid_poro_edges
+ logical :: any_fluid_poro_edges
+ integer, dimension(num_fluid_poro_edges) :: fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec
+
+ integer :: num_solid_poro_edges
+ logical :: any_solid_poro_edges
+ integer, dimension(num_solid_poro_edges) :: solid_poro_elastic_ispec,solid_poro_poroelastic_ispec
+
+ integer, dimension(nspec) :: perm,antecedent_list
+
+ ! local parameters
+ integer :: inum
+ integer :: fluid_solid_acoustic_ispec_read,fluid_solid_elastic_ispec_read, &
+ fluid_poro_acoustic_ispec_read,fluid_poro_poro_ispec_read, &
+ solid_poro_poro_ispec_read,solid_poro_elastic_ispec_read
+ character(len=80) :: datlin
+
+ ! initializes
+ fluid_solid_acoustic_ispec(:) = 0
+ fluid_solid_elastic_ispec(:) = 0
+ fluid_poro_acoustic_ispec(:) = 0
+ fluid_poro_poroelastic_ispec(:) = 0
+ solid_poro_elastic_ispec(:) = 0
+ solid_poro_poroelastic_ispec(:) = 0
+
+ ! reads acoustic elastic coupled edges
+ read(IIN,"(a80)") datlin
+
+ if ( any_fluid_solid_edges ) then
+ do inum = 1, num_fluid_solid_edges
+ read(IIN,*) fluid_solid_acoustic_ispec_read,fluid_solid_elastic_ispec_read
+
+ if(ipass == 1) then
+ fluid_solid_acoustic_ispec(inum) = fluid_solid_acoustic_ispec_read
+ fluid_solid_elastic_ispec(inum) = fluid_solid_elastic_ispec_read
+ else if(ipass == 2) then
+ fluid_solid_acoustic_ispec(inum) = perm(antecedent_list(fluid_solid_acoustic_ispec_read))
+ fluid_solid_elastic_ispec(inum) = perm(antecedent_list(fluid_solid_elastic_ispec_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+ enddo
+ endif
+
+ ! reads acoustic poroelastic coupled edges
+ read(IIN,"(a80)") datlin
+
+ if ( any_fluid_poro_edges ) then
+ do inum = 1, num_fluid_poro_edges
+ read(IIN,*) fluid_poro_acoustic_ispec_read,fluid_poro_poro_ispec_read
+
+ if(ipass == 1) then
+ fluid_poro_acoustic_ispec(inum) = fluid_poro_acoustic_ispec_read
+ fluid_poro_poroelastic_ispec(inum) = fluid_poro_poro_ispec_read
+ else if(ipass == 2) then
+ fluid_poro_acoustic_ispec(inum) = perm(antecedent_list(fluid_poro_acoustic_ispec_read))
+ fluid_poro_poroelastic_ispec(inum) = perm(antecedent_list(fluid_poro_poro_ispec_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+ enddo
+ endif
+
+ ! reads poroelastic elastic coupled edges
+ read(IIN,"(a80)") datlin
+
+ if ( any_solid_poro_edges ) then
+ do inum = 1, num_solid_poro_edges
+ read(IIN,*) solid_poro_poro_ispec_read,solid_poro_elastic_ispec_read
+
+ if(ipass == 1) then
+ solid_poro_elastic_ispec(inum) = solid_poro_elastic_ispec_read
+ solid_poro_poroelastic_ispec(inum) = solid_poro_poro_ispec_read
+ else if(ipass == 2) then
+ solid_poro_elastic_ispec(inum) = perm(antecedent_list(solid_poro_elastic_ispec_read))
+ solid_poro_poroelastic_ispec(inum) = perm(antecedent_list(solid_poro_poro_ispec_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+ enddo
+ endif
+
+ end subroutine read_databases_coupled
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_databases_final(nnodes_tangential_curve,nodes_tangential_curve, &
+ force_normal_to_surface,rec_normal_to_surface, &
+ any_tangential_curve )
+
+! reads tangential detection curve
+! and closes Database file
+
+ implicit none
+ include "constants.h"
+
+ integer :: nnodes_tangential_curve
+ logical :: any_tangential_curve
+ double precision, dimension(2,nnodes_tangential_curve) :: nodes_tangential_curve
+
+ logical :: force_normal_to_surface,rec_normal_to_surface
+
+ ! local parameters
+ integer :: i
+ character(len=80) :: datlin
+
+ ! initializes
+ nodes_tangential_curve(:,:) = 0.d0
+
+ ! reads tangential detection curve
+ read(IIN,"(a80)") datlin
+ read(IIN,*) force_normal_to_surface,rec_normal_to_surface
+
+ if( any_tangential_curve ) then
+ do i = 1, nnodes_tangential_curve
+ read(IIN,*) nodes_tangential_curve(1,i),nodes_tangential_curve(2,i)
+ enddo
+ else
+ force_normal_to_surface = .false.
+ rec_normal_to_surface = .false.
+ endif
+
+ ! closes input Database file
+ close(IIN)
+
+ end subroutine read_databases_final
+
+
\ No newline at end of file
Copied: seismo/2D/SPECFEM2D/trunk/src/read_external_model.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/read_external_model.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_external_model.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/read_external_model.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,188 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine read_external_model(any_acoustic,any_elastic,any_poroelastic, &
+ elastic,poroelastic,anisotropic,nspec,npoin,N_SLS,ibool, &
+ f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
+ inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent, &
+ inv_tau_sigma_nu1,inv_tau_sigma_nu2,phi_nu1,phi_nu2,Mu_nu1,Mu_nu2,&
+ coord,kmato,myrank,rhoext,vpext,vsext, &
+ Qp_attenuationext,Qs_attenuationext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,READ_EXTERNAL_SEP_FILE)
+
+ implicit none
+ include "constants.h"
+
+ integer :: nspec,myrank,npoin
+ double precision :: f0_attenuation
+
+ ! Mesh
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ double precision, dimension(NDIM,npoin) :: coord
+
+ ! Material properties
+ logical :: any_acoustic,any_elastic,any_poroelastic,READ_EXTERNAL_SEP_FILE
+ integer, dimension(nspec) :: kmato
+ logical, dimension(nspec) :: elastic,poroelastic
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: rhoext,vpext,vsext
+
+ ! for attenuation
+ integer :: N_SLS
+ double precision :: Mu_nu1_sent,Mu_nu2_sent
+ double precision, dimension(N_SLS) :: inv_tau_sigma_nu1_sent,phi_nu1_sent, &
+ inv_tau_sigma_nu2_sent,phi_nu2_sent
+ double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu1,phi_nu1, &
+ inv_tau_sigma_nu2,phi_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Mu_nu1,Mu_nu2
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: Qp_attenuationext,Qs_attenuationext
+
+ ! for anisotropy
+ logical, dimension(nspec) :: anisotropic
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: c11ext,c13ext,c15ext,c33ext,c35ext,c55ext
+
+ ! Local variables
+ integer :: i,j,ispec,iglob
+ double precision :: previous_vsext
+ double precision :: tmp1, tmp2,tmp3
+
+ if(READ_EXTERNAL_SEP_FILE) then
+ write(IOUT,*)
+ write(IOUT,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+ write(IOUT,*) 'Assigning external velocity and density model (elastic (no attenuation) and/or acoustic)...'
+ write(IOUT,*) 'Read outside SEG model...'
+ write(IOUT,*) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+
+ open(unit=1001,file='DATA/model_velocity.dat_input',status='unknown')
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ read(1001,*) tmp1,tmp2,tmp3,rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec)
+ ! vsext(i,j,ispec)=0.0
+ ! Qp, Qs : dummy values. If attenuation needed than the "read" line and model_velocity.dat_input
+ ! need to be modified to provide Qp & Qs values
+ Qp_attenuationext(i,j,ispec) = 10.d0
+ Qs_attenuationext(i,j,ispec) = 10.d0
+ end do
+ end do
+ end do
+ close(1001)
+
+ else
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+ call define_external_model(coord(1,iglob),coord(2,iglob),kmato(ispec),myrank,&
+ rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec), &
+ Qp_attenuationext(i,j,ispec),Qs_attenuationext(i,j,ispec),&
+ c11ext(i,j,ispec),c13ext(i,j,ispec),c15ext(i,j,ispec), &
+ c33ext(i,j,ispec),c35ext(i,j,ispec),c55ext(i,j,ispec))
+
+ if((c11ext(i,j,ispec) /= 0) .or. (c13ext(i,j,ispec) /= 0) .or. (c15ext(i,j,ispec) /= 0) .or. &
+ (c33ext(i,j,ispec) /= 0) .or. (c35ext(i,j,ispec) /= 0) .or. (c55ext(i,j,ispec) /= 0)) then
+ ! vp, vs : dummy values, trick to avoid floating point errors
+ vpext(i,j,ispec) = 20.d0
+ vsext(i,j,ispec) = 10.d0
+ end if
+ end do
+ end do
+ end do
+ end if
+
+ ! initializes
+ any_acoustic = .false.
+ any_elastic = .false.
+ any_poroelastic = .false.
+
+ anisotropic(:) = .false.
+ elastic(:) = .false.
+ poroelastic(:) = .false.
+
+ do ispec = 1,nspec
+ previous_vsext = -1.d0
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ if(.not. (i == 1 .and. j == 1) .and. &
+ ((vsext(i,j,ispec) >= TINYVAL .and. previous_vsext < TINYVAL) .or. &
+ (vsext(i,j,ispec) < TINYVAL .and. previous_vsext >= TINYVAL))) &
+ call exit_MPI('external velocity model cannot be both fluid and solid inside the same spectral element')
+
+ if((c11ext(i,j,ispec) /= 0) .or. (c13ext(i,j,ispec) /= 0) .or. (c15ext(i,j,ispec) /= 0) .or. &
+ (c33ext(i,j,ispec) /= 0) .or. (c35ext(i,j,ispec) /= 0) .or. (c55ext(i,j,ispec) /= 0)) then
+ anisotropic(ispec) = .true.
+ poroelastic(ispec) = .false.
+ elastic(ispec) = .true.
+ any_elastic = .true.
+ Qp_attenuationext(i,j,ispec) = 10.d0
+ Qs_attenuationext(i,j,ispec) = 10.d0
+ elseif(vsext(i,j,ispec) < TINYVAL) then
+ elastic(ispec) = .false.
+ poroelastic(ispec) = .false.
+ any_acoustic = .true.
+ else
+ poroelastic(ispec) = .false.
+ elastic(ispec) = .true.
+ any_elastic = .true.
+ endif
+
+ call attenuation_model(N_SLS,Qp_attenuationext(i,j,ispec),Qs_attenuationext(i,j,ispec), &
+ f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
+ inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent)
+ inv_tau_sigma_nu1(i,j,ispec,:) = inv_tau_sigma_nu1_sent(:)
+ phi_nu1(i,j,ispec,:) = phi_nu1_sent(:)
+ inv_tau_sigma_nu2(i,j,ispec,:) = inv_tau_sigma_nu2_sent(:)
+ phi_nu2(i,j,ispec,:) = phi_nu2_sent(:)
+ Mu_nu1(i,j,ispec) = Mu_nu1_sent
+ Mu_nu2(i,j,ispec) = Mu_nu2_sent
+ previous_vsext = vsext(i,j,ispec)
+ enddo
+ enddo
+ enddo
+
+ end subroutine read_external_model
Copied: seismo/2D/SPECFEM2D/trunk/src/read_interfaces_file.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/read_interfaces_file.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_interfaces_file.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/read_interfaces_file.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,179 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+module interfaces_file
+
+ ! note: we use this module definition only to be able to allocate
+ ! arrays for receiverlines and materials in this subroutine rather than in the main
+ ! routine in meshfem2D.F90
+
+ ! note 2: the filename ending is .F90 to have pre-compilation with pragmas
+ ! (like #ifndef USE_MPI) working properly
+
+ implicit none
+
+contains
+
+ subroutine read_interfaces_file(interfacesfile,max_npoints_interface, &
+ number_of_interfaces,npoints_interface_bottom, &
+ number_of_layers,nz_layer,nx,nz,nxread,nzread,ngnod, &
+ nelmnts,elmnts)
+ implicit none
+ include "constants.h"
+
+ character(len=100) :: interfacesfile
+
+ integer :: max_npoints_interface,number_of_interfaces,npoints_interface_bottom
+ integer :: number_of_layers,nx,nz,nxread,nzread,ngnod
+ integer :: nelmnts
+ integer, dimension(:), pointer :: nz_layer
+ integer, dimension(:), pointer :: elmnts
+
+ ! local parameters
+ integer :: ios,interface_current,ipoint_current,ilayer,i,j,num_elmnt
+ double precision :: xinterface_dummy,zinterface_dummy,xinterface_dummy_previous
+
+ ! get interface data from external file to count the spectral elements along Z
+ print *,'Reading interface data from file DATA/',interfacesfile(1:len_trim(interfacesfile)),' to count the spectral elements'
+ open(unit=IIN_INTERFACES,file='DATA/'//interfacesfile,status='old',iostat=ios)
+ if( ios /= 0 ) then
+ print*,'error opening file: ',trim('DATA/'//interfacesfile)
+ stop 'error read interface file in meshfem2D'
+ endif
+
+ max_npoints_interface = -1
+
+ ! read number of interfaces
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,number_of_interfaces)
+ if(number_of_interfaces < 2) stop 'not enough interfaces (minimum is 2)'
+
+ ! loop on all the interfaces
+ do interface_current = 1,number_of_interfaces
+
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_bottom)
+ if(npoints_interface_bottom < 2) stop 'not enough interface points (minimum is 2)'
+ max_npoints_interface = max(npoints_interface_bottom,max_npoints_interface)
+ print *,'Reading ',npoints_interface_bottom,' points for interface ',interface_current
+
+ ! loop on all the points describing this interface
+ xinterface_dummy_previous = -HUGEVAL
+ do ipoint_current = 1,npoints_interface_bottom
+ call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK,xinterface_dummy,zinterface_dummy)
+ if(ipoint_current > 1 .and. xinterface_dummy <= xinterface_dummy_previous) &
+ stop 'interface points must be sorted in increasing X'
+ xinterface_dummy_previous = xinterface_dummy
+ enddo
+ enddo
+
+ ! define number of layers
+ number_of_layers = number_of_interfaces - 1
+
+ allocate(nz_layer(number_of_layers))
+
+ ! loop on all the layers
+ do ilayer = 1,number_of_layers
+
+ ! read number of spectral elements in vertical direction in this layer
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,nz_layer(ilayer))
+ if(nz_layer(ilayer) < 1) stop 'not enough spectral elements along Z in layer (minimum is 1)'
+ print *,'There are ',nz_layer(ilayer),' spectral elements along Z in layer ',ilayer
+
+ enddo
+
+ close(IIN_INTERFACES)
+
+ ! compute total number of spectral elements in vertical direction
+ nz = sum(nz_layer)
+
+ print *
+ print *,'Total number of spectral elements along Z = ',nz
+ print *
+
+ nxread = nx
+ nzread = nz
+
+ ! multiply by 2 if elements have 9 nodes
+ if(ngnod == 9) then
+ nx = nx * 2
+ nz = nz * 2
+ nz_layer(:) = nz_layer(:) * 2
+ endif
+
+ nelmnts = nxread * nzread
+ allocate(elmnts(0:ngnod*nelmnts-1))
+
+ if ( ngnod == 4 ) then
+ num_elmnt = 0
+ do j = 1, nzread
+ do i = 1, nxread
+ elmnts(num_elmnt*ngnod) = (j-1)*(nxread+1) + (i-1)
+ elmnts(num_elmnt*ngnod+1) = (j-1)*(nxread+1) + (i-1) + 1
+ elmnts(num_elmnt*ngnod+2) = j*(nxread+1) + (i-1) + 1
+ elmnts(num_elmnt*ngnod+3) = j*(nxread+1) + (i-1)
+ num_elmnt = num_elmnt + 1
+ enddo
+ enddo
+ else
+ num_elmnt = 0
+ do j = 1, nzread
+ do i = 1, nxread
+ elmnts(num_elmnt*ngnod) = (j-1)*(nxread+1) + (i-1)
+ elmnts(num_elmnt*ngnod+1) = (j-1)*(nxread+1) + (i-1) + 1
+ elmnts(num_elmnt*ngnod+2) = j*(nxread+1) + (i-1) + 1
+ elmnts(num_elmnt*ngnod+3) = j*(nxread+1) + (i-1)
+ elmnts(num_elmnt*ngnod+4) = (nxread+1)*(nzread+1) + (j-1)*nxread + (i-1)
+ elmnts(num_elmnt*ngnod+5) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2 + 2
+ elmnts(num_elmnt*ngnod+6) = (nxread+1)*(nzread+1) + j*nxread + (i-1)
+ elmnts(num_elmnt*ngnod+7) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2
+ elmnts(num_elmnt*ngnod+8) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2 + 1
+ num_elmnt = num_elmnt + 1
+ enddo
+ enddo
+
+ endif
+
+
+ end subroutine read_interfaces_file
+
+end module interfaces_file
Copied: seismo/2D/SPECFEM2D/trunk/src/read_materials.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/read_materials.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_materials.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/read_materials.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,199 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine read_materials(nb_materials,icodemat,cp,cs, &
+ aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
+ Qp,Qs,rho_s,rho_f,phi,tortuosity, &
+ permxx,permxz,permzz,kappa_s,kappa_f,kappa_fr, &
+ eta_f,mu_fr)
+
+! reads in material definitions in DATA/Par_file
+
+ implicit none
+ include "constants.h"
+
+ integer :: nb_materials
+
+ integer, dimension(nb_materials) :: icodemat
+
+ double precision, dimension(nb_materials) :: rho_s,cp,cs, &
+ aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
+ double precision, dimension(nb_materials) :: rho_f,phi,tortuosity,permxx,permxz,&
+ permzz,kappa_s,kappa_f,kappa_fr,eta_f,mu_fr
+
+ ! local parameters
+ integer :: imaterial,i,icodematread
+ double precision :: val0read,val1read,val2read,val3read,val4read, &
+ val5read,val6read,val7read,val8read,val9read,val10read,val11read,val12read
+
+ ! initializes material properties
+ icodemat(:) = 0
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+ aniso3(:) = 0.d0
+ aniso4(:) = 0.d0
+ aniso5(:) = 0.d0
+ aniso6(:) = 0.d0
+ aniso7(:) = 0.d0
+ aniso8(:) = 0.d0
+ Qp(:) = 0.d0
+ Qs(:) = 0.d0
+ rho_s(:) = 0.d0
+ rho_f(:) = 0.d0
+ phi(:) = 0.d0
+ tortuosity(:) = 0.d0
+ permxx(:) = 0.d0
+ permxz(:) = 0.d0
+ permzz(:) = 0.d0
+ kappa_s(:) = 0.d0
+ kappa_f(:) = 0.d0
+ kappa_fr(:) = 0.d0
+ eta_f(:) = 0.d0
+ mu_fr(:) = 0.d0
+
+ ! reads in material parameters
+ do imaterial=1,nb_materials
+ call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread, &
+ val0read,val1read,val2read,val3read, &
+ val4read,val5read,val6read,val7read, &
+ val8read,val9read,val10read,val11read,val12read)
+
+ ! checks material id
+ if(i < 1 .or. i > nb_materials) stop 'Wrong material number!'
+ icodemat(i) = icodematread
+
+
+ ! sets material properties
+ if(icodemat(i) == ISOTROPIC_MATERIAL) then
+
+ ! isotropic materials
+
+ rho_s(i) = val0read
+ cp(i) = val1read
+ cs(i) = val2read
+ Qp(i) = val5read
+ Qs(i) = val6read
+
+ if(rho_s(i) <= 0.d0 .or. cp(i) <= 0.d0 .or. cs(i) < 0.d0) stop 'negative value of velocity or density'
+ if(Qp(i) <= 0.d0 .or. Qs(i) <= 0.d0) stop 'negative value of Qp or Qs'
+
+ aniso3(i) = val3read
+ aniso4(i) = val4read
+ if(cs(i) /= 0.d0) then
+ phi(i) = 0.d0 ! elastic
+ else
+ phi(i) = 1.d0 ! acoustic
+ endif
+ elseif (icodemat(i) == ANISOTROPIC_MATERIAL) then
+
+ ! anisotropic materials
+
+ rho_s(i) = val0read
+ cp(i) = val1read
+ cs(i) = val2read
+ aniso3(i) = val3read
+ aniso4(i) = val4read
+ aniso5(i) = val5read
+ aniso6(i) = val6read
+ aniso7(i) = val7read
+ aniso8(i) = val8read
+ Qp(i) = val9read
+ Qs(i) = val10read
+ else
+
+ ! poroelastic materials
+
+ rho_s(i) = val0read
+ rho_f(i) = val1read
+ phi(i) = val2read
+ tortuosity(i) = val3read
+ permxx(i) = val4read
+ permxz(i) = val5read
+ permzz(i) = val6read
+ kappa_s(i) = val7read
+ kappa_f(i) = val8read
+ kappa_fr(i) = val9read
+ eta_f(i) = val10read
+ mu_fr(i) = val11read
+ Qs(i) = val12read
+
+ if(rho_s(i) <= 0.d0 .or. rho_f(i) <= 0.d0) stop 'negative value of density'
+ if(phi(i) <= 0.d0 .or. tortuosity(i) <= 0.d0) stop 'negative value of porosity or tortuosity'
+ if(kappa_s(i) <= 0.d0 .or. kappa_f(i) <= 0.d0 .or. kappa_fr(i) <= 0.d0 .or. mu_fr(i) <= 0.d0) then
+ stop 'negative value of modulus'
+ end if
+ if(Qs(i) <= 0.d0) stop 'negative value of Qs'
+ endif
+ enddo
+
+ ! user output
+ print *
+ print *, 'Nb of solid, fluid or porous materials = ',nb_materials
+ print *
+ do i=1,nb_materials
+ if(icodemat(i) /= ANISOTROPIC_MATERIAL .and. icodemat(i) /= POROELASTIC_MATERIAL) then
+ print *,'Material #',i,' isotropic'
+ print *,'rho,cp,cs = ',rho_s(i),cp(i),cs(i),Qp(i),Qs(i)
+ if(cs(i) < TINYVAL) then
+ print *,'Material is fluid'
+ else
+ print *,'Material is solid'
+ endif
+ elseif(icodemat(i) == POROELASTIC_MATERIAL) then
+ print *,'Material #',i,' isotropic'
+ print *,'rho_s, kappa_s= ',rho_s(i),kappa_s(i)
+ print *,'rho_f, kappa_f, eta_f= ',rho_f(i),kappa_f(i),eta_f(i)
+ print *,'phi, tortuosity, permxx, permxz, permzz= ',phi(i),tortuosity(i),permxx(i),permxz(i),permzz(i)
+ print *,'kappa_fr, mu_fr, Qs= ',kappa_fr(i),mu_fr(i),Qs(i)
+ print *,'Material is porous'
+ else
+ print *,'Material #',i,' anisotropic'
+ print *,'rho,cp,cs = ',rho_s(i),cp(i),cs(i)
+ print*,'c11,c13,c15,c33,c35,c55 = ',aniso3(i),aniso4(i),aniso5(i),aniso6(i),aniso7(i),aniso8(i)
+ print *,'Qp,Qs = ',Qp(i),Qs(i)
+ endif
+ print *
+ enddo
+
+ end subroutine read_materials
Copied: seismo/2D/SPECFEM2D/trunk/src/read_parameter_file.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/read_parameter_file.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_parameter_file.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/read_parameter_file.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,327 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+module parameter_file
+
+ ! note: we use this module definition only to be able to allocate
+ ! arrays for receiverlines and materials in this subroutine rather than in the main
+ ! routine in meshfem2D.F90
+
+ ! note 2: the filename ending is .F90 to have pre-compilation with pragmas
+ ! (like #ifndef USE_MPI) working properly
+
+ implicit none
+ character(len=100) :: interfacesfile,title
+
+ integer :: SIMULATION_TYPE
+ logical :: SAVE_FORWARD,read_external_mesh
+
+ character(len=256) :: mesh_file, nodes_coords_file, materials_file, &
+ free_surface_file, absorbing_surface_file
+ character(len=256) :: tangential_detection_curve_file
+
+ ! variables used for partitioning
+ integer :: nproc,partitioning_method
+
+ double precision :: xmin,xmax
+ integer :: nx,ngnod
+
+ logical :: initialfield,add_Bielak_conditions,assign_external_model, &
+ READ_EXTERNAL_SEP_FILE,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON
+
+ double precision :: Q0,freq0
+
+ logical :: p_sv
+ logical :: any_abs,absbottom,absright,abstop,absleft
+
+ integer :: nt
+ double precision :: deltat
+
+ integer :: NSOURCES
+ logical :: force_normal_to_surface
+
+ ! variables used for attenuation
+ integer :: N_SLS
+ double precision :: f0_attenuation
+
+ integer :: seismotype
+ logical :: generate_STATIONS
+
+ integer :: nreceiverlines
+ double precision :: anglerec
+ logical :: rec_normal_to_surface
+
+ integer, dimension(:), pointer :: nrec
+ double precision, dimension(:), pointer :: xdeb,zdeb,xfin,zfin
+ logical, dimension(:), pointer :: enreg_surf_same_vertical
+
+ integer :: NTSTEP_BETWEEN_OUTPUT_INFO
+ logical :: output_postscript_snapshot,output_color_image
+ integer :: imagetype
+ double precision :: cutsnaps
+ logical :: meshvect,modelvect,boundvect,interpol
+ integer :: pointsdisp,subsamp
+ double precision :: sizemax_arrows
+ logical :: gnuplot,outputgrid,OUTPUT_ENERGY
+ logical :: plot_lowerleft_corner_only
+
+ ! to store density and velocity model
+ integer :: nb_materials
+ integer, dimension(:),pointer :: icodemat
+ double precision, dimension(:),pointer :: rho_s,cp,cs, &
+ aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
+ double precision, dimension(:),pointer :: rho_f,phi,tortuosity,permxx,permxz,&
+ permzz,kappa_s,kappa_f,kappa_fr,eta_f,mu_fr
+
+contains
+
+ subroutine read_parameter_file()
+
+! reads in DATA/Par_file
+
+ implicit none
+ include "constants.h"
+
+ ! local parameters
+ integer :: ios,ireceiverlines
+
+ ! read file names and path for output
+ call read_value_string(IIN,IGNORE_JUNK,title)
+ call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
+
+ write(*,*) 'Title of the simulation'
+ write(*,*) title
+ print *
+
+ ! read type of simulation
+ call read_value_integer(IIN,IGNORE_JUNK,SIMULATION_TYPE)
+ call read_value_logical(IIN,IGNORE_JUNK,SAVE_FORWARD)
+
+ ! read info about external mesh
+ call read_value_logical(IIN,IGNORE_JUNK,read_external_mesh)
+ call read_value_string(IIN,IGNORE_JUNK,mesh_file)
+ call read_value_string(IIN,IGNORE_JUNK,nodes_coords_file)
+ call read_value_string(IIN,IGNORE_JUNK,materials_file)
+ call read_value_string(IIN,IGNORE_JUNK,free_surface_file)
+ call read_value_string(IIN,IGNORE_JUNK,absorbing_surface_file)
+ call read_value_string(IIN,IGNORE_JUNK,tangential_detection_curve_file)
+
+ ! read info about partitioning
+ call read_value_integer(IIN,IGNORE_JUNK,nproc)
+ call read_value_integer(IIN,IGNORE_JUNK,partitioning_method)
+
+ ! read grid parameters
+ call read_value_double_precision(IIN,IGNORE_JUNK,xmin)
+ call read_value_double_precision(IIN,IGNORE_JUNK,xmax)
+ call read_value_integer(IIN,IGNORE_JUNK,nx)
+ call read_value_integer(IIN,IGNORE_JUNK,ngnod)
+ call read_value_logical(IIN,IGNORE_JUNK,initialfield)
+ call read_value_logical(IIN,IGNORE_JUNK,add_Bielak_conditions)
+ call read_value_logical(IIN,IGNORE_JUNK,assign_external_model)
+ call read_value_logical(IIN,IGNORE_JUNK,READ_EXTERNAL_SEP_FILE)
+ call read_value_logical(IIN,IGNORE_JUNK,TURN_ATTENUATION_ON)
+ ! read viscous attenuation parameters (poroelastic media)
+ call read_value_logical(IIN,IGNORE_JUNK,TURN_VISCATTENUATION_ON)
+ call read_value_double_precision(IIN,IGNORE_JUNK,Q0)
+ call read_value_double_precision(IIN,IGNORE_JUNK,freq0)
+ ! determine if body or surface (membrane) waves calculation
+ call read_value_logical(IIN,IGNORE_JUNK,p_sv)
+
+ ! read absorbing boundaries parameters
+ call read_value_logical(IIN,IGNORE_JUNK,any_abs)
+ call read_value_logical(IIN,IGNORE_JUNK,absbottom)
+ call read_value_logical(IIN,IGNORE_JUNK,absright)
+ call read_value_logical(IIN,IGNORE_JUNK,abstop)
+ call read_value_logical(IIN,IGNORE_JUNK,absleft)
+
+ ! read time step parameters
+ call read_value_integer(IIN,IGNORE_JUNK,nt)
+ call read_value_double_precision(IIN,IGNORE_JUNK,deltat)
+
+ ! read source infos
+ call read_value_integer(IIN,IGNORE_JUNK,NSOURCES)
+ call read_value_logical(IIN,IGNORE_JUNK,force_normal_to_surface)
+
+ ! read constants for attenuation
+ call read_value_integer(IIN,IGNORE_JUNK,N_SLS)
+ call read_value_double_precision(IIN,IGNORE_JUNK,f0_attenuation)
+
+ ! read receiver line parameters
+ call read_value_integer(IIN,IGNORE_JUNK,seismotype)
+ call read_value_logical(IIN,IGNORE_JUNK,generate_STATIONS)
+ call read_value_integer(IIN,IGNORE_JUNK,nreceiverlines)
+ call read_value_double_precision(IIN,IGNORE_JUNK,anglerec)
+ call read_value_logical(IIN,IGNORE_JUNK,rec_normal_to_surface)
+
+ if(nreceiverlines < 1) stop 'number of receiver lines must be greater than 1'
+
+ ! allocate receiver line arrays
+ allocate(nrec(nreceiverlines))
+ allocate(xdeb(nreceiverlines))
+ allocate(zdeb(nreceiverlines))
+ allocate(xfin(nreceiverlines))
+ allocate(zfin(nreceiverlines))
+ allocate(enreg_surf_same_vertical(nreceiverlines),stat=ios)
+ if( ios /= 0 ) stop 'error allocating receiver lines'
+
+ ! loop on all the receiver lines
+ do ireceiverlines = 1,nreceiverlines
+ call read_value_integer(IIN,IGNORE_JUNK,nrec(ireceiverlines))
+ call read_value_double_precision(IIN,IGNORE_JUNK,xdeb(ireceiverlines))
+ call read_value_double_precision(IIN,IGNORE_JUNK,zdeb(ireceiverlines))
+ call read_value_double_precision(IIN,IGNORE_JUNK,xfin(ireceiverlines))
+ call read_value_double_precision(IIN,IGNORE_JUNK,zfin(ireceiverlines))
+ call read_value_logical(IIN,IGNORE_JUNK,enreg_surf_same_vertical(ireceiverlines))
+ if (read_external_mesh .and. enreg_surf_same_vertical(ireceiverlines)) then
+ stop 'Cannot use enreg_surf_same_vertical with external meshes!'
+ endif
+ enddo
+
+ ! read display parameters
+ call read_value_integer(IIN,IGNORE_JUNK,NTSTEP_BETWEEN_OUTPUT_INFO)
+ call read_value_logical(IIN,IGNORE_JUNK,output_postscript_snapshot)
+ call read_value_logical(IIN,IGNORE_JUNK,output_color_image)
+ call read_value_integer(IIN,IGNORE_JUNK,imagetype)
+ call read_value_double_precision(IIN,IGNORE_JUNK,cutsnaps)
+ call read_value_logical(IIN,IGNORE_JUNK,meshvect)
+ call read_value_logical(IIN,IGNORE_JUNK,modelvect)
+ call read_value_logical(IIN,IGNORE_JUNK,boundvect)
+ call read_value_logical(IIN,IGNORE_JUNK,interpol)
+ call read_value_integer(IIN,IGNORE_JUNK,pointsdisp)
+ call read_value_integer(IIN,IGNORE_JUNK,subsamp)
+ call read_value_double_precision(IIN,IGNORE_JUNK,sizemax_arrows)
+ call read_value_logical(IIN,IGNORE_JUNK,gnuplot)
+ call read_value_logical(IIN,IGNORE_JUNK,outputgrid)
+ call read_value_logical(IIN,IGNORE_JUNK,OUTPUT_ENERGY)
+
+
+ ! read the different material materials
+ call read_value_integer(IIN,IGNORE_JUNK,nb_materials)
+ if(nb_materials <= 0) stop 'Negative number of materials not allowed!'
+
+ allocate(icodemat(nb_materials))
+ allocate(cp(nb_materials))
+ allocate(cs(nb_materials))
+ allocate(aniso3(nb_materials))
+ allocate(aniso4(nb_materials))
+ allocate(aniso5(nb_materials))
+ allocate(aniso6(nb_materials))
+ allocate(aniso7(nb_materials))
+ allocate(aniso8(nb_materials))
+ allocate(Qp(nb_materials))
+ allocate(Qs(nb_materials))
+ allocate(rho_s(nb_materials))
+ allocate(rho_f(nb_materials))
+ allocate(phi(nb_materials))
+ allocate(tortuosity(nb_materials))
+ allocate(permxx(nb_materials))
+ allocate(permxz(nb_materials))
+ allocate(permzz(nb_materials))
+ allocate(kappa_s(nb_materials))
+ allocate(kappa_f(nb_materials))
+ allocate(kappa_fr(nb_materials))
+ allocate(eta_f(nb_materials))
+ allocate(mu_fr(nb_materials))
+
+ call read_materials(nb_materials,icodemat,cp,cs, &
+ aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
+ Qp,Qs,rho_s,rho_f,phi,tortuosity, &
+ permxx,permxz,permzz,kappa_s,kappa_f,kappa_fr, &
+ eta_f,mu_fr)
+
+
+ ! checks input parameters
+ call check_parameters()
+
+ end subroutine read_parameter_file
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine check_parameters()
+
+ implicit none
+
+ ! checks partitioning
+ if ( nproc <= 0 ) then
+ print *, 'Number of processes (nproc) must be greater than or equal to one.'
+ stop
+ endif
+
+#ifndef USE_MPI
+ if ( nproc > 1 ) then
+ print *, 'Number of processes (nproc) must be equal to one when not using MPI.'
+ print *, 'Please recompile with -DUSE_MPI in order to enable use of MPI.'
+ stop
+ endif
+#endif
+
+ if(partitioning_method /= 1 .and. partitioning_method /= 3) then
+ print *, 'Invalid partitioning method number.'
+ print *, 'Partitioning method ',partitioning_method,' was requested, but is not available.'
+ print *, 'Support for the METIS graph partitioner has been discontinued, please use SCOTCH (option 3) instead.'
+ stop
+ endif
+
+ ! checks absorbing boundaries
+ if ( .not. any_abs ) then
+ absbottom = .false.
+ absright = .false.
+ abstop = .false.
+ absleft = .false.
+ endif
+
+ ! can use only one point to display lower-left corner only for interpolated snapshot
+ if(pointsdisp < 3) then
+ pointsdisp = 3
+ plot_lowerleft_corner_only = .true.
+ else
+ plot_lowerleft_corner_only = .false.
+ endif
+
+ end subroutine check_parameters
+
+end module parameter_file
+
Copied: seismo/2D/SPECFEM2D/trunk/src/read_regions.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/read_regions.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_regions.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/read_regions.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,145 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine read_regions(nbregion,nb_materials,icodemat,cp,cs, &
+ rho_s,Qp,Qs,aniso3,aniso4,aniso5,aniso6,aniso7,aniso8, &
+ nelmnts,num_material,nxread,nzread)
+
+! reads in material definitions in DATA/Par_file
+
+ implicit none
+ include "constants.h"
+
+ integer :: nbregion,nb_materials
+ integer, dimension(nb_materials) :: icodemat
+ double precision, dimension(nb_materials) :: rho_s,cp,cs, &
+ aniso3,aniso4,aniso5,aniso6,aniso7,aniso8,Qp,Qs
+
+ integer :: nelmnts
+ integer,dimension(nelmnts) :: num_material
+ integer :: nxread,nzread
+
+ ! local parameters
+ integer :: iregion,ixdebregion,ixfinregion,izdebregion,izfinregion,imaterial_number
+ integer :: i,j
+ double precision :: vpregion,vsregion,poisson_ratio
+
+ ! read the material numbers for each region
+ call read_value_integer(IIN,IGNORE_JUNK,nbregion)
+
+ if(nbregion <= 0) stop 'Negative number of regions not allowed!'
+
+ print *
+ print *, 'Nb of regions in the mesh = ',nbregion
+ print *
+
+ do iregion = 1,nbregion
+
+ call read_region_coordinates(IIN,DONT_IGNORE_JUNK,ixdebregion,ixfinregion, &
+ izdebregion,izfinregion,imaterial_number)
+
+ if(imaterial_number < 1) stop 'Negative material number not allowed!'
+ if(ixdebregion < 1) stop 'Left coordinate of region negative!'
+ if(ixfinregion > nxread) stop 'Right coordinate of region too high!'
+ if(izdebregion < 1) stop 'Bottom coordinate of region negative!'
+ if(izfinregion > nzread) stop 'Top coordinate of region too high!'
+
+ print *,'Region ',iregion
+ print *,'IX from ',ixdebregion,' to ',ixfinregion
+ print *,'IZ from ',izdebregion,' to ',izfinregion
+
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. icodemat(imaterial_number) /= POROELASTIC_MATERIAL) then
+
+ ! isotropic material
+ vpregion = cp(imaterial_number)
+ vsregion = cs(imaterial_number)
+ print *,'Material # ',imaterial_number,' isotropic'
+ if(vsregion < TINYVAL) then
+ print *,'Material is fluid'
+ else
+ print *,'Material is solid'
+ endif
+ print *,'vp = ',vpregion
+ print *,'vs = ',vsregion
+ print *,'rho = ',rho_s(imaterial_number)
+ poisson_ratio = 0.5d0*(vpregion*vpregion-2.d0*vsregion*vsregion) / (vpregion*vpregion-vsregion*vsregion)
+ print *,'Poisson''s ratio = ',poisson_ratio
+ if(poisson_ratio <= -1.00001d0 .or. poisson_ratio >= 0.50001d0) stop 'incorrect value of Poisson''s ratio'
+ print *,'Qp = ',Qp(imaterial_number)
+ print *,'Qs = ',Qs(imaterial_number)
+ elseif(icodemat(imaterial_number) == POROELASTIC_MATERIAL) then
+
+ ! poroelastic material
+ print *,'Material # ',imaterial_number,' isotropic'
+ print *,'Material is poroelastic'
+ else
+
+ ! anisotropic material
+ print *,'Material # ',imaterial_number,' anisotropic'
+ print *,'cp = ',cp(imaterial_number)
+ print *,'cs = ',cs(imaterial_number)
+ print *,'c11 = ',aniso3(imaterial_number)
+ print *,'c13 = ',aniso4(imaterial_number)
+ print *,'c15 = ',aniso5(imaterial_number)
+ print *,'c33 = ',aniso6(imaterial_number)
+ print *,'c35 = ',aniso7(imaterial_number)
+ print *,'c55 = ',aniso8(imaterial_number)
+ print *,'rho = ',rho_s(imaterial_number)
+ print *,'Qp = ',Qp(imaterial_number)
+ print *,'Qs = ',Qs(imaterial_number)
+ endif
+ print *,' -----'
+
+ ! store density and velocity model
+ do i = ixdebregion,ixfinregion
+ do j = izdebregion,izfinregion
+ num_material((j-1)*nxread+i) = imaterial_number
+ enddo
+ enddo
+
+ enddo
+
+ if(minval(num_material) <= 0) stop 'Velocity model not entirely set...'
+
+ end subroutine read_regions
Copied: seismo/2D/SPECFEM2D/trunk/src/read_source_file.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/read_source_file.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_source_file.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/read_source_file.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,144 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+module source_file
+
+ implicit none
+
+ ! source parameters
+ integer, dimension(:),pointer :: source_type,time_function_type
+ double precision, dimension(:),pointer :: xs,zs,f0,tshift_src,angleforce, &
+ Mxx,Mzz,Mxz,factor
+ logical, dimension(:),pointer :: source_surf
+
+contains
+
+ subroutine read_source_file(NSOURCES)
+
+! reads in source file DATA/SOURCE
+
+ implicit none
+ include "constants.h"
+
+ integer :: NSOURCES
+
+ ! local parameters
+ integer :: ios,icounter,i_source,num_sources
+ character(len=150) dummystring
+ integer, parameter :: IIN_SOURCE = 22
+
+ ! allocates memory arrays
+ allocate(source_surf(NSOURCES))
+ allocate(xs(NSOURCES))
+ allocate(zs(NSOURCES))
+ allocate(source_type(NSOURCES))
+ allocate(time_function_type(NSOURCES))
+ allocate(f0(NSOURCES))
+ allocate(tshift_src(NSOURCES))
+ allocate(angleforce(NSOURCES))
+ allocate(Mxx(NSOURCES))
+ allocate(Mxz(NSOURCES))
+ allocate(Mzz(NSOURCES))
+ allocate(factor(NSOURCES))
+
+ ! counts lines
+ open(unit=IIN_SOURCE,file='DATA/SOURCE',iostat=ios,status='old',action='read')
+ if(ios /= 0) stop 'error opening DATA/SOURCE file'
+
+ icounter = 0
+ do while(ios == 0)
+ read(IIN_SOURCE,"(a)",iostat=ios) dummystring
+ if(ios == 0) icounter = icounter + 1
+ enddo
+ close(IIN_SOURCE)
+
+ ! checks counter
+ if(mod(icounter,NLINES_PER_SOURCE) /= 0) &
+ stop 'total number of lines in SOURCE file should be a multiple of NLINES_PER_SOURCE'
+
+ ! total number of sources
+ num_sources = icounter / NLINES_PER_SOURCE
+
+ if(num_sources < 1) stop 'need at least one source in SOURCE file'
+ if(num_sources /= NSOURCES) &
+ stop 'total number of sources read is different than declared in Par_file'
+
+ ! reads in source parameters
+ open(unit=IIN_SOURCE,file='DATA/SOURCE',status='old',action='read')
+ do i_source=1,NSOURCES
+ call read_value_logical(IIN_SOURCE,IGNORE_JUNK,source_surf(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,xs(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,zs(i_source))
+ call read_value_integer(IIN_SOURCE,IGNORE_JUNK,source_type(i_source))
+ call read_value_integer(IIN_SOURCE,IGNORE_JUNK,time_function_type(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,f0(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,tshift_src(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,angleforce(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mxx(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mzz(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mxz(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,factor(i_source))
+
+ ! note: we will further process source info in solver,
+ ! here we just read in the given specifics and show them
+
+ print *
+ print *,'Source', i_source
+ print *,'Position xs, zs = ',xs(i_source),zs(i_source)
+ print *,'Frequency, delay = ',f0(i_source),tshift_src(i_source)
+ print *,'Source type (1=force, 2=explosion): ',source_type(i_source)
+ print *,'Time function type (1=Ricker, 2=First derivative, 3=Gaussian, 4=Dirac, 5=Heaviside): ',time_function_type(i_source)
+ print *,'Angle of the source if force = ',angleforce(i_source)
+ print *,'Mxx of the source if moment tensor = ',Mxx(i_source)
+ print *,'Mzz of the source if moment tensor = ',Mzz(i_source)
+ print *,'Mxz of the source if moment tensor = ',Mxz(i_source)
+ print *,'Multiplying factor = ',factor(i_source)
+ print *
+ enddo ! do i_source=1,NSOURCES
+ close(IIN_SOURCE)
+
+ end subroutine read_source_file
+
+end module source_file
+
Copied: seismo/2D/SPECFEM2D/trunk/src/read_value_parameters.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/read_value_parameters.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/read_value_parameters.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,211 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! read values from parameter file, ignoring white lines and comments
+
+ subroutine read_value_integer(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ integer value_to_read
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_integer
+
+!--------------------
+
+ subroutine read_value_double_precision(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ double precision value_to_read
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_double_precision
+
+!--------------------
+
+ subroutine read_value_logical(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ logical value_to_read
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_logical
+
+!--------------------
+
+ subroutine read_value_string(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ character(len=*) value_to_read
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ value_to_read = string_read
+
+ end subroutine read_value_string
+
+!--------------------
+
+ subroutine read_two_interface_points(iin,ignore_junk,value_to_read_1,value_to_read_2)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ double precision value_to_read_1,value_to_read_2
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ read(string_read,*) value_to_read_1,value_to_read_2
+
+ end subroutine read_two_interface_points
+
+!--------------------
+
+ subroutine read_region_coordinates(iin,ignore_junk,value_to_read_1,value_to_read_2, &
+ value_to_read_3,value_to_read_4,value_to_read_5)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ integer value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ read(string_read,*) value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5
+
+ end subroutine read_region_coordinates
+
+!--------------------
+
+ subroutine read_material_parameters(iin,ignore_junk,i,icodematread,val0read,val1read,val2read,val3read, &
+ val4read,val5read,val6read,val7read,val8read,val9read,val10read,val11read,val12read)
+
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+ integer i,icodematread
+ double precision val0read,val1read,val2read,val3read,val4read,val5read,val6read,val7read,&
+ val8read,val9read,val10read,val11read,val12read
+
+ character(len=100) string_read
+
+ call read_next_line(iin,ignore_junk,string_read)
+ print*,string_read
+ read(string_read,*) i,icodematread,val0read,val1read,val2read,val3read,val4read,val5read,&
+ val6read,val7read,val8read,val9read,val10read,val11read,val12read
+
+
+ end subroutine read_material_parameters
+
+!--------------------
+
+ subroutine read_next_line(iin,ignore_junk,string_read)
+
+ implicit none
+
+ logical ignore_junk
+ character(len=100) string_read
+
+ integer ios,iin,index_equal_sign
+
+ do
+ read(unit=iin,fmt="(a100)",iostat=ios) string_read
+ if(ios /= 0) stop 'error while reading input file'
+
+! suppress leading white spaces, if any
+ string_read = adjustl(string_read)
+
+! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS)
+ if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1)
+
+! exit loop when we find the first line that is not a comment or a white line
+ if(len_trim(string_read) == 0) cycle
+ if(string_read(1:1) /= '#') exit
+
+ enddo
+
+! suppress trailing white spaces, if any
+ string_read = string_read(1:len_trim(string_read))
+
+! suppress trailing comments, if any
+ if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1)
+
+! suppress leading junk (up to the first equal sign, included) if needed
+ if(ignore_junk) then
+ index_equal_sign = index(string_read,'=')
+ if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file'
+ string_read = string_read(index_equal_sign + 1:len_trim(string_read))
+ endif
+
+! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk
+ string_read = adjustl(string_read)
+ string_read = string_read(1:len_trim(string_read))
+
+ end subroutine read_next_line
+
Copied: seismo/2D/SPECFEM2D/trunk/src/recompute_jacobian.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/recompute_jacobian.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/recompute_jacobian.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,168 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! recompute 2D jacobian at a given point in a 4-node or 9-node element
+
+ subroutine recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian,coorg,knods,ispec,ngnod,nspec,npgeo, &
+ stop_if_negative_jacobian)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec,ngnod,nspec,npgeo
+ double precision x,z,xix,xiz,gammax,gammaz
+ double precision xi,gamma,jacobian
+
+ integer knods(ngnod,nspec)
+ double precision coorg(NDIM,npgeo)
+
+! 2D shape functions and their derivatives at receiver
+ double precision shape2D(ngnod)
+ double precision dershape2D(NDIM,ngnod)
+
+ double precision xxi,zxi,xgamma,zgamma,xelm,zelm
+
+ integer ia,nnum
+
+ logical stop_if_negative_jacobian
+
+! only one problematic element is output to OpenDX for now in case of elements with a negative Jacobian
+ integer, parameter :: ntotspecAVS_DX = 1
+
+! recompute jacobian for any (xi,gamma) point, not necessarily a GLL point
+
+! create the 2D shape functions and the Jacobian
+ call define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)
+
+! compute coordinates and jacobian matrix
+ x = ZERO
+ z = ZERO
+
+ xxi = ZERO
+ zxi = ZERO
+ xgamma = ZERO
+ zgamma = ZERO
+
+ do ia=1,ngnod
+
+ nnum = knods(ia,ispec)
+
+ xelm = coorg(1,nnum)
+ zelm = coorg(2,nnum)
+
+ x = x + shape2D(ia)*xelm
+ z = z + shape2D(ia)*zelm
+
+ xxi = xxi + dershape2D(1,ia)*xelm
+ zxi = zxi + dershape2D(1,ia)*zelm
+ xgamma = xgamma + dershape2D(2,ia)*xelm
+ zgamma = zgamma + dershape2D(2,ia)*zelm
+
+ enddo
+
+ jacobian = xxi*zgamma - xgamma*zxi
+
+! the Jacobian is negative, so far this means that there is an error in the mesh
+! therefore print the coordinates of the mesh points of this element
+! and also create an OpenDX file to visualize it
+ if(jacobian <= ZERO .and. stop_if_negative_jacobian) then
+
+! print the coordinates of the mesh points of this element
+ print *, 'ispec = ', ispec
+ print *, 'ngnod = ', ngnod
+ do ia=1,ngnod
+ nnum = knods(ia,ispec)
+ xelm = coorg(1,nnum)
+ zelm = coorg(2,nnum)
+ print *,'node ', ia,' x,y = ',xelm,zelm
+ enddo
+
+! create an OpenDX file to visualize this element
+ open(unit=11,file='DX_first_element_with_negative_jacobian.dx',status='unknown')
+
+! output the points (the mesh is flat therefore the third coordinate is zero)
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ngnod,' data follows'
+ do ia=1,ngnod
+ nnum = knods(ia,ispec)
+ xelm = coorg(1,nnum)
+ zelm = coorg(2,nnum)
+ write(11,*) xelm,zelm,' 0'
+ enddo
+
+! output the element (use its four corners only for now)
+ write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows'
+! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
+ write(11,*) '0 3 1 2'
+
+! output element data
+ write(11,*) 'attribute "element type" string "quads"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
+
+! output dummy data value
+ write(11,*) '1'
+
+! define OpenDX field
+ write(11,*) 'attribute "dep" string "connections"'
+ write(11,*) 'object "irregular positions irregular connections" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+
+! close OpenDX file
+ close(11)
+
+ call exit_MPI('negative 2D Jacobian, element saved in DX_first_element_with_negative_jacobian.dx')
+ endif
+
+! invert the relation
+ xix = zgamma / jacobian
+ gammax = - zxi / jacobian
+ xiz = - xgamma / jacobian
+ gammaz = xxi / jacobian
+
+ end subroutine recompute_jacobian
+
Copied: seismo/2D/SPECFEM2D/trunk/src/save_databases.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/save_databases.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/save_databases.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/save_databases.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,263 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine save_databases(nspec,num_material, &
+ my_interfaces,my_nb_interfaces, &
+ nnodes_tangential_curve,nodes_tangential_curve )
+
+
+! generates the databases for the solver
+
+ use part_unstruct
+ use parameter_file
+ use source_file
+ implicit none
+ include "constants.h"
+
+ integer :: nspec
+ integer, dimension(nelmnts) :: num_material
+
+ integer, dimension(0:ninterfaces-1) :: my_interfaces
+ integer, dimension(0:ninterfaces-1) :: my_nb_interfaces
+
+ integer :: nnodes_tangential_curve
+ double precision, dimension(2,nnodes_tangential_curve) :: nodes_tangential_curve
+
+ ! local parameters
+ integer :: iproc,i_source,i,ios
+ integer :: npgeo
+ integer :: my_ninterface
+ integer :: nedges_coupled_loc
+ integer :: nedges_acporo_coupled_loc
+ integer :: nedges_elporo_coupled_loc
+
+ character(len=256) :: prname
+
+
+ do iproc = 0, nproc-1
+
+ ! opens Database file
+ write(prname, "('./OUTPUT_FILES/Database',i5.5)") iproc
+ open(unit=15,file=trim(prname),status='unknown',iostat=ios)
+ if( ios /= 0 ) stop 'error saving databases'
+
+ write(15,*) '#'
+ write(15,*) '# Database for SPECFEM2D'
+ write(15,*) '# Dimitri Komatitsch, (c) University of Pau, France'
+ write(15,*) '#'
+
+ write(15,*) 'Title of the simulation'
+ write(15,"(a100)") title
+
+ write(15,*) 'Type of simulation'
+ write(15,*) SIMULATION_TYPE, SAVE_FORWARD
+
+ call write_glob2loc_nodes_database(15, iproc, npgeo, 1)
+
+
+ call write_partition_database(15, iproc, nspec, num_material, ngnod, 1)
+
+
+ write(15,*) 'npgeo'
+ write(15,*) npgeo
+
+ write(15,*) 'gnuplot interpol'
+ write(15,*) gnuplot,interpol
+
+ write(15,*) 'NTSTEP_BETWEEN_OUTPUT_INFO'
+ write(15,*) NTSTEP_BETWEEN_OUTPUT_INFO
+
+ write(15,*) 'output_postscript_snapshot output_color_image colors numbers'
+ write(15,*) output_postscript_snapshot,output_color_image,' 1 0'
+
+ write(15,*) 'meshvect modelvect boundvect cutsnaps subsamp sizemax_arrows'
+ write(15,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
+
+ write(15,*) 'anglerec'
+ write(15,*) anglerec
+
+ write(15,*) 'initialfield add_Bielak_conditions'
+ write(15,*) initialfield,add_Bielak_conditions
+
+ write(15,*) 'seismotype imagetype'
+ write(15,*) seismotype,imagetype
+
+ write(15,*) 'assign_external_model READ_EXTERNAL_SEP_FILE'
+ write(15,*) assign_external_model,READ_EXTERNAL_SEP_FILE
+
+ write(15,*) 'outputgrid OUTPUT_ENERGY TURN_ATTENUATION_ON'
+ write(15,*) outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON
+
+ write(15,*) 'TURN_VISCATTENUATION_ON Q0 freq0'
+ write(15,*) TURN_VISCATTENUATION_ON,Q0,freq0
+
+ write(15,*) 'p_sv'
+ write(15,*) p_sv
+
+ write(15,*) 'nt deltat'
+ write(15,*) nt,deltat
+ write(15,*) 'NSOURCES'
+ write(15,*) NSOURCES
+
+ do i_source=1,NSOURCES
+ write(15,*) 'source', i_source
+ write(15,*) source_type(i_source),time_function_type(i_source), &
+ xs(i_source),zs(i_source),f0(i_source),tshift_src(i_source), &
+ factor(i_source),angleforce(i_source), &
+ Mxx(i_source),Mzz(i_source),Mxz(i_source)
+ enddo
+
+ write(15,*) 'attenuation'
+ write(15,*) N_SLS, f0_attenuation
+
+ write(15,*) 'Coordinates of macrobloc mesh (coorg):'
+
+ call write_glob2loc_nodes_database(15, iproc, npgeo, 2)
+
+ write(15,*) 'numat ngnod nspec pointsdisp plot_lowerleft_corner_only'
+ write(15,*) nb_materials,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
+
+ if (any_abs) then
+ call write_abs_merge_database(15, iproc, 1)
+ else
+ nelemabs_loc = 0
+ endif
+
+ call write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
+ iproc, 1)
+
+ call write_fluidsolid_edges_database(15,nedges_coupled, nedges_coupled_loc, &
+ edges_coupled, iproc, 1)
+ call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
+ edges_acporo_coupled, iproc, 1)
+ call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
+ edges_elporo_coupled, iproc, 1)
+
+ if (.not. ( force_normal_to_surface .or. rec_normal_to_surface ) ) then
+ nnodes_tangential_curve = 0
+ endif
+
+ write(15,*) 'nelemabs nelem_acoustic_surface num_fluid_solid_edges num_fluid_poro_edges'
+ write(15,*) 'num_solid_poro_edges nnodes_tangential_curve'
+ write(15,*) nelemabs_loc,nelem_acoustic_surface_loc, &
+ nedges_coupled_loc,nedges_acporo_coupled_loc,&
+ nedges_elporo_coupled_loc,nnodes_tangential_curve
+
+ write(15,*) 'Material sets (num 1 rho vp vs 0 0 Qp Qs 0 0 0 0 0 0) or '
+ write(15,*) '(num 2 rho c11 c13 c33 c44 Qp Qs 0 0 0 0 0 0) or '
+ write(15,*) '(num 3 rhos rhof phi c k_xx k_xz k_zz Ks Kf Kfr etaf mufr Qs)'
+ do i=1,nb_materials
+ if (icodemat(i) == ISOTROPIC_MATERIAL) then
+ write(15,*) i,icodemat(i),rho_s(i),cp(i),cs(i),0,0,Qp(i),Qs(i),0,0,0,0,0,0
+ elseif(icodemat(i) == POROELASTIC_MATERIAL) then
+ write(15,*) i,icodemat(i),rho_s(i),rho_f(i),phi(i),tortuosity(i), &
+ permxx(i),permxz(i),permzz(i),kappa_s(i),&
+ kappa_f(i),kappa_fr(i),eta_f(i),mu_fr(i),Qs(i)
+ else
+ write(15,*) i,icodemat(i),rho_s(i),cp(i),cs(i), &
+ aniso3(i),aniso4(i),aniso5(i),aniso6(i),&
+ aniso7(i),aniso8(i),Qp(i),Qs(i),0,0
+ endif
+ enddo
+
+ write(15,*) 'Arrays kmato and knods for each bloc:'
+
+ call write_partition_database(15, iproc, nspec, num_material, ngnod, 2)
+
+ if ( nproc /= 1 ) then
+ call write_interfaces_database(15, nproc, iproc, &
+ my_ninterface, my_interfaces, my_nb_interfaces, 1)
+
+ write(15,*) 'Interfaces:'
+ write(15,*) my_ninterface, maxval(my_nb_interfaces)
+
+ call write_interfaces_database(15, nproc, iproc, &
+ my_ninterface, my_interfaces, my_nb_interfaces, 2)
+
+ else
+ write(15,*) 'Interfaces:'
+ write(15,*) 0, 0
+ endif
+
+
+ write(15,*) 'List of absorbing elements (bottom right top left):'
+ if ( any_abs ) then
+ call write_abs_merge_database(15, iproc, 2)
+ endif
+
+ write(15,*) 'List of acoustic free-surface elements:'
+ call write_surface_database(15, nelem_acoustic_surface, acoustic_surface, nelem_acoustic_surface_loc, &
+ iproc, 2)
+
+
+ write(15,*) 'List of acoustic elastic coupled edges:'
+ call write_fluidsolid_edges_database(15, nedges_coupled, nedges_coupled_loc, &
+ edges_coupled, iproc, 2)
+
+ write(15,*) 'List of acoustic poroelastic coupled edges:'
+ call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
+ edges_acporo_coupled, iproc, 2)
+
+ write(15,*) 'List of poroelastic elastic coupled edges:'
+ call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
+ edges_elporo_coupled, iproc, 2)
+
+ write(15,*) 'List of tangential detection curve nodes:'
+ !write(15,*) nnodes_tangential_curve
+ write(15,*) force_normal_to_surface,rec_normal_to_surface
+
+ if (force_normal_to_surface .or. rec_normal_to_surface) then
+ do i = 1, nnodes_tangential_curve
+ write(15,*) nodes_tangential_curve(1,i),nodes_tangential_curve(2,i)
+ enddo
+ endif
+
+ ! closes Database file
+ close(15)
+
+ enddo
+
+ end subroutine save_databases
+
Copied: seismo/2D/SPECFEM2D/trunk/src/save_gnuplot_file.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/save_gnuplot_file.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/save_gnuplot_file.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/save_gnuplot_file.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,118 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine save_gnuplot_file(ngnod,nx,nz,x,z)
+
+! creates a Gnuplot file that displays the grid
+
+ implicit none
+
+ integer :: ngnod,nx,nz
+ double precision, dimension(0:nx,0:nz) :: x,z
+
+ ! local parameters
+ integer :: ios,istepx,istepz,ili,icol
+
+ print *
+ print *,'Saving the grid in Gnuplot format...'
+
+ open(unit=20,file='OUTPUT_FILES/gridfile.gnu',status='unknown',iostat=ios)
+ if( ios /= 0 ) stop 'error saving gnuplot file'
+
+ ! draw horizontal lines of the grid
+ print *,'drawing horizontal lines of the grid'
+ istepx = 1
+ if(ngnod == 4) then
+ istepz = 1
+ else
+ istepz = 2
+ endif
+ do ili=0,nz,istepz
+ do icol=0,nx-istepx,istepx
+ write(20,*) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,*) sngl(x(icol+istepx,ili)),sngl(z(icol+istepx,ili))
+ write(20,10)
+ enddo
+ enddo
+
+ ! draw vertical lines of the grid
+ print *,'drawing vertical lines of the grid'
+ if(ngnod == 4) then
+ istepx = 1
+ else
+ istepx = 2
+ endif
+ istepz = 1
+ do icol=0,nx,istepx
+ do ili=0,nz-istepz,istepz
+ write(20,*) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,*) sngl(x(icol,ili+istepz)),sngl(z(icol,ili+istepz))
+ write(20,10)
+ enddo
+ enddo
+
+10 format('')
+
+ close(20)
+
+ ! create a Gnuplot script to display the grid
+ open(unit=20,file='OUTPUT_FILES/plotgnu',status='unknown',iostat=ios)
+ if( ios /= 0 ) stop 'error saving plotgnu file'
+
+ write(20,*) '#set term X11'
+ write(20,*) 'set term postscript landscape monochrome solid "Helvetica" 22'
+ write(20,*) 'set output "grid.ps"'
+ write(20,*) '#set xrange [',sngl(minval(x)),':',sngl(maxval(x)),']'
+ write(20,*) '#set yrange [',sngl(minval(z)),':',sngl(maxval(z)),']'
+ ! use same unit length on both X and Y axes
+ write(20,*) 'set size ratio -1'
+ write(20,*) 'plot "gridfile.gnu" title "Macrobloc mesh" w l'
+ write(20,*) 'pause -1 "Hit any key..."'
+ close(20)
+
+ print *,'Grid saved in Gnuplot format...'
+ print *
+
+ end subroutine save_gnuplot_file
Copied: seismo/2D/SPECFEM2D/trunk/src/save_openDX_jacobian.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/save_openDX_jacobian.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/save_openDX_jacobian.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/save_openDX_jacobian.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,155 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine save_openDX_jacobian(nspec,npgeo,ngnod,knods,coorg,xigll,zigll)
+
+ implicit none
+ include "constants.h"
+
+ integer :: nspec,npgeo,ngnod
+ double precision, dimension(NDIM,npgeo) :: coorg
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ integer, dimension(ngnod,nspec) :: knods
+
+ ! local parameters
+ integer, dimension(:), allocatable :: ibool_OpenDX
+ logical, dimension(:), allocatable :: mask_point
+ double precision :: xelm,zelm
+ double precision :: xi,gamma,x,z
+ double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+ integer :: ia,nnum,ipoint_number,total_of_negative_elements
+ integer :: ispec,i,j
+ logical :: found_a_problem_in_this_element
+
+ ! create an OpenDX file to visualize this element
+ open(unit=11,file='DX_all_elements_with_negative_jacobian_in_red.dx',status='unknown')
+
+ ! output all the points (i.e. all the control points of the mesh)
+ ! the mesh is flat therefore the third coordinate is zero
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',npgeo,' data follows'
+ ipoint_number = 0
+ allocate(mask_point(npgeo))
+ allocate(ibool_OpenDX(npgeo))
+ mask_point(:) = .false.
+ do ispec = 1,nspec
+ do ia=1,ngnod
+ nnum = knods(ia,ispec)
+ xelm = coorg(1,nnum)
+ zelm = coorg(2,nnum)
+ if(.not. mask_point(knods(ia,ispec))) then
+ mask_point(knods(ia,ispec)) = .true.
+ ibool_OpenDX(knods(ia,ispec)) = ipoint_number
+ write(11,*) xelm,zelm,' 0'
+ ipoint_number = ipoint_number + 1
+ endif
+ enddo
+ enddo
+ deallocate(mask_point)
+
+ ! output all the elements of the mesh (use their four corners only in OpenDX
+ write(11,*) 'object 2 class array type int rank 1 shape 4 items ',nspec,' data follows'
+ ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
+ do ispec = 1,nspec
+ write(11,*) ibool_OpenDX(knods(1,ispec)),ibool_OpenDX(knods(4,ispec)), &
+ ibool_OpenDX(knods(2,ispec)),ibool_OpenDX(knods(3,ispec))
+ enddo
+ deallocate(ibool_OpenDX)
+
+ ! output element data
+ write(11,*) 'attribute "element type" string "quads"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items ',nspec,' data follows'
+
+ ! output all the element data (value = 1 if positive Jacobian, = 2 if negative Jacobian)
+ total_of_negative_elements = 0
+ do ispec = 1,nspec
+
+ ! check if this element has a negative Jacobian at any of its points
+ found_a_problem_in_this_element = .false.
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ xi = xigll(i)
+ gamma = zigll(j)
+
+ call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
+ jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
+ .false.)
+
+ if(jacobianl <= ZERO) found_a_problem_in_this_element = .true.
+ enddo
+ enddo
+
+ ! output data value
+ if(found_a_problem_in_this_element) then
+ write(11,*) '2'
+ print *,'element ',ispec,' has a negative Jacobian'
+ total_of_negative_elements = total_of_negative_elements + 1
+ else
+ write(11,*) '1'
+ endif
+
+ enddo
+
+ ! define OpenDX field
+ write(11,*) 'attribute "dep" string "connections"'
+ write(11,*) 'object "irregular positions irregular connections" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+
+ ! close OpenDX file
+ close(11)
+
+ print *
+ print *,total_of_negative_elements,' elements have a negative Jacobian, out of ',nspec
+ print *,'i.e., ',sngl(100.d0 * dble(total_of_negative_elements)/dble(nspec)),'%'
+ print *
+
+ end subroutine save_openDX_jacobian
\ No newline at end of file
Copied: seismo/2D/SPECFEM2D/trunk/src/save_stations_file.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/save_stations_file.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/save_stations_file.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/save_stations_file.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,122 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine save_stations_file(nreceiverlines,nrec,xdeb,zdeb,xfin,zfin,enreg_surf_same_vertical, &
+ xinterface_top,zinterface_top,coefs_interface_top, &
+ npoints_interface_top,max_npoints_interface)
+
+ implicit none
+
+ integer :: nreceiverlines
+ integer, dimension(nreceiverlines) :: nrec
+ double precision, dimension(nreceiverlines) :: xdeb,zdeb,xfin,zfin
+ logical, dimension(nreceiverlines) :: enreg_surf_same_vertical
+
+ integer :: max_npoints_interface
+ double precision, dimension(max_npoints_interface) :: xinterface_top, &
+ zinterface_top,coefs_interface_top
+ integer :: npoints_interface_top
+
+ !local parameters
+ integer :: ireceiverlines,irec,irec_global_number,ios
+ integer :: nrec_total
+ double precision :: xrec,zrec
+ double precision, external :: value_spline
+
+ print *
+ print *,'writing the DATA/STATIONS_target file'
+ print *
+
+ ! total number of receivers in all the receiver lines
+ nrec_total = sum(nrec)
+
+ print *
+ print *,'There are ',nrec_total,' receivers'
+
+ print *
+ print *,'Position (x,z) of the ',nrec_total,' receivers'
+ print *
+
+ open(unit=15,file='DATA/STATIONS_target',status='unknown',iostat=ios)
+ if( ios /= 0 ) stop 'error saving STATIONS file'
+
+ irec_global_number = 0
+
+ ! loop on all the receiver lines
+ do ireceiverlines = 1,nreceiverlines
+
+ ! loop on all the receivers of this receiver line
+ do irec = 1,nrec(ireceiverlines)
+
+ ! compute global receiver number
+ irec_global_number = irec_global_number + 1
+
+ ! compute coordinates of the receiver
+ if(nrec(ireceiverlines) > 1) then
+ xrec = xdeb(ireceiverlines) + dble(irec-1)*(xfin(ireceiverlines) &
+ -xdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
+ zrec = zdeb(ireceiverlines) + dble(irec-1)*(zfin(ireceiverlines) &
+ -zdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
+ else
+ xrec = xdeb(ireceiverlines)
+ zrec = zdeb(ireceiverlines)
+ endif
+
+ ! modify position of receiver if we must record exactly at the surface
+ if(enreg_surf_same_vertical(ireceiverlines)) &
+ zrec = value_spline(xrec,xinterface_top,zinterface_top, &
+ coefs_interface_top,npoints_interface_top)
+
+ ! display position of the receiver
+ print *,'Receiver ',irec_global_number,' = ',xrec,zrec
+
+ write(15,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") irec_global_number,xrec,zrec
+
+ enddo
+ enddo
+
+ close(15)
+
+ end subroutine save_stations_file
+
Copied: seismo/2D/SPECFEM2D/trunk/src/set_sources.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/set_sources.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/set_sources.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/set_sources.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,252 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+ subroutine set_sources(myrank,NSOURCES,source_type,time_function_type, &
+ x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce,aval, &
+ t0,initialfield,ipass,deltat)
+
+! gets source parameters
+
+ implicit none
+ include "constants.h"
+
+ integer :: myrank
+ integer :: NSOURCES
+ integer, dimension(NSOURCES) :: source_type,time_function_type
+ double precision, dimension(NSOURCES) :: x_source,z_source, &
+ Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
+ double precision, dimension(NSOURCES) :: aval
+ double precision :: t0
+ double precision :: deltat
+ integer :: ipass
+ logical :: initialfield
+
+ ! local parameters
+ integer :: i_source
+ double precision, dimension(NSOURCES) :: t0_source,hdur
+ double precision :: min_tshift_src_original
+
+ ! checks the input
+ do i_source=1,NSOURCES
+
+ ! checks source type
+ if(.not. initialfield) then
+ if (source_type(i_source) == 1) then
+ if ( myrank == 0 .and. ipass == 1 ) then
+ ! user output
+ write(IOUT,212) x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
+ factor(i_source),angleforce(i_source)
+ endif
+ else if(source_type(i_source) == 2) then
+ if ( myrank == 0 .and. ipass == 1 ) then
+ ! user output
+ write(IOUT,222) x_source(i_source),z_source(i_source),f0(i_source),tshift_src(i_source), &
+ factor(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
+ endif
+ else
+ call exit_MPI('Unknown source type number !')
+ endif
+ endif
+
+ ! if Dirac source time function, use a very thin Gaussian instead
+ ! if Heaviside source time function, use a very thin error function instead
+ if(time_function_type(i_source) == 4 .or. time_function_type(i_source) == 5) &
+ f0(i_source) = 1.d0 / (10.d0 * deltat)
+
+ ! checks source frequency
+ if( abs(f0(i_source)) < TINYVAL ) then
+ call exit_MPI('Error source frequency is zero')
+ endif
+
+ ! half-duration of source
+ hdur(i_source) = 1.d0 / f0(i_source)
+
+ ! sets source start times, shifted by the given (non-zero) time-shift
+ if(time_function_type(i_source)== 5) then
+ t0_source(i_source) = 2.0d0 * hdur(i_source) + tshift_src(i_source)
+ else
+ t0_source(i_source) = 1.20d0 * hdur(i_source) + tshift_src(i_source)
+ endif
+
+ ! for the source time function
+ aval(i_source) = PI*PI*f0(i_source)*f0(i_source)
+
+ ! convert angle from degrees to radians
+ angleforce(i_source) = angleforce(i_source) * PI / 180.d0
+
+ enddo ! do i_source=1,NSOURCES
+
+ ! initializes simulation start time
+ if( NSOURCES == 1 ) then
+ ! simulation start time
+ t0 = t0_source(1)
+ ! sets source time shift relative to simulation start time
+ min_tshift_src_original = tshift_src(1)
+ tshift_src(1) = 0.d0
+ else
+ ! starts with earliest start time
+ t0 = minval( t0_source(:) )
+ ! sets source time shifts relative to simulation start time
+ min_tshift_src_original = minval( tshift_src(:) )
+ tshift_src(:) = t0_source(:) - t0
+ endif
+
+ ! checks if user set USER_T0 to fix simulation start time
+ ! note: USER_T0 has to be positive
+ if( USER_T0 > 0.d0 ) then
+ ! user cares about origin time and time shifts of the CMTSOLUTION
+ ! and wants to fix simulation start time to a constant start time
+ ! time 0 on time axis will correspond to given origin time
+
+ ! notifies user
+ if( myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) ' using USER_T0 . . . . . . . . . = ',USER_T0
+ write(IOUT,*) ' original t0 . . . . . . . . . = ',t0
+ write(IOUT,*) ' min_tshift_src_original . . . = ',min_tshift_src_original
+ write(IOUT,*)
+ endif
+
+ ! checks if automatically set t0 is too small
+ ! note: times in seismograms are shifted by t0(1)
+ if( t0 <= USER_T0 + min_tshift_src_original ) then
+
+ ! sets new simulation start time such that
+ ! simulation starts at t = - t0 = - USER_T0
+ t0 = USER_T0
+
+ ! notifies user
+ if( myrank == 0 .and. ipass == 1) then
+ write(IOUT,*) ' fix new simulation start time . = ', - t0
+ endif
+
+ ! loops over all sources
+ do i_source=1,NSOURCES
+ ! sets the given, initial time shifts
+ if( time_function_type(i_source) == 5 ) then
+ tshift_src(i_source) = t0_source(i_source) - 2.0d0 * hdur(i_source)
+ else
+ tshift_src(i_source) = t0_source(i_source) - 1.20d0 * hdur(i_source)
+ endif
+ ! user output
+ if( myrank == 0 .and. ipass == 1) then
+ write(IOUT,*) ' source ',i_source,'uses tshift = ',tshift_src(i_source)
+ endif
+ enddo
+ ! user output
+ if( myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ endif
+
+ else
+ ! start time needs to be at least t0 for numerical stability
+ ! notifies user
+ if( myrank == 0 .and. ipass == 1) then
+ write(IOUT,*) 'error: USER_T0 is too small'
+ write(IOUT,*) ' must make one of three adjustements:'
+ write(IOUT,*) ' - increase USER_T0 to be at least: ',t0
+ write(IOUT,*) ' - decrease time shift tshift_src in SOURCE file'
+ write(IOUT,*) ' - increase frequency f0 in SOURCE file'
+ endif
+ call exit_MPI('error USER_T0 is set but too small')
+ endif
+ else if( USER_T0 < 0.d0 ) then
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) 'error: USER_T0 is negative, must be set zero or positive!'
+ endif
+ call exit_MPI('error negative USER_T0 parameter in constants.h')
+ endif
+
+ ! checks onset times
+ if(.not. initialfield) then
+
+ ! loops over sources
+ do i_source = 1,NSOURCES
+
+ ! excludes Dirac and Heaviside sources
+ if(time_function_type(i_source) /= 4 .and. time_function_type(i_source) /= 5) then
+
+ ! user output
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) ' Onset time. . . . . . = ',t0+tshift_src(i_source)
+ write(IOUT,*) ' Fundamental period. . = ',1.d0/f0(i_source)
+ write(IOUT,*) ' Fundamental frequency = ',f0(i_source)
+ endif
+
+ ! checks source onset time
+ if( t0+tshift_src(i_source) <= 1.d0/f0(i_source)) then
+ call exit_MPI('Onset time too small')
+ else
+ if( myrank == 0 .and. ipass == 1 ) then
+ write(IOUT,*) ' --> onset time ok'
+ endif
+ endif
+ endif
+ enddo
+
+ endif
+
+
+ ! output formats
+212 format(//,5x,'Source Type. . . . . . . . . . . . . . = Collocated Force',/5x, &
+ 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
+ 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Angle from vertical direction (deg). . =',1pe20.10,/5x)
+
+222 format(//,5x,'Source Type. . . . . . . . . . . . . . = Moment-tensor',/5x, &
+ 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
+ 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Mxx. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Mzz. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Mxz. . . . . . . . . . . . . . . . . . =',1pe20.10)
+
+ end subroutine set_sources
Copied: seismo/2D/SPECFEM2D/trunk/src/setup_sources_receivers.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/setup_sources_receivers.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/setup_sources_receivers.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/setup_sources_receivers.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,170 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+! Pieyre Le Loher, pieyre DOT le-loher aT inria.fr
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+ subroutine setup_sources_receivers(NSOURCES,initialfield,source_type,&
+ coord,ibool,npoin,nspec,nelem_acoustic_surface,acoustic_surface,elastic,poroelastic, &
+ x_source,z_source,ispec_selected_source,ispec_selected_rec, &
+ is_proc_source,nb_proc_source,ipass,&
+ sourcearray,Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,npgeo,&
+ nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod, &
+ nrec,nrecloc,recloc,which_proc_receiver,st_xval,st_zval, &
+ xi_receiver,gamma_receiver,station_name,network_name,x_final_receiver,z_final_receiver,iglob_source)
+
+ implicit none
+
+ include "constants.h"
+
+ logical :: initialfield
+ integer :: NSOURCES
+ integer :: npgeo,ngnod,myrank,ipass,nproc
+ integer :: npoin,nspec,nelem_acoustic_surface
+
+ ! Gauss-Lobatto-Legendre points
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ ! for receivers
+ integer :: nrec,nrecloc
+ integer, dimension(nrec) :: recloc, which_proc_receiver
+ integer, dimension(nrec) :: ispec_selected_rec
+ double precision, dimension(nrec) :: xi_receiver,gamma_receiver,st_xval,st_zval
+ double precision, dimension(nrec) :: x_final_receiver, z_final_receiver
+
+ ! timing information for the stations
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ ! for sources
+ integer, dimension(NSOURCES) :: source_type
+ integer, dimension(NSOURCES) :: ispec_selected_source,is_proc_source,nb_proc_source,iglob_source
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLZ) :: sourcearray
+ double precision, dimension(NSOURCES) :: x_source,z_source,xi_source,gamma_source,Mxx,Mzz,Mxz
+
+ logical, dimension(nspec) :: elastic,poroelastic
+ integer, dimension(ngnod,nspec) :: knods
+ integer, dimension(5,nelem_acoustic_surface) :: acoustic_surface
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+ double precision, dimension(NDIM,npgeo) :: coorg
+ double precision, dimension(NDIM,npoin) :: coord
+
+ integer :: ixmin, ixmax, izmin, izmax
+
+ ! Local variables
+ integer i_source,ispec,ispec_acoustic_surface
+
+ do i_source=1,NSOURCES
+
+ if(source_type(i_source) == 1) then
+
+ ! collocated force source
+ call locate_source_force(ibool,coord,nspec,npoin,xigll,zigll,x_source(i_source),z_source(i_source), &
+ ispec_selected_source(i_source),is_proc_source(i_source),nb_proc_source(i_source),&
+ nproc,myrank,xi_source(i_source),gamma_source(i_source),coorg,knods,ngnod,npgeo,ipass,&
+ iglob_source(i_source))
+
+ ! check that acoustic source is not exactly on the free surface because pressure is zero there
+ if(is_proc_source(i_source) == 1) then
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+ ispec = acoustic_surface(1,ispec_acoustic_surface)
+ ixmin = acoustic_surface(2,ispec_acoustic_surface)
+ ixmax = acoustic_surface(3,ispec_acoustic_surface)
+ izmin = acoustic_surface(4,ispec_acoustic_surface)
+ izmax = acoustic_surface(5,ispec_acoustic_surface)
+ if( .not. elastic(ispec) .and. .not. poroelastic(ispec) .and. &
+ ispec == ispec_selected_source(i_source) ) then
+ if ( (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==NGLLX .and. &
+ gamma_source(i_source) < -0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==NGLLX .and. &
+ gamma_source(i_source) > 0.99d0) .or.&
+ (izmin==1 .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
+ xi_source(i_source) < -0.99d0) .or.&
+ (izmin==1 .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ xi_source(i_source) > 0.99d0) .or.&
+ (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==1 .and. &
+ gamma_source(i_source) < -0.99d0 .and. xi_source(i_source) < -0.99d0) .or.&
+ (izmin==1 .and. izmax==1 .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ gamma_source(i_source) < -0.99d0 .and. xi_source(i_source) > 0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
+ gamma_source(i_source) > 0.99d0 .and. xi_source(i_source) < -0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ gamma_source(i_source) > 0.99d0 .and. xi_source(i_source) > 0.99d0) ) then
+ call exit_MPI('an acoustic source cannot be located exactly '// &
+ 'on the free surface because pressure is zero there')
+ endif
+ endif
+ enddo
+ endif
+
+ else if(source_type(i_source) == 2) then
+ ! moment-tensor source
+ call locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source(i_source),z_source(i_source), &
+ ispec_selected_source(i_source),is_proc_source(i_source),nb_proc_source(i_source),&
+ nproc,myrank,xi_source(i_source),gamma_source(i_source),coorg,knods,ngnod,npgeo,ipass)
+
+ ! compute source array for moment-tensor source
+ call compute_arrays_source(ispec_selected_source(i_source),xi_source(i_source),gamma_source(i_source),&
+ sourcearray(i_source,:,:,:), &
+ Mxx(i_source),Mzz(i_source),Mxz(i_source),xix,xiz,gammax,gammaz,xigll,zigll,nspec)
+
+ else if(.not.initialfield) then
+
+ call exit_MPI('incorrect source type')
+
+ endif
+
+ enddo ! do i_source=1,NSOURCES
+
+ ! locate receivers in the mesh
+ call locate_receivers(ibool,coord,nspec,npoin,xigll,zigll, &
+ nrec,nrecloc,recloc,which_proc_receiver,nproc,myrank, &
+ st_xval,st_zval,ispec_selected_rec, &
+ xi_receiver,gamma_receiver,station_name,network_name, &
+ x_source(1),z_source(1), &
+ coorg,knods,ngnod,npgeo,ipass, &
+ x_final_receiver,z_final_receiver)
+
+ end subroutine setup_sources_receivers
+
Copied: seismo/2D/SPECFEM2D/trunk/src/sort_array_coordinates.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/sort_array_coordinates.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/sort_array_coordinates.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/sort_array_coordinates.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,241 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+
+#ifdef USE_MPI
+
+! subroutines to sort MPI buffers to assemble between chunks
+
+ subroutine sort_array_coordinates(npointot,x,z,ibool,iglob,loc,ifseg, &
+ nglob,ind,ninseg,iwork,work)
+
+! this routine MUST be in double precision to avoid sensitivity
+! to roundoff errors in the coordinates of the points
+!
+! returns: sorted indexing array (ibool), reordering array (iglob) & number of global points (nglob)
+
+ implicit none
+
+ include "constants.h"
+
+ integer,intent(in) :: npointot
+ integer,intent(out) :: nglob
+
+ integer,intent(inout) :: ibool(npointot)
+
+ integer iglob(npointot),loc(npointot)
+ integer ind(npointot),ninseg(npointot)
+ logical ifseg(npointot)
+ double precision,intent(in) :: x(npointot),z(npointot)
+ integer iwork(npointot)
+ double precision work(npointot)
+
+ ! local parameters
+ integer ipoin,i,j
+ integer nseg,ioff,iseg,ig
+ ! define a tolerance, normalized radius is 1., so let's use a small value
+ double precision,parameter :: xtol = SMALLVALTOL
+
+ ! establish initial pointers
+ do ipoin=1,npointot
+ loc(ipoin)=ipoin
+ enddo
+
+ ifseg(:)=.false.
+
+ nseg=1
+ ifseg(1)=.true.
+ ninseg(1)=npointot
+
+ do j=1,NDIM
+
+ ! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+
+ if(j == 1) then
+ call rank_buffers(x(ioff),ind,ninseg(iseg))
+ else if(j == 2) then
+ call rank_buffers(z(ioff),ind,ninseg(iseg))
+ endif
+
+ call swap_all_buffers(ibool(ioff),loc(ioff), &
+ x(ioff),z(ioff),iwork,work,ind,ninseg(iseg))
+
+ ioff=ioff+ninseg(iseg)
+ enddo
+
+ ! check for jumps in current coordinate
+ if(j == 1) then
+ do i=2,npointot
+ if(dabs(x(i)-x(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else if(j == 2) then
+ do i=2,npointot
+ if(dabs(z(i)-z(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ endif
+
+ ! count up number of different segments
+ nseg=0
+ do i=1,npointot
+ if(ifseg(i)) then
+ nseg=nseg+1
+ ninseg(nseg)=1
+ else
+ ninseg(nseg)=ninseg(nseg)+1
+ endif
+ enddo
+ enddo
+
+ ! assign global node numbers (now sorted lexicographically)
+ ig=0
+ do i=1,npointot
+ if(ifseg(i)) ig=ig+1
+ iglob(loc(i))=ig
+ enddo
+
+ nglob=ig
+
+ end subroutine sort_array_coordinates
+
+! -------------------- library for sorting routine ------------------
+
+! sorting routines put here in same file to allow for inlining
+
+ subroutine rank_buffers(A,IND,N)
+!
+! Use Heap Sort (Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(n)
+ integer IND(n)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do j=1,n
+ IND(j)=j
+ enddo
+
+ if(n == 1) return
+
+ L=n/2+1
+ ir=n
+ 100 CONTINUE
+ IF(l>1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 CONTINUE
+ IF(J <= IR) THEN
+ IF(J < IR) THEN
+ IF(A(IND(j)) < A(IND(j+1))) j=j+1
+ ENDIF
+ IF (q < A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ goto 200
+ ENDIF
+ IND(I)=INDX
+ goto 100
+ end subroutine rank_buffers
+
+! -------------------------------------------------------------------
+
+ subroutine swap_all_buffers(IA,IB,A,B,IW,W,ind,n)
+!
+! swap arrays IA, IB, A and B according to addressing in array IND
+!
+ implicit none
+
+ integer n
+
+ integer IND(n)
+ integer IA(n),IB(n),IW(n)
+ double precision A(n),B(n),W(n)
+
+ integer i
+
+ do i=1,n
+ W(i)=A(i)
+ IW(i)=IA(i)
+ enddo
+
+ do i=1,n
+ A(i)=W(ind(i))
+ IA(i)=IW(ind(i))
+ enddo
+
+ do i=1,n
+ W(i)=B(i)
+ IW(i)=IB(i)
+ enddo
+
+ do i=1,n
+ B(i)=W(ind(i))
+ IB(i)=IW(ind(i))
+ enddo
+
+ end subroutine swap_all_buffers
+
+#endif
Copied: seismo/2D/SPECFEM2D/trunk/src/specfem2D.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/specfem2D.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/specfem2D.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/specfem2D.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,6863 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+!====================================================================================
+!
+! An explicit 2D parallel MPI spectral element solver
+! for the anelastic anisotropic or poroelastic wave equation.
+!
+!====================================================================================
+
+! If you use this code for your own research, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{VaCaSaKoVi99,
+! author = {R. Vai and J. M. Castillo-Covarrubias and F. J. S\'anchez-Sesma and
+! D. Komatitsch and J. P. Vilotte},
+! title = {Elastic wave propagation in an irregularly layered medium},
+! journal = {Soil Dynamics and Earthquake Engineering},
+! year = {1999},
+! volume = {18},
+! pages = {11-18},
+! number = {1},
+! doi = {10.1016/S0267-7261(98)00027-X}}
+!
+! @ARTICLE{LeChKoHuTr09,
+! author = {Shiann Jong Lee and Yu Chang Chan and Dimitri Komatitsch and Bor
+! Shouh Huang and Jeroen Tromp},
+! title = {Effects of realistic surface topography on seismic ground motion
+! in the {Y}angminshan region of {T}aiwan based upon the spectral-element
+! method and {LiDAR DTM}},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2009},
+! volume = {99},
+! pages = {681-693},
+! number = {2A},
+! doi = {10.1785/0120080264}}
+!
+! @ARTICLE{LeChLiKoHuTr08,
+! author = {Shiann Jong Lee and How Wei Chen and Qinya Liu and Dimitri Komatitsch
+! and Bor Shouh Huang and Jeroen Tromp},
+! title = {Three-Dimensional Simulations of Seismic Wave Propagation in the
+! {T}aipei Basin with Realistic Topography Based upon the Spectral-Element Method},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2008},
+! volume = {98},
+! pages = {253-264},
+! number = {1},
+! doi = {10.1785/0120070033}}
+!
+! @ARTICLE{LeKoHuTr09,
+! author = {S. J. Lee and Dimitri Komatitsch and B. S. Huang and J. Tromp},
+! title = {Effects of topography on seismic wave propagation: An example from
+! northern {T}aiwan},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2009},
+! volume = {99},
+! pages = {314-325},
+! number = {1},
+! doi = {10.1785/0120080020}}
+!
+! @ARTICLE{KoErGoMi10,
+! author = {Dimitri Komatitsch and Gordon Erlebacher and Dominik G\"oddeke and
+! David Mich\'ea},
+! title = {High-order finite-element seismic wave propagation modeling with
+! {MPI} on a large {GPU} cluster},
+! journal = {J. Comput. Phys.},
+! year = {2010},
+! volume = {229},
+! pages = {7692-7714},
+! number = {20},
+! doi = {10.1016/j.jcp.2010.06.024}}
+!
+! @ARTICLE{KoGoErMi10,
+! author = {Dimitri Komatitsch and Dominik G\"oddeke and Gordon Erlebacher and
+! David Mich\'ea},
+! title = {Modeling the propagation of elastic waves using spectral elements
+! on a cluster of 192 {GPU}s},
+! journal = {Computer Science Research and Development},
+! year = {2010},
+! volume = {25},
+! pages = {75-82},
+! number = {1-2},
+! doi = {10.1007/s00450-010-0109-1}}
+!
+! @ARTICLE{KoMiEr09,
+! author = {Dimitri Komatitsch and David Mich\'ea and Gordon Erlebacher},
+! title = {Porting a high-order finite-element earthquake modeling application
+! to {NVIDIA} graphics cards using {CUDA}},
+! journal = {Journal of Parallel and Distributed Computing},
+! year = {2009},
+! volume = {69},
+! pages = {451-460},
+! number = {5},
+! doi = {10.1016/j.jpdc.2009.01.006}}
+!
+! @ARTICLE{LiPoKoTr04,
+! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
+! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
+! journal={Bull. Seismol. Soc. Am.},
+! year = {2004},
+! volume = {94},
+! pages = {1748-1761},
+! number = {5},
+! doi = {10.1785/012004038}}
+!
+! @INCOLLECTION{ChKoViCaVaFe07,
+! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
+! Yann Capdeville and Bernard Valette and Gaetano Festa},
+! title = {Spectral Element Analysis in Seismology},
+! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
+! publisher = {Elsevier - Academic Press},
+! year = {2007},
+! editor = {Ru-Shan Wu and Val\'erie Maupin},
+! volume = {48},
+! series = {Advances in Geophysics},
+! pages = {365-419}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoLiTrSuStSh04,
+! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
+! and Christiane Stidham and John H. Shaw},
+! year=2004,
+! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
+! based upon the Spectral-Element Method},
+! journal={Bull. Seism. Soc. Am.},
+! volume=94,
+! number=1,
+! pages={187-206}}
+!
+! @ARTICLE{MoTr08,
+! author={C. Morency and J. Tromp},
+! title={Spectral-element simulations of wave propagation in poroelastic media},
+! journal={Geophys. J. Int.},
+! year=2008,
+! volume=175,
+! pages={301-345}}
+!
+! and/or other articles from http://web.univ-pau.fr/~dkomati1/publications.html
+!
+! If you use the kernel capabilities of the code, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! @ARTICLE{MoLuTr09,
+! author={C. Morency and Y. Luo and J. Tromp},
+! title={Finite-frequency kernels for wave propagation in porous media based upon adjoint methods},
+! year=2009,
+! journal={Geophys. J. Int.},
+! doi={10.1111/j.1365-246X.2009.04332}}
+!
+! If you use the METIS / SCOTCH / CUBIT non-structured capabilities, please also cite:
+!
+! @ARTICLE{MaKoBlLe08,
+! author = {R. Martin and D. Komatitsch and C. Blitz and N. {Le Goff}},
+! title = {Simulation of seismic wave propagation in an asteroid based upon
+! an unstructured {MPI} spectral-element method: blocking and non-blocking
+! communication strategies},
+! journal = {Lecture Notes in Computer Science},
+! year = {2008},
+! volume = {5336},
+! pages = {350-363}}
+!
+! version 6.1, Christina Morency and Pieyre Le Loher, March 2010:
+! - added SH (membrane) waves calculation for elastic media
+! - added support for external fully anisotropic media
+! - fixed some bugs in acoustic kernels
+!
+! version 6.0, Christina Morency and Yang Luo, August 2009:
+! - support for poroelastic media
+! - adjoint method for acoustic/elastic/poroelastic
+!
+! version 5.2, Dimitri Komatitsch, Nicolas Le Goff and Roland Martin, February 2008:
+! - support for CUBIT and GiD meshes
+! - MPI implementation of the code based on domain decomposition
+! with METIS or SCOTCH
+! - general fluid/solid implementation with any number, shape and orientation of
+! matching edges
+! - fluid potential of density * displacement instead of displacement
+! - absorbing edges with any normal vector
+! - general numbering of absorbing and acoustic free surface edges
+! - cleaned implementation of attenuation as in Carcione (1993)
+! - merged loops in the solver for efficiency
+! - simplified input of external model
+! - added CPU time information
+! - translated many comments from French to English
+!
+! version 5.1, Dimitri Komatitsch, January 2005:
+! - more general mesher with any number of curved layers
+! - Dirac and Gaussian time sources and corresponding convolution routine
+! - option for acoustic medium instead of elastic
+! - receivers at any location, not only grid points
+! - moment-tensor source at any location, not only a grid point
+! - color snapshots
+! - more flexible DATA/Par_file with any number of comment lines
+! - Xsu scripts for seismograms
+! - subtract t0 from seismograms
+! - seismograms and snapshots in pressure in addition to vector field
+!
+! version 5.0, Dimitri Komatitsch, May 2004:
+! - got rid of useless routines, suppressed commons etc.
+! - weak formulation based explicitly on stress tensor
+! - implementation of full anisotropy
+! - implementation of attenuation based on memory variables
+!
+! based on SPECFEM2D version 4.2, June 1998
+! (c) by Dimitri Komatitsch, Harvard University, USA
+! and Jean-Pierre Vilotte, Institut de Physique du Globe de Paris, France
+!
+! itself based on SPECFEM2D version 1.0, 1995
+! (c) by Dimitri Komatitsch and Jean-Pierre Vilotte,
+! Institut de Physique du Globe de Paris, France
+!
+
+! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
+! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
+! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement is then: u = grad(Chi) / rho
+! Velocity is then: v = grad(Chi_dot) / rho (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+! The source in an acoustic element is a pressure source.
+! First-order acoustic-acoustic discontinuities are also handled automatically
+! because pressure is continuous at such an interface, therefore Chi_dot_dot
+! is continuous, therefore Chi is also continuous, which is consistent with
+! the spectral-element basis functions and with the assembling process.
+! This is the reason why a simple displacement potential u = grad(Chi) would
+! not work because it would be discontinuous at such an interface and would
+! therefore not be consistent with the basis functions.
+
+ program specfem2D
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+! character(len=80) datlin
+
+ integer NSOURCES,i_source
+ integer, dimension(:), allocatable :: source_type,time_function_type
+ double precision, dimension(:), allocatable :: x_source,z_source,xi_source,gamma_source,&
+ Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: sourcearray
+ double precision :: t0
+
+ double precision, dimension(:,:), allocatable :: coorg
+
+! for P-SV or SH (membrane) waves calculation
+ logical :: p_sv
+
+! receiver information
+ integer :: nrec,ios
+ integer, dimension(:), allocatable :: ispec_selected_rec
+ double precision, dimension(:), allocatable :: xi_receiver,gamma_receiver,st_xval,st_zval
+ character(len=150) dummystring
+
+! for seismograms
+ double precision, dimension(:,:), allocatable :: sisux,sisuz,siscurl
+ integer :: seismo_offset, seismo_current
+
+! vector field in an element
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLX) :: vector_field_element
+
+! pressure in an element
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
+
+! curl in an element
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
+
+ integer :: i,j,k,it,irec,id,n,ispec,npoin,npgeo,iglob
+ integer :: npoin_acoustic
+ integer :: npoin_elastic
+ integer :: npoin_poroelastic
+ logical :: anyabs
+ double precision :: dxd,dyd,dzd,dcurld,valux,valuy,valuz,valcurl,hlagrange,rhol,xi,gamma,x,z
+
+! coefficients of the explicit Newmark time scheme
+ integer NSTEP
+ double precision :: deltatover2,deltatsquareover2,time
+ double precision :: deltat
+
+! Gauss-Lobatto-Legendre points and weights
+ double precision, dimension(NGLLX) :: xigll
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
+ double precision, dimension(NGLLZ) :: zigll
+ real(kind=CUSTOM_REAL), dimension(NGLLX) :: wzgll
+
+! derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+! Jacobian matrix and determinant
+ double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the elastic medium
+ double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal
+
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_elastic,veloc_elastic,displ_elastic
+ double precision, dimension(:,:), allocatable :: &
+ coord, flagrange,xinterp,zinterp,Uxinterp,Uzinterp,vector_field_display
+
+! material properties of the poroelastic medium (solid phase:s and fluid phase [defined as w=phi(u_f-u_s)]: w)
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ accels_poroelastic,velocs_poroelastic,displs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ accelw_poroelastic,velocw_poroelastic,displw_poroelastic
+ double precision, dimension(:), allocatable :: porosity,tortuosity
+ double precision, dimension(:,:), allocatable :: density,permeability
+
+! poroelastic and elastic coefficients
+ double precision, dimension(:,:,:), allocatable :: poroelastcoef
+
+! anisotropy parameters
+ logical :: all_anisotropic
+ double precision :: c11,c13,c15,c33,c35,c55
+ logical, dimension(:), allocatable :: anisotropic
+ double precision, dimension(:,:), allocatable :: anisotropy
+
+! for acoustic medium
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
+ potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
+
+! inverse mass matrices
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_inverse_elastic
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_inverse_acoustic
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
+ rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
+
+! to evaluate cpI, cpII, and cs, and rI (poroelastic medium)
+ real(kind=CUSTOM_REAL) :: rhol_s,rhol_f,rhol_bar,phil,tortl
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s
+ real(kind=CUSTOM_REAL) :: kappal_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,B_biot,cpIsquare,cpIIsquare,cssquare
+ real(kind=CUSTOM_REAL) :: ratio,dd1
+
+ double precision, dimension(:,:,:), allocatable :: vpext,vsext,rhoext
+ double precision, dimension(:,:,:), allocatable :: Qp_attenuationext,Qs_attenuationext
+ double precision, dimension(:,:,:), allocatable :: c11ext,c13ext,c15ext,c33ext,c35ext,c55ext
+
+ double precision, dimension(:,:,:), allocatable :: shape2D,shape2D_display
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: xix,xiz,gammax,gammaz,jacobian
+
+ double precision, dimension(:,:,:,:), allocatable :: dershape2D,dershape2D_display
+
+ integer, dimension(:,:,:), allocatable :: ibool,ibool_outer,ibool_inner
+ integer, dimension(:,:), allocatable :: knods
+ integer, dimension(:), allocatable :: kmato,numabs, &
+ ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
+
+ integer, dimension(:), allocatable :: ispec_selected_source,iglob_source,&
+ is_proc_source,nb_proc_source
+ double precision, dimension(:), allocatable :: aval
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: source_time_function
+ double precision, external :: netlib_specfun_erf
+
+ double precision :: vpImin,vpImax,vpIImin,vpIImax
+
+ integer :: colors,numbers,subsamp,imagetype, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NTSTEP_BETWEEN_OUTPUT_SEISMO,seismotype
+ integer :: numat,ngnod,nspec,pointsdisp, &
+ nelemabs,nelem_acoustic_surface,ispecabs,UPPER_LIMIT_DISPLAY
+
+ logical interpol,meshvect,modelvect,boundvect,assign_external_model,initialfield, &
+ outputgrid,gnuplot,TURN_ATTENUATION_ON,output_postscript_snapshot,output_color_image, &
+ plot_lowerleft_corner_only,add_Bielak_conditions,OUTPUT_ENERGY,READ_EXTERNAL_SEP_FILE
+
+ double precision :: cutsnaps,sizemax_arrows,anglerec,xirec,gammarec
+
+! for absorbing and acoustic free surface conditions
+ integer :: ispec_acoustic_surface,inum
+ real(kind=CUSTOM_REAL) :: nx,nz,weight,xxi,zgamma
+
+ logical, dimension(:,:), allocatable :: codeabs
+
+! for attenuation
+ integer :: N_SLS
+ double precision, dimension(:), allocatable :: Qp_attenuation
+ double precision, dimension(:), allocatable :: Qs_attenuation
+ double precision :: f0_attenuation
+ integer nspec_allocate
+ double precision :: deltatsquare,deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: e1,e11,e13
+ double precision, dimension(:,:,:,:), allocatable :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
+ double precision, dimension(:), allocatable :: inv_tau_sigma_nu1_sent,phi_nu1_sent,inv_tau_sigma_nu2_sent,phi_nu2_sent
+ double precision, dimension(:,:,:) , allocatable :: Mu_nu1,Mu_nu2
+ double precision :: Mu_nu1_sent,Mu_nu2_sent
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
+ dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
+
+! for viscous attenuation
+ double precision, dimension(:,:,:), allocatable :: &
+ rx_viscous,rz_viscous,viscox,viscoz
+ double precision :: theta_e,theta_s
+ double precision :: Q0,freq0
+ double precision :: alphaval,betaval,gammaval,thetainv
+ logical :: TURN_VISCATTENUATION_ON
+ double precision, dimension(NGLLX,NGLLZ) :: viscox_loc,viscoz_loc
+ double precision :: Sn,Snp1,etal_f
+ double precision, dimension(3):: bl_relaxed
+ double precision :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
+! adjoint
+ double precision, dimension(:), allocatable :: b_viscodampx,b_viscodampz
+ integer reclen
+
+! for fluid/solid coupling and edge detection
+ logical, dimension(:), allocatable :: elastic
+ integer, dimension(NEDGES) :: i_begin,j_begin,i_end,j_end
+ integer, dimension(NGLLX,NEDGES) :: ivalue,jvalue,ivalue_inverse,jvalue_inverse
+ integer, dimension(:), allocatable :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge, &
+ fluid_solid_elastic_ispec,fluid_solid_elastic_iedge
+ integer :: num_fluid_solid_edges,ispec_acoustic,ispec_elastic, &
+ iedge_acoustic,iedge_elastic,ipoin1D,iglob2
+ logical :: any_acoustic,any_acoustic_glob,any_elastic,any_elastic_glob,coupled_acoustic_elastic
+ real(kind=CUSTOM_REAL) :: displ_x,displ_z,displ_n,displw_x,displw_z,zxi,xgamma,jacobian1D,pressure
+ real(kind=CUSTOM_REAL) :: b_displ_x,b_displ_z,b_displw_x,b_displw_z,b_pressure
+ logical :: any_fluid_solid_edges
+
+! for fluid/porous medium coupling and edge detection
+ logical, dimension(:), allocatable :: poroelastic
+ logical :: any_poroelastic,any_poroelastic_glob
+ integer, dimension(:), allocatable :: fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge, &
+ fluid_poro_poroelastic_ispec,fluid_poro_poroelastic_iedge
+ integer :: num_fluid_poro_edges,iedge_poroelastic
+ logical :: coupled_acoustic_poro
+ double precision :: mul_G,lambdal_G,lambdalplus2mul_G
+ double precision :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ double precision :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ double precision :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ double precision :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
+ double precision :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
+ double precision :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
+ double precision :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
+ double precision :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
+ logical :: any_fluid_poro_edges
+
+! for solid/porous medium coupling and edge detection
+ integer, dimension(:), allocatable :: solid_poro_elastic_ispec,solid_poro_elastic_iedge, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge
+ integer :: num_solid_poro_edges,ispec_poroelastic,ii2,jj2
+ logical :: coupled_elastic_poro
+ integer, dimension(:), allocatable :: icount
+ double precision :: sigma_xx,sigma_xz,sigma_zz,sigmap
+ double precision :: b_sigma_xx,b_sigma_xz,b_sigma_zz,b_sigmap
+ integer, dimension(:), allocatable :: ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,&
+ iend_top_poro,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro
+ logical :: any_solid_poro_edges
+
+! for adjoint method
+ logical :: SAVE_FORWARD ! whether or not the last frame is saved to reconstruct the forward field
+ integer :: SIMULATION_TYPE ! 1 = forward wavefield, 2 = backward and adjoint wavefields and kernels
+ double precision :: b_deltatover2,b_deltatsquareover2,b_deltat ! coefficients of the explicit Newmark time scheme
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accels_poroelastic,b_velocs_poroelastic,b_displs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accelw_poroelastic,b_velocw_poroelastic,b_displw_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accel_elastic,b_veloc_elastic,b_displ_elastic
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_potential_dot_dot_acoustic,b_potential_dot_acoustic,b_potential_acoustic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_ac,b_displ_ac,b_accel_ac
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rho_kl, mu_kl, kappa_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_global, mul_global, kappal_global
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: mu_k, kappa_k,rho_k
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhop_kl, beta_kl, alpha_kl
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rho_ac_kl, kappa_ac_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_ac_global, kappal_ac_global
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhop_ac_kl, alpha_ac_kl
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhot_kl, rhof_kl, sm_kl, eta_kl, mufr_kl, B_kl, &
+ C_kl, M_kl, rhob_kl, rhofb_kl, phi_kl, Bb_kl, Cb_kl, Mb_kl, mufrb_kl, &
+ rhobb_kl, rhofbb_kl, phib_kl, cpI_kl, cpII_kl, cs_kl, ratio_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhot_k, rhof_k, sm_k, eta_k, mufr_k, B_k, &
+ C_k, M_k
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: phil_global,etal_f_global,rhol_s_global,rhol_f_global,rhol_bar_global, &
+ tortl_global,mulfr_global
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: permlxx_global,permlxz_global,permlzz_global
+ character(len=150) :: adj_source_file
+ integer :: irec_local,nadj_rec_local
+ double precision :: xx,zz,rholb,tempx1l,tempx2l,b_tempx1l,b_tempx2l,bb_tempx1l,bb_tempx2l
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: adj_sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_left,b_absorb_poro_s_left,b_absorb_poro_w_left
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_right,b_absorb_poro_s_right,b_absorb_poro_w_right
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_bottom,b_absorb_poro_s_bottom,b_absorb_poro_w_bottom
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_top,b_absorb_poro_s_top,b_absorb_poro_w_top
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_absorb_acoustic_left,b_absorb_acoustic_right,&
+ b_absorb_acoustic_bottom, b_absorb_acoustic_top
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(:), allocatable :: ib_left,ib_right,ib_bottom,ib_top
+
+! for color images
+ integer :: NX_IMAGE_color,NZ_IMAGE_color
+ double precision :: xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image
+ integer, dimension(:,:), allocatable :: iglob_image_color,copy_iglob_image_color
+ double precision, dimension(:,:), allocatable :: image_color_data
+ double precision, dimension(:,:), allocatable :: image_color_vp_display
+ integer :: nb_pixel_loc
+ integer, dimension(:), allocatable :: num_pixel_loc
+
+#ifdef USE_MPI
+ integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
+ integer, dimension(:), allocatable :: nb_pixel_per_proc
+ integer, dimension(:,:), allocatable :: num_pixel_recv
+ double precision, dimension(:), allocatable :: data_pixel_recv
+ double precision, dimension(:), allocatable :: data_pixel_send
+#endif
+
+! timing information for the stations
+ character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
+
+! title of the plot
+ character(len=60) simulation_title
+
+! Lagrange interpolators at receivers
+ double precision, dimension(:), allocatable :: hxir,hgammar,hpxir,hpgammar
+ double precision, dimension(:,:), allocatable :: hxir_store,hgammar_store
+
+! Lagrange interpolators at sources
+ double precision, dimension(:), allocatable :: hxis,hgammas,hpxis,hpgammas
+ double precision, dimension(:,:), allocatable :: hxis_store,hgammas_store
+
+! for Lagrange interpolants
+ double precision, external :: hgll
+
+! timer to count elapsed time
+ double precision :: time_start
+ integer :: year_start,month_start
+
+ ! to determine date and time at which the run will finish
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+
+! for MPI and partitioning
+ integer :: ier
+ integer :: nproc
+ integer :: myrank
+ character(len=150) :: outputname,outputname2
+
+ integer :: ninterface
+ integer :: max_interface_size
+ integer, dimension(:), allocatable :: my_neighbours
+ integer, dimension(:), allocatable :: my_nelmnts_neighbours
+ integer, dimension(:,:,:), allocatable :: my_interfaces
+ integer, dimension(:,:), allocatable :: ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(:), allocatable :: nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
+
+ integer :: ninterface_acoustic, ninterface_elastic,ninterface_poroelastic
+ integer, dimension(:), allocatable :: inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
+
+#ifdef USE_MPI
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_ac
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_ac
+ integer, dimension(:), allocatable :: tab_requests_send_recv_acoustic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_el
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_el
+ integer, dimension(:), allocatable :: tab_requests_send_recv_elastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_pos,buffer_send_faces_vector_pow
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow
+ integer, dimension(:), allocatable :: tab_requests_send_recv_poro
+ integer :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, max_ibool_interfaces_size_po
+ integer :: iproc
+#endif
+
+! for overlapping MPI communications with computation
+ integer :: nspec_outer, nspec_inner, num_ispec_outer, num_ispec_inner
+ integer, dimension(:), allocatable :: ispec_outer_to_glob, ispec_inner_to_glob
+ logical, dimension(:), allocatable :: mask_ispec_inner_outer
+
+ integer, dimension(:,:), allocatable :: acoustic_surface
+ integer, dimension(:,:), allocatable :: acoustic_edges
+ logical :: any_acoustic_edges
+
+ integer :: ixmin, ixmax, izmin, izmax
+
+ integer :: nrecloc, irecloc
+ integer, dimension(:), allocatable :: recloc, which_proc_receiver
+
+! mask to sort ibool
+ integer, dimension(:), allocatable :: mask_ibool
+ integer, dimension(:,:,:), allocatable :: copy_ibool_ori
+ integer :: inumber
+
+! to compute analytical initial plane wave field
+ double precision :: angleforce_refl, c_inc, c_refl, cploc, csloc
+ double precision, dimension(2) :: A_plane, B_plane, C_plane
+ double precision :: z0_source, x0_source, time_offset
+
+! beyond critical angle
+ integer , dimension(:), allocatable :: left_bound,right_bound,bot_bound
+ double precision , dimension(:,:), allocatable :: v0x_left,v0z_left,v0x_right,v0z_right,v0x_bot,v0z_bot
+ double precision , dimension(:,:), allocatable :: t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_paco,veloc_paco,displ_paco
+ integer count_left,count_right,count_bottom
+ logical :: over_critical_angle
+
+! further reduce cache misses inner/outer in two passes in the case of an MPI simulation
+ integer :: ipass,ispec_inner,ispec_outer,NUMBER_OF_PASSES
+ integer :: npoin_outer,npoin_inner
+ integer, dimension(:), allocatable :: perm,antecedent_list,check_perm
+
+! arrays for plotpost
+ integer :: d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
+ d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model
+ double precision, dimension(:,:), allocatable :: coorg_send_ps_velocity_model
+ double precision, dimension(:,:), allocatable :: coorg_recv_ps_velocity_model
+ double precision, dimension(:,:), allocatable :: RGB_send_ps_velocity_model
+ double precision, dimension(:,:), allocatable :: RGB_recv_ps_velocity_model
+ integer :: d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
+ d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh, &
+ d1_color_recv_ps_element_mesh
+ double precision, dimension(:,:), allocatable :: coorg_send_ps_element_mesh
+ double precision, dimension(:,:), allocatable :: coorg_recv_ps_element_mesh
+ integer, dimension(:), allocatable :: color_send_ps_element_mesh
+ integer, dimension(:), allocatable :: color_recv_ps_element_mesh
+ integer :: d1_coorg_send_ps_abs, d2_coorg_send_ps_abs, &
+ d1_coorg_recv_ps_abs, d2_coorg_recv_ps_abs
+ double precision, dimension(:,:), allocatable :: coorg_send_ps_abs
+ double precision, dimension(:,:), allocatable :: coorg_recv_ps_abs
+ integer :: d1_coorg_send_ps_free_surface, d2_coorg_send_ps_free_surface, &
+ d1_coorg_recv_ps_free_surface, d2_coorg_recv_ps_free_surface
+ double precision, dimension(:,:), allocatable :: coorg_send_ps_free_surface
+ double precision, dimension(:,:), allocatable :: coorg_recv_ps_free_surface
+ integer :: d1_coorg_send_ps_vector_field, d2_coorg_send_ps_vector_field, &
+ d1_coorg_recv_ps_vector_field, d2_coorg_recv_ps_vector_field
+ double precision, dimension(:,:), allocatable :: coorg_send_ps_vector_field
+ double precision, dimension(:,:), allocatable :: coorg_recv_ps_vector_field
+
+! tangential detection
+ double precision, dimension(:), allocatable :: anglerec_irec
+ double precision, dimension(:), allocatable :: cosrot_irec, sinrot_irec
+ double precision, dimension(:), allocatable :: x_final_receiver, z_final_receiver
+ logical :: force_normal_to_surface,rec_normal_to_surface
+
+ integer, dimension(:), allocatable :: source_courbe_eros
+
+ integer :: nnodes_tangential_curve
+ double precision, dimension(:,:), allocatable :: nodes_tangential_curve
+ logical :: any_tangential_curve
+
+ integer :: n1_tangential_detection_curve
+ integer, dimension(4) :: n_tangential_detection_curve
+ integer, dimension(:), allocatable :: rec_tangential_detection_curve
+ double precision :: distmin, dist_current, angleforce_recv
+ double precision, dimension(:), allocatable :: dist_tangential_detection_curve
+ double precision :: x_final_receiver_dummy, z_final_receiver_dummy
+!!!!!!!!!!
+ double precision, dimension(:,:,:),allocatable:: rho_local,vp_local,vs_local
+!!!! hessian
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhorho_el_hessian_final1, rhorho_el_hessian_final2
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhorho_el_hessian_temp1, rhorho_el_hessian_temp2
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhorho_ac_hessian_final1, rhorho_ac_hessian_final2
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: weight_line_x, weight_line_z, weight_surface,weight_jacobian
+ integer, dimension(:), allocatable :: weight_gll
+ real(kind=CUSTOM_REAL) :: zmin_yang, zmax_yang, xmin_yang, xmax_yang
+
+! to help locate elements with a negative Jacobian using OpenDX
+ logical :: found_a_negative_jacobian
+
+!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
+ logical, parameter :: ADD_PERIODIC_CONDITIONS = .false.
+
+!! DK DK the periodic conditions below are currently specific to a Gmsh model designed by Paul Cristini
+
+!! DK DK the horizontal periodicity distance is:
+ double precision, parameter :: PERIODIC_horiz_dist = 0.3597d0
+
+!! DK DK the length of an edge is about 1d-003, thus use e.g. 1/300 of that
+ double precision, parameter :: PERIODIC_DETECT_TOL = 1d-003 / 300.d0
+
+ integer, parameter :: NSPEC_PERIO = 670 / 2 ! 414 / 2
+
+ integer, dimension(NSPEC_PERIO) :: numperio_left
+ integer, dimension(NSPEC_PERIO) :: numperio_right
+
+ logical, dimension(4,NSPEC_PERIO) :: codeabs_perio_left
+ logical, dimension(4,NSPEC_PERIO) :: codeabs_perio_right
+
+ integer :: idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
+ integer :: ispecperio, ispecperio2, ispec2, i2, j2
+ integer :: iglob_target_to_replace, ispec3, i3, j3
+
+!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
+
+!***********************************************************************
+!
+! i n i t i a l i z a t i o n p h a s e
+!
+!***********************************************************************
+ call initialize_simulation(nproc,myrank,NUMBER_OF_PASSES, &
+ ninterface_acoustic,ninterface_elastic,ninterface_poroelastic)
+
+
+ ! reduction of cache misses inner/outer in two passes
+ do ipass = 1,NUMBER_OF_PASSES
+
+ ! starts reading in Database file
+ call read_databases_init(myrank,ipass, &
+ simulation_title,SIMULATION_TYPE,SAVE_FORWARD,npgeo, &
+ gnuplot,interpol,NTSTEP_BETWEEN_OUTPUT_INFO, &
+ output_postscript_snapshot,output_color_image,colors,numbers, &
+ meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows, &
+ anglerec,initialfield,add_Bielak_conditions, &
+ seismotype,imagetype,assign_external_model,READ_EXTERNAL_SEP_FILE, &
+ outputgrid,OUTPUT_ENERGY,TURN_ATTENUATION_ON, &
+ TURN_VISCATTENUATION_ON,Q0,freq0,p_sv, &
+ NSTEP,deltat,NTSTEP_BETWEEN_OUTPUT_SEISMO,NSOURCES)
+
+ !
+ !--- source information
+ !
+ if(ipass == 1) then
+ allocate( source_type(NSOURCES) )
+ allocate( time_function_type(NSOURCES) )
+ allocate( x_source(NSOURCES) )
+ allocate( z_source(NSOURCES) )
+ allocate( f0(NSOURCES) )
+ allocate( tshift_src(NSOURCES) )
+ allocate( factor(NSOURCES) )
+ allocate( angleforce(NSOURCES) )
+ allocate( Mxx(NSOURCES) )
+ allocate( Mxz(NSOURCES) )
+ allocate( Mzz(NSOURCES) )
+ allocate( aval(NSOURCES) )
+ allocate( ispec_selected_source(NSOURCES) )
+ allocate( iglob_source(NSOURCES) )
+ allocate( source_courbe_eros(NSOURCES) )
+ allocate( xi_source(NSOURCES) )
+ allocate( gamma_source(NSOURCES) )
+ allocate( is_proc_source(NSOURCES) )
+ allocate( nb_proc_source(NSOURCES) )
+ allocate( sourcearray(NSOURCES,NDIM,NGLLX,NGLLZ) )
+ endif
+
+ ! reads in source infos
+ call read_databases_sources(NSOURCES,source_type,time_function_type, &
+ x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce)
+
+ ! sets source parameters
+ call set_sources(myrank,NSOURCES,source_type,time_function_type, &
+ x_source,z_source,Mxx,Mzz,Mxz,f0,tshift_src,factor,angleforce,aval, &
+ t0,initialfield,ipass,deltat)
+
+ !
+ !---- read attenuation information
+ !
+ call read_databases_atten(N_SLS,f0_attenuation)
+
+ ! if source is not a Dirac or Heavyside then f0_attenuation is f0 of the first source
+ if(.not. (time_function_type(1) == 4 .or. time_function_type(1) == 5)) then
+ f0_attenuation = f0(1)
+ endif
+
+
+ !
+ !---- read the spectral macrobloc nodal coordinates
+ !
+ if(ipass == 1) allocate(coorg(NDIM,npgeo))
+
+ ! reads the spectral macrobloc nodal coordinates
+ ! and basic properties of the spectral elements
+ call read_databases_coorg_elem(myrank,ipass,npgeo,coorg,numat,ngnod,nspec, &
+ pointsdisp,plot_lowerleft_corner_only, &
+ nelemabs,nelem_acoustic_surface, &
+ num_fluid_solid_edges,num_fluid_poro_edges, &
+ num_solid_poro_edges,nnodes_tangential_curve)
+
+
+ !
+ !---- allocate arrays
+ !
+ if(ipass == 1) then
+ allocate(shape2D(ngnod,NGLLX,NGLLZ))
+ allocate(dershape2D(NDIM,ngnod,NGLLX,NGLLZ))
+ allocate(shape2D_display(ngnod,pointsdisp,pointsdisp))
+ allocate(dershape2D_display(NDIM,ngnod,pointsdisp,pointsdisp))
+ allocate(xix(NGLLX,NGLLZ,nspec))
+ allocate(xiz(NGLLX,NGLLZ,nspec))
+ allocate(gammax(NGLLX,NGLLZ,nspec))
+ allocate(gammaz(NGLLX,NGLLZ,nspec))
+ allocate(jacobian(NGLLX,NGLLZ,nspec))
+ allocate(flagrange(NGLLX,pointsdisp))
+ allocate(xinterp(pointsdisp,pointsdisp))
+ allocate(zinterp(pointsdisp,pointsdisp))
+ allocate(Uxinterp(pointsdisp,pointsdisp))
+ allocate(Uzinterp(pointsdisp,pointsdisp))
+ allocate(density(2,numat))
+ allocate(anisotropy(6,numat))
+ allocate(porosity(numat))
+ allocate(tortuosity(numat))
+ allocate(permeability(3,numat))
+ allocate(poroelastcoef(4,3,numat))
+ allocate(Qp_attenuation(numat))
+ allocate(Qs_attenuation(numat))
+ allocate(kmato(nspec))
+ allocate(knods(ngnod,nspec))
+ allocate(ibool(NGLLX,NGLLZ,nspec))
+ allocate(elastic(nspec))
+ allocate(poroelastic(nspec))
+ allocate(anisotropic(nspec))
+ allocate(inv_tau_sigma_nu1(NGLLX,NGLLZ,nspec,N_SLS))
+ allocate(inv_tau_sigma_nu2(NGLLX,NGLLZ,nspec,N_SLS))
+ allocate(phi_nu1(NGLLX,NGLLZ,nspec,N_SLS))
+ allocate(phi_nu2(NGLLX,NGLLZ,nspec,N_SLS))
+ allocate(inv_tau_sigma_nu1_sent(N_SLS))
+ allocate(inv_tau_sigma_nu2_sent(N_SLS))
+ allocate(phi_nu1_sent(N_SLS))
+ allocate(phi_nu2_sent(N_SLS))
+ endif
+
+ !
+ !---- read the material properties
+ !
+ call gmat01(density,porosity,tortuosity,anisotropy,permeability,poroelastcoef,numat,&
+ myrank,ipass,Qp_attenuation,Qs_attenuation,freq0,Q0,f0(1),TURN_VISCATTENUATION_ON)
+ !
+ !---- read spectral macrobloc data
+ !
+ if(ipass == 1) then
+ allocate(antecedent_list(nspec))
+ allocate(perm(nspec))
+ endif
+ call read_databases_mato(ipass,nspec,ngnod,kmato,knods, &
+ perm,antecedent_list)
+
+
+!-------------------------------------------------------------------------------
+!---- determine if each spectral element is elastic, poroelastic, or acoustic
+!-------------------------------------------------------------------------------
+ ! initializes
+ any_acoustic = .false.
+ any_elastic = .false.
+ any_poroelastic = .false.
+
+ anisotropic(:) = .false.
+ elastic(:) = .false.
+ poroelastic(:) = .false.
+
+ ! loops over all elements
+ do ispec = 1,nspec
+
+ if( nint(porosity(kmato(ispec))) == 1 ) then
+ ! acoustic domain
+ elastic(ispec) = .false.
+ poroelastic(ispec) = .false.
+ any_acoustic = .true.
+ elseif( porosity(kmato(ispec)) < TINYVAL) then
+ ! elastic domain
+ elastic(ispec) = .true.
+ poroelastic(ispec) = .false.
+ any_elastic = .true.
+ if(any(anisotropy(:,kmato(ispec)) /= 0)) then
+ anisotropic(ispec) = .true.
+ end if
+ else
+ ! poroelastic domain
+ elastic(ispec) = .false.
+ poroelastic(ispec) = .true.
+ any_poroelastic = .true.
+ endif
+
+ enddo !do ispec = 1,nspec
+
+
+ if(.not. p_sv .and. .not. any_elastic) then
+ print*, '*************** WARNING ***************'
+ print*, 'Surface (membrane) waves calculation needs an elastic medium'
+ print*, '*************** WARNING ***************'
+ stop
+ endif
+ if(.not. p_sv .and. (TURN_ATTENUATION_ON)) then
+ print*, '*************** WARNING ***************'
+ print*, 'Attenuation and anisotropy are not implemented for surface (membrane) waves calculation'
+ print*, '*************** WARNING ***************'
+ stop
+ endif
+
+
+ if(TURN_ATTENUATION_ON) then
+ nspec_allocate = nspec
+ else
+ nspec_allocate = 1
+ endif
+
+! allocate memory variables for attenuation
+ if(ipass == 1) then
+ allocate(e1(NGLLX,NGLLZ,nspec_allocate,N_SLS))
+ allocate(e11(NGLLX,NGLLZ,nspec_allocate,N_SLS))
+ allocate(e13(NGLLX,NGLLZ,nspec_allocate,N_SLS))
+ e1(:,:,:,:) = 0._CUSTOM_REAL
+ e11(:,:,:,:) = 0._CUSTOM_REAL
+ e13(:,:,:,:) = 0._CUSTOM_REAL
+
+ allocate(dux_dxl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dzl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dxl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dzl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(Mu_nu1(NGLLX,NGLLZ,nspec))
+ allocate(Mu_nu2(NGLLX,NGLLZ,nspec))
+ endif
+
+! define the attenuation quality factors.
+! they can be different for each element.
+!! DK DK if needed in the future, here the quality factor could be different for each point
+ do ispec = 1,nspec
+ call attenuation_model(N_SLS,Qp_attenuation(kmato(ispec)),Qs_attenuation(kmato(ispec)), &
+ f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
+ inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent)
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ inv_tau_sigma_nu1(i,j,ispec,:) = inv_tau_sigma_nu1_sent(:)
+ phi_nu1(i,j,ispec,:) = phi_nu1_sent(:)
+ inv_tau_sigma_nu2(i,j,ispec,:) = inv_tau_sigma_nu2_sent(:)
+ phi_nu2(i,j,ispec,:) = phi_nu2_sent(:)
+ Mu_nu1(i,j,ispec) = Mu_nu1_sent
+ Mu_nu2(i,j,ispec) = Mu_nu2_sent
+ enddo
+ enddo
+ enddo
+
+! allocate memory variables for viscous attenuation (poroelastic media)
+ if(ipass == 1) then
+ if(TURN_VISCATTENUATION_ON) then
+ allocate(rx_viscous(NGLLX,NGLLZ,nspec))
+ allocate(rz_viscous(NGLLX,NGLLZ,nspec))
+ allocate(viscox(NGLLX,NGLLZ,nspec))
+ allocate(viscoz(NGLLX,NGLLZ,nspec))
+ else
+ allocate(rx_viscous(NGLLX,NGLLZ,1))
+ allocate(rz_viscous(NGLLX,NGLLZ,1))
+ allocate(viscox(NGLLX,NGLLZ,1))
+ allocate(viscoz(NGLLX,NGLLZ,1))
+ endif
+ endif
+
+ !
+ !---- read interfaces data
+ !
+ call read_databases_ninterface(ninterface,max_interface_size)
+ if ( ninterface > 0 ) then
+ if(ipass == 1) then
+ allocate(my_neighbours(ninterface))
+ allocate(my_nelmnts_neighbours(ninterface))
+ allocate(my_interfaces(4,max_interface_size,ninterface))
+ allocate(ibool_interfaces_acoustic(NGLLX*max_interface_size,ninterface))
+ allocate(ibool_interfaces_elastic(NGLLX*max_interface_size,ninterface))
+ allocate(ibool_interfaces_poroelastic(NGLLX*max_interface_size,ninterface))
+ allocate(nibool_interfaces_acoustic(ninterface))
+ allocate(nibool_interfaces_elastic(ninterface))
+ allocate(nibool_interfaces_poroelastic(ninterface))
+ allocate(inum_interfaces_acoustic(ninterface))
+ allocate(inum_interfaces_elastic(ninterface))
+ allocate(inum_interfaces_poroelastic(ninterface))
+ endif
+ call read_databases_interfaces(ipass,ninterface,nspec,max_interface_size, &
+ my_neighbours,my_nelmnts_neighbours,my_interfaces, &
+ perm,antecedent_list)
+
+ endif
+
+
+! --- allocate arrays for absorbing boundary conditions
+
+ if(nelemabs <= 0) then
+ nelemabs = 1
+ anyabs = .false.
+ else
+ anyabs = .true.
+ endif
+
+ if(ipass == 1) then
+ allocate(numabs(nelemabs))
+ allocate(codeabs(4,nelemabs))
+
+ allocate(ibegin_bottom(nelemabs))
+ allocate(iend_bottom(nelemabs))
+ allocate(ibegin_top(nelemabs))
+ allocate(iend_top(nelemabs))
+
+ allocate(jbegin_left(nelemabs))
+ allocate(jend_left(nelemabs))
+ allocate(jbegin_right(nelemabs))
+ allocate(jend_right(nelemabs))
+
+ allocate(ibegin_bottom_poro(nelemabs))
+ allocate(iend_bottom_poro(nelemabs))
+ allocate(ibegin_top_poro(nelemabs))
+ allocate(iend_top_poro(nelemabs))
+
+ allocate(jbegin_left_poro(nelemabs))
+ allocate(jend_left_poro(nelemabs))
+ allocate(jbegin_right_poro(nelemabs))
+ allocate(jend_right_poro(nelemabs))
+
+ allocate(ib_left(nelemabs))
+ allocate(ib_right(nelemabs))
+ allocate(ib_bottom(nelemabs))
+ allocate(ib_top(nelemabs))
+
+ endif
+
+ !
+ !---- read absorbing boundary data
+ !
+ call read_databases_absorbing(myrank,ipass,nelemabs,nspec,anyabs, &
+ ibegin_bottom,iend_bottom,jbegin_right,jend_right, &
+ ibegin_top,iend_top,jbegin_left,jend_left, &
+ numabs,codeabs,perm,antecedent_list, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ ib_right,ib_left,ib_bottom,ib_top)
+
+
+ if( anyabs ) then
+ ! Files to save absorbed waves needed to reconstruct backward wavefield for adjoint method
+ if(ipass == 1) then
+ if(any_elastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 2)) then
+ allocate(b_absorb_elastic_left(3,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_elastic_right(3,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_elastic_bottom(3,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_elastic_top(3,NGLLX,nspec_zmax,NSTEP))
+ else
+ allocate(b_absorb_elastic_left(1,1,1,1))
+ allocate(b_absorb_elastic_right(1,1,1,1))
+ allocate(b_absorb_elastic_bottom(1,1,1,1))
+ allocate(b_absorb_elastic_top(1,1,1,1))
+ endif
+ if(any_poroelastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 2)) then
+ allocate(b_absorb_poro_s_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_poro_s_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_poro_s_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_poro_s_top(NDIM,NGLLX,nspec_zmax,NSTEP))
+ allocate(b_absorb_poro_w_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_poro_w_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_poro_w_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_poro_w_top(NDIM,NGLLX,nspec_zmax,NSTEP))
+ else
+ allocate(b_absorb_poro_s_left(1,1,1,1))
+ allocate(b_absorb_poro_s_right(1,1,1,1))
+ allocate(b_absorb_poro_s_bottom(1,1,1,1))
+ allocate(b_absorb_poro_s_top(1,1,1,1))
+ allocate(b_absorb_poro_w_left(1,1,1,1))
+ allocate(b_absorb_poro_w_right(1,1,1,1))
+ allocate(b_absorb_poro_w_bottom(1,1,1,1))
+ allocate(b_absorb_poro_w_top(1,1,1,1))
+ endif
+ if(any_acoustic .and. (SAVE_FORWARD .or. SIMULATION_TYPE == 2)) then
+ allocate(b_absorb_acoustic_left(NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_acoustic_right(NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_acoustic_bottom(NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_acoustic_top(NGLLX,nspec_zmax,NSTEP))
+ else
+ allocate(b_absorb_acoustic_left(1,1,1))
+ allocate(b_absorb_acoustic_right(1,1,1))
+ allocate(b_absorb_acoustic_bottom(1,1,1))
+ allocate(b_absorb_acoustic_top(1,1,1))
+ endif
+ endif
+
+ else
+
+ if(.not. allocated(b_absorb_elastic_left)) then
+ allocate(b_absorb_elastic_left(1,1,1,1))
+ allocate(b_absorb_elastic_right(1,1,1,1))
+ allocate(b_absorb_elastic_bottom(1,1,1,1))
+ allocate(b_absorb_elastic_top(1,1,1,1))
+ endif
+
+ if(.not. allocated(b_absorb_poro_s_left)) then
+ allocate(b_absorb_poro_s_left(1,1,1,1))
+ allocate(b_absorb_poro_s_right(1,1,1,1))
+ allocate(b_absorb_poro_s_bottom(1,1,1,1))
+ allocate(b_absorb_poro_s_top(1,1,1,1))
+ allocate(b_absorb_poro_w_left(1,1,1,1))
+ allocate(b_absorb_poro_w_right(1,1,1,1))
+ allocate(b_absorb_poro_w_bottom(1,1,1,1))
+ allocate(b_absorb_poro_w_top(1,1,1,1))
+ endif
+
+ if(.not. allocated(b_absorb_acoustic_left)) then
+ allocate(b_absorb_acoustic_left(1,1,1))
+ allocate(b_absorb_acoustic_right(1,1,1))
+ allocate(b_absorb_acoustic_bottom(1,1,1))
+ allocate(b_absorb_acoustic_top(1,1,1))
+ endif
+
+ endif
+
+!
+!---- read acoustic free surface data
+!
+ if(nelem_acoustic_surface > 0) then
+ any_acoustic_edges = .true.
+ else
+ any_acoustic_edges = .false.
+ nelem_acoustic_surface = 1
+ endif
+ if( ipass == 1 ) then
+ allocate(acoustic_edges(4,nelem_acoustic_surface))
+ allocate(acoustic_surface(5,nelem_acoustic_surface))
+ endif
+ call read_databases_free_surf(ipass,nelem_acoustic_surface,nspec, &
+ acoustic_edges,perm,antecedent_list,any_acoustic_edges)
+ ! resets nelem_acoustic_surface
+ if( any_acoustic_edges .eqv. .false. ) nelem_acoustic_surface = 0
+
+ ! constructs acoustic surface
+ if(nelem_acoustic_surface > 0) then
+ call construct_acoustic_surface ( nspec, ngnod, knods, nelem_acoustic_surface, &
+ acoustic_edges, acoustic_surface)
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
+ endif
+ endif
+
+
+ !
+ !---- read coupled edges
+ !
+ if( num_fluid_solid_edges > 0 ) then
+ any_fluid_solid_edges = .true.
+ else
+ any_fluid_solid_edges = .false.
+ num_fluid_solid_edges = 1
+ endif
+ if(ipass == 1) then
+ allocate(fluid_solid_acoustic_ispec(num_fluid_solid_edges))
+ allocate(fluid_solid_acoustic_iedge(num_fluid_solid_edges))
+ allocate(fluid_solid_elastic_ispec(num_fluid_solid_edges))
+ allocate(fluid_solid_elastic_iedge(num_fluid_solid_edges))
+ endif
+ if( num_fluid_poro_edges > 0 ) then
+ any_fluid_poro_edges = .true.
+ else
+ any_fluid_poro_edges = .false.
+ num_fluid_poro_edges = 1
+ endif
+ if(ipass == 1) then
+ allocate(fluid_poro_acoustic_ispec(num_fluid_poro_edges))
+ allocate(fluid_poro_acoustic_iedge(num_fluid_poro_edges))
+ allocate(fluid_poro_poroelastic_ispec(num_fluid_poro_edges))
+ allocate(fluid_poro_poroelastic_iedge(num_fluid_poro_edges))
+ endif
+ if ( num_solid_poro_edges > 0 ) then
+ any_solid_poro_edges = .true.
+ else
+ any_solid_poro_edges = .false.
+ num_solid_poro_edges = 1
+ endif
+ if(ipass == 1) then
+ allocate(solid_poro_elastic_ispec(num_solid_poro_edges))
+ allocate(solid_poro_elastic_iedge(num_solid_poro_edges))
+ allocate(solid_poro_poroelastic_ispec(num_solid_poro_edges))
+ allocate(solid_poro_poroelastic_iedge(num_solid_poro_edges))
+ endif
+
+ call read_databases_coupled(ipass,nspec,num_fluid_solid_edges,any_fluid_solid_edges, &
+ fluid_solid_acoustic_ispec,fluid_solid_elastic_ispec, &
+ num_fluid_poro_edges,any_fluid_poro_edges, &
+ fluid_poro_acoustic_ispec,fluid_poro_poroelastic_ispec, &
+ num_solid_poro_edges,any_solid_poro_edges, &
+ solid_poro_elastic_ispec,solid_poro_poroelastic_ispec, &
+ perm,antecedent_list)
+
+ ! resets counters
+ if( any_fluid_solid_edges .eqv. .false. ) num_fluid_solid_edges = 0
+ if( any_fluid_poro_edges .eqv. .false. ) num_fluid_poro_edges = 0
+ if( any_solid_poro_edges .eqv. .false. ) num_solid_poro_edges = 0
+
+
+ !
+ !---- read tangential detection curve
+ ! and close Database file
+ !
+ if (nnodes_tangential_curve > 0) then
+ any_tangential_curve = .true.
+ else
+ any_tangential_curve = .false.
+ nnodes_tangential_curve = 1
+ endif
+ if (ipass == 1) then
+ allocate(nodes_tangential_curve(2,nnodes_tangential_curve))
+ allocate(dist_tangential_detection_curve(nnodes_tangential_curve))
+ endif
+ call read_databases_final(nnodes_tangential_curve,nodes_tangential_curve, &
+ force_normal_to_surface,rec_normal_to_surface, &
+ any_tangential_curve)
+ ! resets nnode_tangential_curve
+ if( any_tangential_curve .eqv. .false. ) nnodes_tangential_curve = 0
+
+!
+!---- compute shape functions and their derivatives for SEM grid
+!
+
+! set up Gauss-Lobatto-Legendre derivation matrices
+ call define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ call define_shape_functions(shape2D(:,i,j),dershape2D(:,:,i,j),xigll(i),zigll(j),ngnod)
+ enddo
+ enddo
+
+!
+!---- generate the global numbering
+!
+
+! "slow and clean" or "quick and dirty" version
+ if(FAST_NUMBERING) then
+ call createnum_fast(knods,ibool,shape2D,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
+ else
+ call createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
+ endif
+
+! create a new indirect addressing array to reduce cache misses in memory access in the solver
+ if(ipass == 2) then
+
+ deallocate(perm)
+
+ allocate(copy_ibool_ori(NGLLX,NGLLZ,nspec))
+ allocate(mask_ibool(npoin))
+
+ print *
+ print *,'Xmin,Xmax of the whole mesh = ',minval(coord(1,:)),maxval(coord(1,:))
+ print *,'Zmin,Zmax of the whole mesh = ',minval(coord(2,:)),maxval(coord(2,:))
+ print *
+
+!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
+
+ if(ADD_PERIODIC_CONDITIONS) then
+
+#ifdef USE_MPI
+ stop 'periodic conditions currently implemented for a serial simulation only (due e.g. to mass matrix rebuilding)'
+#endif
+
+ if(any_poroelastic .or. any_acoustic) stop 'periodic conditions currently implemented for purely elastic models only'
+
+ if(ACTUALLY_IMPLEMENT_PERM_OUT .or. ACTUALLY_IMPLEMENT_PERM_INN .or. ACTUALLY_IMPLEMENT_PERM_WHOLE) &
+ stop 'currently, all permutations should be off for periodic conditions'
+
+print *
+open(unit=123,file='Database00000_left_edge_only',status='old')
+do ispecperio = 1,NSPEC_PERIO
+ read(123,*) numperio_left(ispecperio), &
+ codeabs_perio_left(IBOTTOM,ispecperio), &
+ codeabs_perio_left(IRIGHT,ispecperio), &
+ codeabs_perio_left(ITOP,ispecperio), &
+ codeabs_perio_left(ILEFT,ispecperio), &
+ idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
+enddo
+close(123)
+print *,'read ',NSPEC_PERIO,' elements for left periodic edge'
+
+open(unit=123,file='Database00000_right_edge_only',status='old')
+do ispecperio = 1,NSPEC_PERIO
+ read(123,*) numperio_right(ispecperio), &
+ codeabs_perio_right(IBOTTOM,ispecperio), &
+ codeabs_perio_right(IRIGHT,ispecperio), &
+ codeabs_perio_right(ITOP,ispecperio), &
+ codeabs_perio_right(ILEFT,ispecperio), &
+ idummy1, idummy2, idummy3, idummy4, idummy5, idummy6, idummy7, idummy8
+enddo
+close(123)
+print *,'read ',NSPEC_PERIO,' elements for right periodic edge'
+print *
+
+print *,'because of periodic conditions, values computed by checkgrid() are not reliable'
+print *
+
+!---------------------------------------------------------------------------
+
+ do ispecperio = 1,NSPEC_PERIO
+
+ ispec = numperio_left(ispecperio)
+
+! print *,'dist of edge is ',sqrt((coord(2,ibool(1,1,ispec)) - coord(2,ibool(1,NGLLZ,ispec))) ** 2 + &
+! (coord(1,ibool(1,1,ispec)) - coord(1,ibool(1,NGLLZ,ispec))) ** 2)
+
+ if(codeabs_perio_left(ILEFT,ispecperio)) then
+ i = 1
+ do j = 1,NGLLZ
+ iglob = ibool(i,j,ispec)
+!----------------------------------------------------------------------
+ include "include_for_periodic_conditions.f90"
+!----------------------------------------------------------------------
+ enddo
+ endif
+
+ if(codeabs_perio_left(IRIGHT,ispecperio)) then
+ i = NGLLX
+ do j = 1,NGLLZ
+ iglob = ibool(i,j,ispec)
+!----------------------------------------------------------------------
+ include "include_for_periodic_conditions.f90"
+!----------------------------------------------------------------------
+ enddo
+ endif
+
+ if(codeabs_perio_left(IBOTTOM,ispecperio)) then
+ j = 1
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+!----------------------------------------------------------------------
+ include "include_for_periodic_conditions.f90"
+!----------------------------------------------------------------------
+ enddo
+ endif
+
+ if(codeabs_perio_left(ITOP,ispecperio)) then
+ j = NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+!----------------------------------------------------------------------
+ include "include_for_periodic_conditions.f90"
+!----------------------------------------------------------------------
+ enddo
+ endif
+
+ enddo
+
+! rebuild the mass matrix based on this new numbering
+!
+!---- build the global mass matrix and invert it once and for all
+!
+ rmass_inverse_elastic(:) = 0._CUSTOM_REAL
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+
+ ! if external density model (elastic or acoustic)
+ if(assign_external_model) then
+ rhol = rhoext(i,j,ispec)
+ kappal = rhol * vpext(i,j,ispec)**2
+ else
+ rhol = density(1,kmato(ispec))
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
+ kappal = lambdal_relaxed + 2.d0/3.d0*mul_relaxed
+ endif
+
+ rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) &
+ + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
+
+ enddo
+ enddo
+ enddo ! do ispec = 1,nspec
+
+! invert the mass matrix once and for all
+! set entries that are equal to zero to something else, e.g. 1, to avoid division by zero
+! these degrees of freedom correspond to points that have been replaced with their periodic counterpart
+! and thus are not used any more
+ where(rmass_inverse_elastic == 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
+ rmass_inverse_elastic(:) = 1._CUSTOM_REAL / rmass_inverse_elastic(:)
+
+ endif ! of if(ADD_PERIODIC_CONDITIONS)
+
+!! DK DK Feb 2010 for periodic conditions: detect common points between left and right edges
+
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:) = ibool(:,:,:)
+
+ inumber = 0
+
+ if(.not. ACTUALLY_IMPLEMENT_PERM_WHOLE) then
+
+! first reduce cache misses in outer elements, since they are taken first
+! loop over spectral elements
+ do ispec = 1,nspec_outer
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
+ ! create a new point
+ inumber = inumber + 1
+ ibool(i,j,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
+ else
+ ! use an existing point created previously
+ ibool(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+
+! then reduce cache misses in inner elements, since they are taken second
+! loop over spectral elements
+ do ispec = nspec_outer+1,nspec
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
+ ! create a new point
+ inumber = inumber + 1
+ ibool(i,j,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
+ else
+ ! use an existing point created previously
+ ibool(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+
+ else ! if ACTUALLY_IMPLEMENT_PERM_WHOLE
+
+! reduce cache misses in all the elements
+! loop over spectral elements
+ do ispec = 1,nspec
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
+ ! create a new point
+ inumber = inumber + 1
+ ibool(i,j,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
+ else
+ ! use an existing point created previously
+ ibool(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ deallocate(copy_ibool_ori)
+ deallocate(mask_ibool)
+
+ else if(ipass /= 1) then
+
+ stop 'incorrect pass number for reduction of cache misses'
+
+ endif ! ipass
+
+!---- compute shape functions and their derivatives for regular interpolated display grid
+ do j = 1,pointsdisp
+ do i = 1,pointsdisp
+ xirec = 2.d0*dble(i-1)/dble(pointsdisp-1) - 1.d0
+ gammarec = 2.d0*dble(j-1)/dble(pointsdisp-1) - 1.d0
+ call define_shape_functions(shape2D_display(:,i,j),dershape2D_display(:,:,i,j),xirec,gammarec,ngnod)
+ enddo
+ enddo
+
+!---- compute Lagrange interpolants on a regular interpolated grid in (xi,gamma)
+!---- for display (assumes NGLLX = NGLLZ)
+ do j=1,NGLLX
+ do i=1,pointsdisp
+ xirec = 2.d0*dble(i-1)/dble(pointsdisp-1) - 1.d0
+ flagrange(j,i) = hgll(j-1,xirec,xigll,NGLLX)
+ enddo
+ enddo
+
+! get number of stations from receiver file
+ open(unit=IIN,file='DATA/STATIONS_target',iostat=ios,status='old',action='read')
+ nrec = 0
+ do while(ios == 0)
+ read(IIN,"(a)",iostat=ios) dummystring
+ if(ios == 0) nrec = nrec + 1
+ enddo
+ close(IIN)
+
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Total number of receivers = ',nrec
+ write(IOUT,*)
+ endif
+
+ if(nrec < 1) call exit_MPI('need at least one receiver')
+
+! receiver information
+ if(ipass == 1) then
+
+ allocate(ispec_selected_rec(nrec))
+ allocate(st_xval(nrec))
+ allocate(st_zval(nrec))
+ allocate(xi_receiver(nrec))
+ allocate(gamma_receiver(nrec))
+ allocate(station_name(nrec))
+ allocate(network_name(nrec))
+ allocate(recloc(nrec))
+ allocate(which_proc_receiver(nrec))
+ allocate(x_final_receiver(nrec))
+ allocate(z_final_receiver(nrec))
+
+! allocate 1-D Lagrange interpolators and derivatives
+ allocate(hxir(NGLLX))
+ allocate(hxis(NGLLX))
+ allocate(hpxir(NGLLX))
+ allocate(hpxis(NGLLX))
+ allocate(hgammar(NGLLZ))
+ allocate(hgammas(NGLLZ))
+ allocate(hpgammar(NGLLZ))
+ allocate(hpgammas(NGLLZ))
+
+! allocate Lagrange interpolators for receivers
+ allocate(hxir_store(nrec,NGLLX))
+ allocate(hgammar_store(nrec,NGLLZ))
+
+! allocate Lagrange interpolators for sources
+ allocate(hxis_store(NSOURCES,NGLLX))
+ allocate(hgammas_store(NSOURCES,NGLLZ))
+
+! allocate other global arrays
+ allocate(coord(NDIM,npoin))
+
+! to display acoustic elements
+ allocate(vector_field_display(3,npoin))
+
+! if(assign_external_model) then
+
+! note: so far, full external array needed/defined in subroutine calls
+ allocate(vpext(NGLLX,NGLLZ,nspec))
+ allocate(vsext(NGLLX,NGLLZ,nspec))
+ allocate(rhoext(NGLLX,NGLLZ,nspec))
+ allocate(Qp_attenuationext(NGLLX,NGLLZ,nspec))
+ allocate(Qs_attenuationext(NGLLX,NGLLZ,nspec))
+ allocate(c11ext(NGLLX,NGLLZ,nspec))
+ allocate(c13ext(NGLLX,NGLLZ,nspec))
+ allocate(c15ext(NGLLX,NGLLZ,nspec))
+ allocate(c33ext(NGLLX,NGLLZ,nspec))
+ allocate(c35ext(NGLLX,NGLLZ,nspec))
+ allocate(c55ext(NGLLX,NGLLZ,nspec))
+! else
+! allocate(vpext(1,1,1))
+! allocate(vsext(1,1,1))
+! allocate(rhoext(1,1,1))
+! allocate(c11ext(1,1,1))
+! allocate(c13ext(1,1,1))
+! allocate(c15ext(1,1,1))
+! allocate(c33ext(1,1,1))
+! allocate(c35ext(1,1,1))
+! allocate(c55ext(1,1,1))
+! endif
+
+ endif
+
+!
+!---- set the coordinates of the points of the global grid
+!
+ found_a_negative_jacobian = .false.
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ xi = xigll(i)
+ gamma = zigll(j)
+
+ call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
+ jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
+ .false.)
+
+ if(jacobianl <= ZERO) found_a_negative_jacobian = .true.
+
+ coord(1,ibool(i,j,ispec)) = x
+ coord(2,ibool(i,j,ispec)) = z
+
+ xix(i,j,ispec) = xixl
+ xiz(i,j,ispec) = xizl
+ gammax(i,j,ispec) = gammaxl
+ gammaz(i,j,ispec) = gammazl
+ jacobian(i,j,ispec) = jacobianl
+
+ enddo
+ enddo
+ enddo
+
+! create an OpenDX file containing all the negative elements displayed in red, if any
+! this allows users to locate problems in a mesh based on the OpenDX file created at the second iteration
+! do not create OpenDX files if no negative Jacobian has been found, or if we are running in parallel
+! (because writing OpenDX routines is much easier in serial)
+ if(found_a_negative_jacobian .and. nproc == 1) then
+ call save_openDX_jacobian(nspec,npgeo,ngnod,knods,coorg,xigll,zigll)
+ endif
+
+! stop the code at the first negative element found, because such a mesh cannot be computed
+ if(found_a_negative_jacobian) then
+
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ xi = xigll(i)
+ gamma = zigll(j)
+
+ call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl, &
+ jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
+ .true.)
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! yang output weights for line, surface integrals !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!define_derivation_matrices(xigll(NGLLX),zigll(NGLLZ),wxgll(NGLLX),wzgll(NGLLZ),hprime_xx(NGLLX,NGLLX),hprime_zz(NGLLZ,NGLLZ),&
+! hprimewgll_xx(NGLLX,NGLLX),hprimewgll_zz(NGLLZ,NGLLZ))
+!xix(NGLLX,NGLLZ,nspec),xiz,gammax,gammaz,jacobian
+!recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl,jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo, &
+! .true.)
+ allocate(weight_line_x(npoin))
+ allocate(weight_line_z(npoin))
+ allocate(weight_surface(npoin))
+ allocate(weight_jacobian(npoin))
+ allocate(weight_gll(npoin))
+ weight_line_x=0.0
+ weight_line_z=0.0
+ weight_surface=0.0
+ zmin_yang=minval(coord(2,:))
+ xmin_yang=minval(coord(1,:))
+ zmax_yang=maxval(coord(2,:))
+ xmax_yang=maxval(coord(1,:))
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob=ibool(i,j,ispec)
+ z=coord(2,ibool(i,j,ispec))
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ if ((j==1 .OR. j==NGLLZ) .AND. ( (abs(z-zmin_yang).GE.1) .AND. (abs(z-zmax_yang)).GE.1) ) xxi=xxi/2.0
+ if ((i==1 .OR. i==NGLLZ) .AND. ( (abs(x-xmin_yang).GE.1) .AND. (abs(x-xmax_yang)).GE.1) ) zgamma=zgamma/2.0
+ weight_line_x(iglob) = weight_line_x(iglob) + xxi * wxgll(i)
+ weight_line_z(iglob) = weight_line_z(iglob) + zgamma * wzgll(j)
+ weight_surface(iglob) = weight_surface(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec)
+ weight_jacobian(iglob) = jacobian(i,j,ispec)
+ weight_gll(iglob) = 10*j+i
+ enddo
+ enddo
+ enddo
+ open(unit=55,file='OUTPUT_FILES/x_z_weightLineX_weightLineZ_weightSurface',status='unknown')
+ do n = 1,npoin
+ write(55,*) coord(1,n), coord(2,n), weight_line_x(n), weight_line_z(n), weight_surface(n),weight_jacobian(n),weight_gll(n)
+ enddo
+ close(55)
+ deallocate(weight_line_x)
+ deallocate(weight_line_z)
+ deallocate(weight_surface)
+ deallocate(weight_jacobian)
+ deallocate(weight_gll)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!--- save the grid of points in a file
+!
+ if(outputgrid .and. myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving the grid in a text file...'
+ write(IOUT,*)
+ open(unit=55,file='OUTPUT_FILES/grid_points_and_model.txt',status='unknown')
+ write(55,*) npoin
+ do n = 1,npoin
+ write(55,*) (coord(i,n), i=1,NDIM)
+ enddo
+ close(55)
+ endif
+
+!
+!----- plot the GLL mesh in a Gnuplot file
+!
+ if(gnuplot .and. myrank == 0 .and. ipass == 1) &
+ call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
+
+ if(myrank == 0 .and. ipass == 1) &
+ write(IOUT,*) 'assign_external_model = ', assign_external_model
+
+!if ( assign_external_model .and. ipass == 1) then
+ if ( assign_external_model) then
+ call read_external_model(any_acoustic,any_elastic,any_poroelastic, &
+ elastic,poroelastic,anisotropic,nspec,npoin,N_SLS,ibool, &
+ f0_attenuation,inv_tau_sigma_nu1_sent,phi_nu1_sent, &
+ inv_tau_sigma_nu2_sent,phi_nu2_sent,Mu_nu1_sent,Mu_nu2_sent, &
+ inv_tau_sigma_nu1,inv_tau_sigma_nu2,phi_nu1,phi_nu2,Mu_nu1,Mu_nu2,&
+ coord,kmato,myrank,rhoext,vpext,vsext, &
+ Qp_attenuationext,Qs_attenuationext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,READ_EXTERNAL_SEP_FILE)
+ end if
+
+!
+!---- perform basic checks on parameters read
+!
+ all_anisotropic = .false.
+ if(count(anisotropic(:) .eqv. .true.) == nspec) all_anisotropic = .true.
+
+ if(all_anisotropic .and. anyabs) &
+ call exit_MPI('Cannot put absorbing boundaries if anisotropic materials along edges')
+
+ if(TURN_ATTENUATION_ON .and. all_anisotropic) then
+ call exit_MPI('Cannot turn attenuation on in anisotropic materials')
+ end if
+
+ ! global domain flags
+ any_elastic_glob = any_elastic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(any_elastic, any_elastic_glob, 1, MPI_LOGICAL, &
+ MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ any_poroelastic_glob = any_poroelastic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, &
+ MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ any_acoustic_glob = any_acoustic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(any_acoustic, any_acoustic_glob, 1, MPI_LOGICAL, &
+ MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ ! for acoustic
+ if(TURN_ATTENUATION_ON .and. .not. any_elastic_glob) &
+ call exit_MPI('currently cannot have attenuation if acoustic/poroelastic simulation only')
+
+!
+!---- define coefficients of the Newmark time scheme
+!
+ deltatover2 = HALF*deltat
+ deltatsquareover2 = HALF*deltat*deltat
+
+ if(SIMULATION_TYPE == 2) then
+! define coefficients of the Newmark time scheme for the backward wavefield
+ b_deltat = - deltat
+ b_deltatover2 = HALF*b_deltat
+ b_deltatsquareover2 = HALF*b_deltat*b_deltat
+ endif
+
+!---- define actual location of source and receivers
+
+ call setup_sources_receivers(NSOURCES,initialfield,source_type,&
+ coord,ibool,npoin,nspec,nelem_acoustic_surface,acoustic_surface,elastic,poroelastic, &
+ x_source,z_source,ispec_selected_source,ispec_selected_rec, &
+ is_proc_source,nb_proc_source,ipass,&
+ sourcearray,Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,npgeo,&
+ nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod, &
+ nrec,nrecloc,recloc,which_proc_receiver,st_xval,st_zval, &
+ xi_receiver,gamma_receiver,station_name,network_name,x_final_receiver,z_final_receiver,iglob_source)
+
+! compute source array for adjoint source
+ if(SIMULATION_TYPE == 2) then ! adjoint calculation
+ nadj_rec_local = 0
+ do irec = 1,nrec
+ if(myrank == which_proc_receiver(irec))then
+! check that the source proc number is okay
+ if(which_proc_receiver(irec) < 0 .or. which_proc_receiver(irec) > NPROC-1) &
+ call exit_MPI('something is wrong with the source proc number in adjoint simulation')
+ nadj_rec_local = nadj_rec_local + 1
+ endif
+ enddo
+ if(ipass == 1) allocate(adj_sourcearray(NSTEP,3,NGLLX,NGLLZ))
+ if (nadj_rec_local > 0 .and. ipass == 1) then
+ allocate(adj_sourcearrays(nadj_rec_local,NSTEP,3,NGLLX,NGLLZ))
+ else if (ipass == 1) then
+ allocate(adj_sourcearrays(1,1,1,1,1))
+ endif
+
+ irec_local = 0
+ do irec = 1, nrec
+! compute only adjoint source arrays in the local proc
+ if(myrank == which_proc_receiver(irec))then
+ irec_local = irec_local + 1
+ adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+ call compute_arrays_adj_source(adj_source_file, &
+ xi_receiver(irec), gamma_receiver(irec), &
+ adj_sourcearray, xigll,zigll,NSTEP)
+ adj_sourcearrays(irec_local,:,:,:,:) = adj_sourcearray(:,:,:,:)
+ endif
+ enddo
+ else if (ipass == 1) then
+ allocate(adj_sourcearrays(1,1,1,1,1))
+ endif
+
+ if (ipass == 1) then
+ if (nrecloc > 0) then
+ allocate(anglerec_irec(nrecloc))
+ allocate(cosrot_irec(nrecloc))
+ allocate(sinrot_irec(nrecloc))
+ allocate(rec_tangential_detection_curve(nrecloc))
+ else
+ allocate(anglerec_irec(1))
+ allocate(cosrot_irec(1))
+ allocate(sinrot_irec(1))
+ allocate(rec_tangential_detection_curve(1))
+ endif
+
+ if (rec_normal_to_surface .and. abs(anglerec) > 1.d-6) &
+ stop 'anglerec should be zero when receivers are normal to the topography'
+
+ anglerec_irec(:) = anglerec * pi / 180.d0
+ cosrot_irec(:) = cos(anglerec_irec(:))
+ sinrot_irec(:) = sin(anglerec_irec(:))
+ endif
+
+!
+!--- tangential computation
+!
+ if (ipass == NUMBER_OF_PASSES) then
+
+! for receivers
+ if (rec_normal_to_surface) then
+ irecloc = 0
+ do irec = 1, nrec
+ if (which_proc_receiver(irec) == myrank) then
+ irecloc = irecloc + 1
+ distmin = HUGEVAL
+ do i = 1, nnodes_tangential_curve
+ dist_current = sqrt((x_final_receiver(irec)-nodes_tangential_curve(1,i))**2 + &
+ (z_final_receiver(irec)-nodes_tangential_curve(2,i))**2)
+ if ( dist_current < distmin ) then
+ n1_tangential_detection_curve = i
+ distmin = dist_current
+ endif
+ enddo
+
+ rec_tangential_detection_curve(irecloc) = n1_tangential_detection_curve
+ call tri_quad(n_tangential_detection_curve, n1_tangential_detection_curve, &
+ nnodes_tangential_curve)
+
+ call compute_normal_vector( anglerec_irec(irecloc), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(1)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(2)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(3)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(4)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(1)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(2)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(3)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(4)) )
+ endif
+
+ enddo
+ cosrot_irec(:) = cos(anglerec_irec(:))
+ sinrot_irec(:) = sin(anglerec_irec(:))
+ endif
+
+! for the source
+ if (force_normal_to_surface) then
+
+ do i_source=1,NSOURCES
+ if (is_proc_source(i_source) == 1) then
+ distmin = HUGEVAL
+ do i = 1, nnodes_tangential_curve
+ dist_current = sqrt((coord(1,iglob_source(i_source))-nodes_tangential_curve(1,i))**2 + &
+ (coord(2,iglob_source(i_source))-nodes_tangential_curve(2,i))**2)
+ if ( dist_current < distmin ) then
+ n1_tangential_detection_curve = i
+ distmin = dist_current
+
+ endif
+ enddo
+
+ call tri_quad(n_tangential_detection_curve, n1_tangential_detection_curve, &
+ nnodes_tangential_curve)
+
+ ! in the case of a source force vector
+ ! users can give an angle with respect to the normal to the topography surface,
+ ! in which case we must compute the normal to the topography
+ ! and add it the existing rotation angle
+ call compute_normal_vector( angleforce(i_source), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(1)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(2)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(3)), &
+ nodes_tangential_curve(1,n_tangential_detection_curve(4)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(1)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(2)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(3)), &
+ nodes_tangential_curve(2,n_tangential_detection_curve(4)) )
+
+ source_courbe_eros(i_source) = n1_tangential_detection_curve
+ if ( myrank == 0 .and. is_proc_source(i_source) == 1 .and. nb_proc_source(i_source) == 1 ) then
+ source_courbe_eros(i_source) = n1_tangential_detection_curve
+ angleforce_recv = angleforce(i_source)
+#ifdef USE_MPI
+ else if ( myrank == 0 ) then
+ do i = 1, nb_proc_source(i_source) - is_proc_source(i_source)
+ call MPI_recv(source_courbe_eros(i_source),1,MPI_INTEGER, &
+ MPI_ANY_SOURCE,42,MPI_COMM_WORLD,request_mpi_status,ier)
+ call MPI_recv(angleforce_recv,1,MPI_DOUBLE_PRECISION, &
+ MPI_ANY_SOURCE,43,MPI_COMM_WORLD,request_mpi_status,ier)
+ enddo
+ else if ( is_proc_source(i_source) == 1 ) then
+ call MPI_send(n1_tangential_detection_curve,1,MPI_INTEGER,0,42,MPI_COMM_WORLD,ier)
+ call MPI_send(angleforce(i_source),1,MPI_DOUBLE_PRECISION,0,43,MPI_COMM_WORLD,ier)
+#endif
+ endif
+
+#ifdef USE_MPI
+ call MPI_bcast(angleforce_recv,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ angleforce(i_source) = angleforce_recv
+#endif
+ endif ! if (is_proc_source(i_source) == 1)
+ enddo ! do i_source=1,NSOURCES
+ endif ! if (force_normal_to_surface)
+
+! CHRIS --- how to deal with multiple source. Use first source now. ---
+! compute distance from source to receivers following the curve
+ if (force_normal_to_surface .and. rec_normal_to_surface) then
+ dist_tangential_detection_curve(source_courbe_eros(1)) = 0
+ do i = source_courbe_eros(1)+1, nnodes_tangential_curve
+ dist_tangential_detection_curve(i) = dist_tangential_detection_curve(i-1) + &
+ sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i-1))**2 + &
+ (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i-1))**2)
+ enddo
+ dist_tangential_detection_curve(1) = dist_tangential_detection_curve(nnodes_tangential_curve) + &
+ sqrt((nodes_tangential_curve(1,1)-nodes_tangential_curve(1,nnodes_tangential_curve))**2 + &
+ (nodes_tangential_curve(2,1)-nodes_tangential_curve(2,nnodes_tangential_curve))**2)
+ do i = 2, source_courbe_eros(1)-1
+ dist_tangential_detection_curve(i) = dist_tangential_detection_curve(i-1) + &
+ sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i-1))**2 + &
+ (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i-1))**2)
+ enddo
+ do i = source_courbe_eros(1)-1, 1, -1
+ dist_current = dist_tangential_detection_curve(i+1) + &
+ sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i+1))**2 + &
+ (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i+1))**2)
+ if ( dist_current < dist_tangential_detection_curve(i) ) then
+ dist_tangential_detection_curve(i) = dist_current
+ endif
+ enddo
+ dist_current = dist_tangential_detection_curve(1) + &
+ sqrt((nodes_tangential_curve(1,1)-nodes_tangential_curve(1,nnodes_tangential_curve))**2 + &
+ (nodes_tangential_curve(2,1)-nodes_tangential_curve(2,nnodes_tangential_curve))**2)
+ if ( dist_current < dist_tangential_detection_curve(nnodes_tangential_curve) ) then
+ dist_tangential_detection_curve(nnodes_tangential_curve) = dist_current
+ endif
+ do i = nnodes_tangential_curve-1, source_courbe_eros(1)+1, -1
+ dist_current = dist_tangential_detection_curve(i+1) + &
+ sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i+1))**2 + &
+ (nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i+1))**2)
+ if ( dist_current < dist_tangential_detection_curve(i) ) then
+ dist_tangential_detection_curve(i) = dist_current
+ endif
+ enddo
+
+ if ( myrank == 0 ) then
+ open(unit=11,file='OUTPUT_FILES/dist_rec_tangential_detection_curve', &
+ form='formatted', status='unknown')
+ endif
+ irecloc = 0
+ do irec = 1,nrec
+
+ if ( myrank == 0 ) then
+ if ( which_proc_receiver(irec) == myrank ) then
+ irecloc = irecloc + 1
+ n1_tangential_detection_curve = rec_tangential_detection_curve(irecloc)
+ x_final_receiver_dummy = x_final_receiver(irec)
+ z_final_receiver_dummy = z_final_receiver(irec)
+#ifdef USE_MPI
+ else
+
+ call MPI_RECV(n1_tangential_detection_curve,1,MPI_INTEGER,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,request_mpi_status,ier)
+ call MPI_RECV(x_final_receiver_dummy,1,MPI_DOUBLE_PRECISION,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,request_mpi_status,ier)
+ call MPI_RECV(z_final_receiver_dummy,1,MPI_DOUBLE_PRECISION,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,request_mpi_status,ier)
+
+#endif
+ endif
+
+#ifdef USE_MPI
+ else
+ if ( which_proc_receiver(irec) == myrank ) then
+ irecloc = irecloc + 1
+ call MPI_SEND(rec_tangential_detection_curve(irecloc),1,MPI_INTEGER,0,irec,MPI_COMM_WORLD,ier)
+ call MPI_SEND(x_final_receiver(irec),1,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ier)
+ call MPI_SEND(z_final_receiver(irec),1,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ier)
+ endif
+#endif
+
+ endif
+ if ( myrank == 0 ) then
+ write(11,*) dist_tangential_detection_curve(n1_tangential_detection_curve)
+ write(12,*) x_final_receiver_dummy
+ write(13,*) z_final_receiver_dummy
+ endif
+ enddo
+
+ if ( myrank == 0 ) then
+ close(11)
+ close(12)
+ close(13)
+ endif
+
+ endif ! force_normal_to_surface
+
+ endif ! ipass
+
+!
+!---
+!
+
+! allocate seismogram arrays
+ if(ipass == 1) then
+ allocate(sisux(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
+ allocate(sisuz(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
+ allocate(siscurl(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc))
+ endif
+
+! check if acoustic receiver is exactly on the free surface because pressure is zero there
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+ ispec = acoustic_surface(1,ispec_acoustic_surface)
+ ixmin = acoustic_surface(2,ispec_acoustic_surface)
+ ixmax = acoustic_surface(3,ispec_acoustic_surface)
+ izmin = acoustic_surface(4,ispec_acoustic_surface)
+ izmax = acoustic_surface(5,ispec_acoustic_surface)
+ do irecloc = 1,nrecloc
+ irec = recloc(irecloc)
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
+ if ( (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==NGLLX .and. &
+ gamma_receiver(irec) < -0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==NGLLX .and. &
+ gamma_receiver(irec) > 0.99d0) .or.&
+ (izmin==1 .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
+ xi_receiver(irec) < -0.99d0) .or.&
+ (izmin==1 .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ xi_receiver(irec) > 0.99d0) .or.&
+ (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==1 .and. &
+ gamma_receiver(irec) < -0.99d0 .and. xi_receiver(irec) < -0.99d0) .or.&
+ (izmin==1 .and. izmax==1 .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ gamma_receiver(irec) < -0.99d0 .and. xi_receiver(irec) > 0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==1 .and. &
+ gamma_receiver(irec) > 0.99d0 .and. xi_receiver(irec) < -0.99d0) .or.&
+ (izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==NGLLX .and. ixmax==NGLLX .and. &
+ gamma_receiver(irec) > 0.99d0 .and. xi_receiver(irec) > 0.99d0) ) then
+ if(seismotype == 4) then
+ call exit_MPI('an acoustic pressure receiver cannot be located exactly '// &
+ 'on the free surface because pressure is zero there')
+ else
+ print *, '**********************************************************************'
+ print *, '*** Warning: acoustic receiver located exactly on the free surface ***'
+ print *, '*** Warning: tangential component will be zero there ***'
+ print *, '**********************************************************************'
+ print *
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+! define and store Lagrange interpolators at all the receivers
+ do irec = 1,nrec
+ call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
+ hxir_store(irec,:) = hxir(:)
+ hgammar_store(irec,:) = hgammar(:)
+ enddo
+
+! define and store Lagrange interpolators at all the sources
+ do i = 1,NSOURCES
+ call lagrange_any(xi_source(i),NGLLX,xigll,hxis,hpxis)
+ call lagrange_any(gamma_source(i),NGLLZ,zigll,hgammas,hpgammas)
+ hxis_store(i,:) = hxis(:)
+ hgammas_store(i,:) = hgammas(:)
+ enddo
+
+! displacement, velocity, acceleration and inverse of the mass matrix for elastic elements
+ if(ipass == 1) then
+
+ if(any_elastic) then
+ npoin_elastic = npoin
+ else
+ ! allocate unused arrays with fictitious size
+ npoin_elastic = 1
+ endif
+ allocate(displ_elastic(3,npoin_elastic))
+ allocate(veloc_elastic(3,npoin_elastic))
+ allocate(accel_elastic(3,npoin_elastic))
+ allocate(rmass_inverse_elastic(npoin_elastic))
+
+ ! extra array if adjoint and kernels calculation
+ if(SIMULATION_TYPE == 2 .and. any_elastic) then
+ allocate(b_displ_elastic(3,npoin))
+ allocate(b_veloc_elastic(3,npoin))
+ allocate(b_accel_elastic(3,npoin))
+ allocate(rho_kl(NGLLX,NGLLZ,nspec))
+ allocate(rho_k(npoin))
+ allocate(rhol_global(npoin))
+ allocate(mu_kl(NGLLX,NGLLZ,nspec))
+ allocate(mu_k(npoin))
+ allocate(mul_global(npoin))
+ allocate(kappa_kl(NGLLX,NGLLZ,nspec))
+ allocate(kappa_k(npoin))
+ allocate(kappal_global(npoin))
+ allocate(rhop_kl(NGLLX,NGLLZ,nspec))
+ allocate(alpha_kl(NGLLX,NGLLZ,nspec))
+ allocate(beta_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhorho_el_hessian_final2(NGLLX,NGLLZ,nspec))
+ allocate(rhorho_el_hessian_temp2(npoin))
+ allocate(rhorho_el_hessian_final1(NGLLX,NGLLZ,nspec))
+ allocate(rhorho_el_hessian_temp1(npoin))
+ else
+ allocate(b_displ_elastic(1,1))
+ allocate(b_veloc_elastic(1,1))
+ allocate(b_accel_elastic(1,1))
+ allocate(rho_kl(1,1,1))
+ allocate(rho_k(1))
+ allocate(rhol_global(1))
+ allocate(mu_kl(1,1,1))
+ allocate(mu_k(1))
+ allocate(mul_global(1))
+ allocate(kappa_kl(1,1,1))
+ allocate(kappa_k(1))
+ allocate(kappal_global(1))
+ allocate(rhop_kl(1,1,1))
+ allocate(alpha_kl(1,1,1))
+ allocate(beta_kl(1,1,1))
+ allocate(rhorho_el_hessian_final2(1,1,1))
+ allocate(rhorho_el_hessian_temp2(1))
+ allocate(rhorho_el_hessian_final1(1,1,1))
+ allocate(rhorho_el_hessian_temp1(1))
+ endif
+
+ if(any_poroelastic) then
+ npoin_poroelastic = npoin
+ else
+ ! allocate unused arrays with fictitious size
+ npoin_poroelastic = 1
+ endif
+ allocate(displs_poroelastic(NDIM,npoin_poroelastic))
+ allocate(velocs_poroelastic(NDIM,npoin_poroelastic))
+ allocate(accels_poroelastic(NDIM,npoin_poroelastic))
+ allocate(rmass_s_inverse_poroelastic(npoin_poroelastic))
+ allocate(displw_poroelastic(NDIM,npoin_poroelastic))
+ allocate(velocw_poroelastic(NDIM,npoin_poroelastic))
+ allocate(accelw_poroelastic(NDIM,npoin_poroelastic))
+ allocate(rmass_w_inverse_poroelastic(npoin_poroelastic))
+
+ ! extra array if adjoint and kernels calculation
+ if(SIMULATION_TYPE == 2 .and. any_poroelastic) then
+ allocate(b_displs_poroelastic(NDIM,npoin))
+ allocate(b_velocs_poroelastic(NDIM,npoin))
+ allocate(b_accels_poroelastic(NDIM,npoin))
+ allocate(b_displw_poroelastic(NDIM,npoin))
+ allocate(b_velocw_poroelastic(NDIM,npoin))
+ allocate(b_accelw_poroelastic(NDIM,npoin))
+ allocate(rhot_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhot_k(npoin))
+ allocate(rhof_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhof_k(npoin))
+ allocate(sm_kl(NGLLX,NGLLZ,nspec))
+ allocate(sm_k(npoin))
+ allocate(eta_kl(NGLLX,NGLLZ,nspec))
+ allocate(eta_k(npoin))
+ allocate(mufr_kl(NGLLX,NGLLZ,nspec))
+ allocate(mufr_k(npoin))
+ allocate(B_kl(NGLLX,NGLLZ,nspec))
+ allocate(B_k(npoin))
+ allocate(C_kl(NGLLX,NGLLZ,nspec))
+ allocate(C_k(npoin))
+ allocate(M_kl(NGLLX,NGLLZ,nspec))
+ allocate(M_k(npoin))
+ allocate(rhob_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhofb_kl(NGLLX,NGLLZ,nspec))
+ allocate(phi_kl(NGLLX,NGLLZ,nspec))
+ allocate(Bb_kl(NGLLX,NGLLZ,nspec))
+ allocate(Cb_kl(NGLLX,NGLLZ,nspec))
+ allocate(Mb_kl(NGLLX,NGLLZ,nspec))
+ allocate(mufrb_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhobb_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhofbb_kl(NGLLX,NGLLZ,nspec))
+ allocate(phib_kl(NGLLX,NGLLZ,nspec))
+ allocate(cpI_kl(NGLLX,NGLLZ,nspec))
+ allocate(cpII_kl(NGLLX,NGLLZ,nspec))
+ allocate(cs_kl(NGLLX,NGLLZ,nspec))
+ allocate(ratio_kl(NGLLX,NGLLZ,nspec))
+ allocate(phil_global(npoin))
+ allocate(mulfr_global(npoin))
+ allocate(etal_f_global(npoin))
+ allocate(rhol_s_global(npoin))
+ allocate(rhol_f_global(npoin))
+ allocate(rhol_bar_global(npoin))
+ allocate(tortl_global(npoin))
+ allocate(permlxx_global(npoin))
+ allocate(permlxz_global(npoin))
+ allocate(permlzz_global(npoin))
+ else
+ allocate(b_displs_poroelastic(1,1))
+ allocate(b_velocs_poroelastic(1,1))
+ allocate(b_accels_poroelastic(1,1))
+ allocate(b_displw_poroelastic(1,1))
+ allocate(b_velocw_poroelastic(1,1))
+ allocate(b_accelw_poroelastic(1,1))
+ allocate(rhot_kl(1,1,1))
+ allocate(rhot_k(1))
+ allocate(rhof_kl(1,1,1))
+ allocate(rhof_k(1))
+ allocate(sm_kl(1,1,1))
+ allocate(sm_k(1))
+ allocate(eta_kl(1,1,1))
+ allocate(eta_k(1))
+ allocate(mufr_kl(1,1,1))
+ allocate(mufr_k(1))
+ allocate(B_kl(1,1,1))
+ allocate(B_k(1))
+ allocate(C_kl(1,1,1))
+ allocate(C_k(1))
+ allocate(M_kl(1,1,1))
+ allocate(M_k(1))
+ allocate(rhob_kl(1,1,1))
+ allocate(rhofb_kl(1,1,1))
+ allocate(phi_kl(1,1,1))
+ allocate(Bb_kl(1,1,1))
+ allocate(Cb_kl(1,1,1))
+ allocate(Mb_kl(1,1,1))
+ allocate(mufrb_kl(1,1,1))
+ allocate(rhobb_kl(1,1,1))
+ allocate(rhofbb_kl(1,1,1))
+ allocate(phib_kl(1,1,1))
+ allocate(cpI_kl(1,1,1))
+ allocate(cpII_kl(1,1,1))
+ allocate(cs_kl(1,1,1))
+ allocate(ratio_kl(1,1,1))
+ allocate(phil_global(1))
+ allocate(mulfr_global(1))
+ allocate(etal_f_global(1))
+ allocate(rhol_s_global(1))
+ allocate(rhol_f_global(1))
+ allocate(rhol_bar_global(1))
+ allocate(tortl_global(1))
+ allocate(permlxx_global(1))
+ allocate(permlxz_global(1))
+ allocate(permlzz_global(1))
+ endif
+
+ if(any_poroelastic .and. any_elastic) then
+ allocate(icount(npoin))
+ else
+ allocate(icount(1))
+ endif
+
+ ! potential, its first and second derivative, and inverse of the mass matrix for acoustic elements
+ if(any_acoustic) then
+ npoin_acoustic = npoin
+ else
+ ! allocate unused arrays with fictitious size
+ npoin_acoustic = 1
+ endif
+ allocate(potential_acoustic(npoin_acoustic))
+ allocate(potential_dot_acoustic(npoin_acoustic))
+ allocate(potential_dot_dot_acoustic(npoin_acoustic))
+ allocate(rmass_inverse_acoustic(npoin_acoustic))
+
+ if(SIMULATION_TYPE == 2 .and. any_acoustic) then
+ allocate(b_potential_acoustic(npoin))
+ allocate(b_potential_dot_acoustic(npoin))
+ allocate(b_potential_dot_dot_acoustic(npoin))
+ allocate(b_displ_ac(2,npoin))
+ allocate(b_accel_ac(2,npoin))
+ allocate(accel_ac(2,npoin))
+ allocate(rho_ac_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhol_ac_global(npoin))
+ allocate(kappa_ac_kl(NGLLX,NGLLZ,nspec))
+ allocate(kappal_ac_global(npoin))
+ allocate(rhop_ac_kl(NGLLX,NGLLZ,nspec))
+ allocate(alpha_ac_kl(NGLLX,NGLLZ,nspec))
+ allocate(rhorho_ac_hessian_final2(NGLLX,NGLLZ,nspec))
+ allocate(rhorho_ac_hessian_final1(NGLLX,NGLLZ,nspec))
+ else
+ ! allocate unused arrays with fictitious size
+ allocate(b_potential_acoustic(1))
+ allocate(b_potential_dot_acoustic(1))
+ allocate(b_potential_dot_dot_acoustic(1))
+ allocate(b_displ_ac(1,1))
+ allocate(b_accel_ac(1,1))
+ allocate(accel_ac(1,1))
+ allocate(rho_ac_kl(1,1,1))
+ allocate(rhol_ac_global(1))
+ allocate(kappa_ac_kl(1,1,1))
+ allocate(kappal_ac_global(1))
+ allocate(rhop_ac_kl(1,1,1))
+ allocate(alpha_ac_kl(1,1,1))
+ allocate(rhorho_ac_hessian_final2(1,1,1))
+ allocate(rhorho_ac_hessian_final1(1,1,1))
+ endif
+
+ endif ! ipass == 1
+
+ !
+ !---- build the global mass matrix
+ !
+ call invert_mass_matrix_init(any_elastic,any_acoustic,any_poroelastic, &
+ rmass_inverse_elastic,npoin_elastic, &
+ rmass_inverse_acoustic,npoin_acoustic, &
+ rmass_s_inverse_poroelastic, &
+ rmass_w_inverse_poroelastic,npoin_poroelastic, &
+ nspec,ibool,kmato,wxgll,wzgll,jacobian, &
+ elastic,poroelastic, &
+ assign_external_model,numat, &
+ density,poroelastcoef,porosity,tortuosity, &
+ vpext,rhoext)
+
+
+
+#ifdef USE_MPI
+ if ( nproc > 1 ) then
+
+ ! preparing for MPI communications
+ if(ipass == 1) allocate(mask_ispec_inner_outer(nspec))
+ mask_ispec_inner_outer(:) = .false.
+
+ call get_MPI(nspec,ibool,knods,ngnod,npoin,elastic,poroelastic, &
+ ninterface, max_interface_size, &
+ my_nelmnts_neighbours,my_interfaces,my_neighbours, &
+ ibool_interfaces_acoustic, ibool_interfaces_elastic, &
+ ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic, nibool_interfaces_elastic, &
+ nibool_interfaces_poroelastic, &
+ inum_interfaces_acoustic, inum_interfaces_elastic, &
+ inum_interfaces_poroelastic, &
+ ninterface_acoustic, ninterface_elastic, ninterface_poroelastic, &
+ mask_ispec_inner_outer, &
+ myrank,ipass,coord)
+
+
+ nspec_outer = count(mask_ispec_inner_outer)
+ nspec_inner = nspec - nspec_outer
+
+ if(ipass == 1) then
+ allocate(ispec_outer_to_glob(nspec_outer))
+ allocate(ispec_inner_to_glob(nspec_inner))
+ endif
+
+ ! building of corresponding arrays between inner/outer elements and their global number
+ if(ipass == 1) then
+ num_ispec_outer = 0
+ num_ispec_inner = 0
+ do ispec = 1, nspec
+ if ( mask_ispec_inner_outer(ispec) ) then
+ num_ispec_outer = num_ispec_outer + 1
+ ispec_outer_to_glob(num_ispec_outer) = ispec
+ else
+ num_ispec_inner = num_ispec_inner + 1
+ ispec_inner_to_glob(num_ispec_inner) = ispec
+ endif
+ enddo
+ endif
+
+ ! buffers for MPI communications
+ max_ibool_interfaces_size_ac = maxval(nibool_interfaces_acoustic(:))
+ max_ibool_interfaces_size_el = 3*maxval(nibool_interfaces_elastic(:))
+ max_ibool_interfaces_size_po = NDIM*maxval(nibool_interfaces_poroelastic(:))
+ if(ipass == 1) then
+ allocate(tab_requests_send_recv_acoustic(ninterface_acoustic*2))
+ allocate(buffer_send_faces_vector_ac(max_ibool_interfaces_size_ac,ninterface_acoustic))
+ allocate(buffer_recv_faces_vector_ac(max_ibool_interfaces_size_ac,ninterface_acoustic))
+ allocate(tab_requests_send_recv_elastic(ninterface_elastic*2))
+ allocate(buffer_send_faces_vector_el(max_ibool_interfaces_size_el,ninterface_elastic))
+ allocate(buffer_recv_faces_vector_el(max_ibool_interfaces_size_el,ninterface_elastic))
+ allocate(tab_requests_send_recv_poro(ninterface_poroelastic*4))
+ allocate(buffer_send_faces_vector_pos(max_ibool_interfaces_size_po,ninterface_poroelastic))
+ allocate(buffer_recv_faces_vector_pos(max_ibool_interfaces_size_po,ninterface_poroelastic))
+ allocate(buffer_send_faces_vector_pow(max_ibool_interfaces_size_po,ninterface_poroelastic))
+ allocate(buffer_recv_faces_vector_pow(max_ibool_interfaces_size_po,ninterface_poroelastic))
+ endif
+
+! assembling the mass matrix
+ call assemble_MPI_scalar(rmass_inverse_acoustic,npoin_acoustic, &
+ rmass_inverse_elastic,npoin_elastic, &
+ rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic,npoin_poroelastic, &
+ ninterface, max_interface_size, max_ibool_interfaces_size_ac, &
+ max_ibool_interfaces_size_el, &
+ max_ibool_interfaces_size_po, &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic, &
+ ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic,nibool_interfaces_elastic, &
+ nibool_interfaces_poroelastic,my_neighbours)
+
+ else
+ ninterface_acoustic = 0
+ ninterface_elastic = 0
+ ninterface_poroelastic = 0
+
+ num_ispec_outer = 0
+ num_ispec_inner = 0
+ if(ipass == 1) allocate(mask_ispec_inner_outer(1))
+
+ nspec_outer = 0
+ nspec_inner = nspec
+
+ if(ipass == 1) allocate(ispec_inner_to_glob(nspec_inner))
+ do ispec = 1, nspec
+ ispec_inner_to_glob(ispec) = ispec
+ enddo
+
+ endif ! end of test on wether there is more than one process (nproc > 1)
+
+#else
+ num_ispec_outer = 0
+ num_ispec_inner = 0
+ if(ipass == 1) allocate(mask_ispec_inner_outer(1))
+
+ nspec_outer = 0
+ nspec_inner = nspec
+
+ if(ipass == 1) then
+ allocate(ispec_outer_to_glob(1))
+ allocate(ispec_inner_to_glob(nspec_inner))
+ endif
+ do ispec = 1, nspec
+ ispec_inner_to_glob(ispec) = ispec
+ enddo
+
+#endif
+
+ if(ipass == 1) then
+
+ ! allocate(antecedent_list(nspec))
+
+ ! loop over spectral elements
+ do ispec_outer = 1,nspec_outer
+ ! get global numbering for inner or outer elements
+ ispec = ispec_outer_to_glob(ispec_outer)
+ antecedent_list(ispec) = ispec_outer
+ enddo
+
+ ! loop over spectral elements
+ do ispec_inner = 1,nspec_inner
+ ! get global numbering for inner or outer elements
+ ispec = ispec_inner_to_glob(ispec_inner)
+ antecedent_list(ispec) = nspec_outer + ispec_inner
+ enddo
+
+ allocate(ibool_outer(NGLLX,NGLLZ,nspec_outer))
+ allocate(ibool_inner(NGLLX,NGLLZ,nspec_inner))
+
+ ! loop over spectral elements
+ do ispec_outer = 1,nspec_outer
+ ! get global numbering for inner or outer elements
+ ispec = ispec_outer_to_glob(ispec_outer)
+ ibool_outer(:,:,ispec_outer) = ibool(:,:,ispec)
+ enddo
+
+ ! loop over spectral elements
+ do ispec_inner = 1,nspec_inner
+ ! get global numbering for inner or outer elements
+ ispec = ispec_inner_to_glob(ispec_inner)
+ ibool_inner(:,:,ispec_inner) = ibool(:,:,ispec)
+ enddo
+
+ allocate(copy_ibool_ori(NGLLX,NGLLZ,nspec_outer))
+ allocate(mask_ibool(npoin))
+
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:) = ibool_outer(:,:,:)
+
+ inumber = 0
+
+ do ispec = 1,nspec_outer
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
+ ! create a new point
+ inumber = inumber + 1
+ ibool_outer(i,j,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
+ else
+ ! use an existing point created previously
+ ibool_outer(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+
+ deallocate(copy_ibool_ori)
+ deallocate(mask_ibool)
+
+ ! the total number of points without multiples in this region is now known
+ npoin_outer = maxval(ibool_outer)
+
+ allocate(copy_ibool_ori(NGLLX,NGLLZ,nspec_inner))
+ allocate(mask_ibool(npoin))
+
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:) = ibool_inner(:,:,:)
+
+ inumber = 0
+
+ do ispec = 1,nspec_inner
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ if(mask_ibool(copy_ibool_ori(i,j,ispec)) == -1) then
+ ! create a new point
+ inumber = inumber + 1
+ ibool_inner(i,j,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,ispec)) = inumber
+ else
+ ! use an existing point created previously
+ ibool_inner(i,j,ispec) = mask_ibool(copy_ibool_ori(i,j,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+
+ deallocate(copy_ibool_ori)
+ deallocate(mask_ibool)
+
+ ! the total number of points without multiples in this region is now known
+ npoin_inner = maxval(ibool_inner)
+
+ !allocate(perm(nspec))
+
+ ! use identity permutation by default
+ do ispec = 1,nspec
+ perm(ispec) = ispec
+ enddo
+
+ if(ACTUALLY_IMPLEMENT_PERM_WHOLE) then
+
+ allocate(check_perm(nspec))
+ call get_perm(ibool,perm,LIMIT_MULTI_CUTHILL,nspec,npoin)
+ ! check that the permutation obtained is bijective
+ check_perm(:) = -1
+ do ispec = 1,nspec
+ check_perm(perm(ispec)) = ispec
+ enddo
+ if(minval(check_perm) /= 1) stop 'minval check_perm is incorrect for whole'
+ if(maxval(check_perm) /= nspec) stop 'maxval check_perm is incorrect for whole'
+ deallocate(check_perm)
+ else
+
+ if(ACTUALLY_IMPLEMENT_PERM_OUT) then
+ allocate(check_perm(nspec_outer))
+ call get_perm(ibool_outer,perm(1:nspec_outer),LIMIT_MULTI_CUTHILL,nspec_outer,npoin_outer)
+ ! check that the permutation obtained is bijective
+ check_perm(:) = -1
+ do ispec = 1,nspec_outer
+ check_perm(perm(ispec)) = ispec
+ enddo
+ if(minval(check_perm) /= 1) stop 'minval check_perm is incorrect for outer'
+ if(maxval(check_perm) /= nspec_outer) stop 'maxval check_perm is incorrect for outer'
+ deallocate(check_perm)
+ deallocate(ibool_outer)
+ endif
+
+ if(ACTUALLY_IMPLEMENT_PERM_INN) then
+ allocate(check_perm(nspec_inner))
+ call get_perm(ibool_inner,perm(nspec_outer+1:nspec),LIMIT_MULTI_CUTHILL,nspec_inner,npoin_inner)
+ ! check that the permutation obtained is bijective
+ check_perm(:) = -1
+ do ispec = 1,nspec_inner
+ check_perm(perm(nspec_outer+ispec)) = ispec
+ enddo
+ if(minval(check_perm) /= 1) stop 'minval check_perm is incorrect for inner'
+ if(maxval(check_perm) /= nspec_inner) stop 'maxval check_perm is incorrect for inner'
+ deallocate(check_perm)
+ ! add the right offset
+ perm(nspec_outer+1:nspec) = perm(nspec_outer+1:nspec) + nspec_outer
+ deallocate(ibool_inner)
+ endif
+
+ endif
+
+ endif
+
+ enddo ! end of further reduction of cache misses inner/outer in two passes
+
+!============================================
+!
+! end inner/outer passes
+!
+!============================================
+
+!---
+!--- end of section performed in two passes
+!---
+
+ call invert_mass_matrix(any_elastic,any_acoustic,any_poroelastic,&
+ rmass_inverse_elastic,npoin_elastic, &
+ rmass_inverse_acoustic,npoin_acoustic, &
+ rmass_s_inverse_poroelastic, &
+ rmass_w_inverse_poroelastic,npoin_poroelastic)
+
+! check the mesh, stability and number of points per wavelength
+ if(DISPLAY_SUBSET_OPTION == 1) then
+ UPPER_LIMIT_DISPLAY = nspec
+ else if(DISPLAY_SUBSET_OPTION == 2) then
+ UPPER_LIMIT_DISPLAY = nspec_inner
+ else if(DISPLAY_SUBSET_OPTION == 3) then
+ UPPER_LIMIT_DISPLAY = nspec_outer
+ else if(DISPLAY_SUBSET_OPTION == 4) then
+ UPPER_LIMIT_DISPLAY = NSPEC_DISPLAY_SUBSET
+ else
+ stop 'incorrect value of DISPLAY_SUBSET_OPTION'
+ endif
+ call checkgrid(vpext,vsext,rhoext,density,poroelastcoef, &
+ porosity,tortuosity,permeability,ibool,kmato, &
+ coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
+ assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat, &
+ f0,initialfield,time_function_type, &
+ coorg,xinterp,zinterp,shape2D_display,knods,simulation_title, &
+ npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,all_anisotropic, &
+ myrank,nproc,NSOURCES,poroelastic, &
+ freq0,Q0,TURN_VISCATTENUATION_ON)
+
+! convert receiver angle to radians
+ anglerec = anglerec * pi / 180.d0
+
+!
+!---- for color images
+!
+
+ if(output_color_image) then
+ ! prepares dimension of image
+ call prepare_color_image_init(NX_IMAGE_color,NZ_IMAGE_color, &
+ xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image, &
+ coord,npoin,npgeo)
+
+ ! allocate an array for image data
+ allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color))
+ allocate(image_color_vp_display(NX_IMAGE_color,NZ_IMAGE_color))
+
+ ! allocate an array for the grid point that corresponds to a given image data point
+ allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
+ allocate(copy_iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
+
+ ! creates pixels indexing
+ call prepare_color_image_pixels(myrank,NX_IMAGE_color,NZ_IMAGE_color, &
+ xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image, &
+ coord,npoin,coorg,npgeo,nspec,ngnod,knods,ibool, &
+ nb_pixel_loc,iglob_image_color)
+
+
+ ! creating and filling array num_pixel_loc with the positions of each colored
+ ! pixel owned by the local process (useful for parallel jobs)
+ allocate(num_pixel_loc(nb_pixel_loc))
+
+ nb_pixel_loc = 0
+ do i = 1, NX_IMAGE_color
+ do j = 1, NZ_IMAGE_color
+ if ( iglob_image_color(i,j) /= -1 ) then
+ nb_pixel_loc = nb_pixel_loc + 1
+ num_pixel_loc(nb_pixel_loc) = (j-1)*NX_IMAGE_color + i
+ endif
+ enddo
+ enddo
+
+! filling array iglob_image_color, containing info on which process owns which pixels.
+#ifdef USE_MPI
+ allocate(nb_pixel_per_proc(nproc))
+
+ call MPI_GATHER( nb_pixel_loc, 1, MPI_INTEGER, nb_pixel_per_proc(1), &
+ 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ier)
+
+ if ( myrank == 0 ) then
+ allocate(num_pixel_recv(maxval(nb_pixel_per_proc(:)),nproc))
+ allocate(data_pixel_recv(maxval(nb_pixel_per_proc(:))))
+ endif
+
+ allocate(data_pixel_send(nb_pixel_loc))
+ if (nproc > 1) then
+ if (myrank == 0) then
+
+ do iproc = 1, nproc-1
+
+ call MPI_RECV(num_pixel_recv(1,iproc+1),nb_pixel_per_proc(iproc+1), MPI_INTEGER, &
+ iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
+ do k = 1, nb_pixel_per_proc(iproc+1)
+ j = ceiling(real(num_pixel_recv(k,iproc+1)) / real(NX_IMAGE_color))
+ i = num_pixel_recv(k,iproc+1) - (j-1)*NX_IMAGE_color
+ iglob_image_color(i,j) = iproc
+
+ enddo
+ enddo
+
+ else
+ call MPI_SEND(num_pixel_loc(1),nb_pixel_loc,MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
+ endif
+ endif
+#endif
+
+ if (myrank == 0) write(IOUT,*) 'done locating all the pixels of color images'
+
+ endif ! color_image
+
+!
+!---- initialize seismograms
+!
+ sisux = ZERO ! double precision zero
+ sisuz = ZERO
+
+! initialize arrays to zero
+ displ_elastic = 0._CUSTOM_REAL
+ veloc_elastic = 0._CUSTOM_REAL
+ accel_elastic = 0._CUSTOM_REAL
+
+ displs_poroelastic = 0._CUSTOM_REAL
+ velocs_poroelastic = 0._CUSTOM_REAL
+ accels_poroelastic = 0._CUSTOM_REAL
+ displw_poroelastic = 0._CUSTOM_REAL
+ velocw_poroelastic = 0._CUSTOM_REAL
+ accelw_poroelastic = 0._CUSTOM_REAL
+
+ potential_acoustic = 0._CUSTOM_REAL
+ potential_dot_acoustic = 0._CUSTOM_REAL
+ potential_dot_dot_acoustic = 0._CUSTOM_REAL
+
+!
+!----- Files where viscous damping are saved during forward wavefield calculation
+!
+ if(any_poroelastic .and. (SAVE_FORWARD .or. SIMULATION_TYPE .eq. 2)) then
+ allocate(b_viscodampx(npoin))
+ allocate(b_viscodampz(npoin))
+ write(outputname,'(a,i6.6,a)') 'viscodampingx',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'viscodampingz',myrank,'.bin'
+ if(SIMULATION_TYPE == 2) then
+ reclen = CUSTOM_REAL * npoin
+ open(unit=23,file='OUTPUT_FILES/'//outputname,status='old',&
+ action='read',form='unformatted',access='direct',&
+ recl=reclen)
+ open(unit=24,file='OUTPUT_FILES/'//outputname2,status='old',&
+ action='read',form='unformatted',access='direct',&
+ recl=reclen)
+ else
+ reclen = CUSTOM_REAL * npoin
+ open(unit=23,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted',access='direct',&
+ recl=reclen)
+ open(unit=24,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted',access='direct',&
+ recl=reclen)
+ endif
+ else
+ allocate(b_viscodampx(1))
+ allocate(b_viscodampz(1))
+ endif
+
+!
+!----- Files where absorbing signal are saved during forward wavefield calculation
+!
+
+ if( ((SAVE_FORWARD .and. SIMULATION_TYPE ==1) .or. SIMULATION_TYPE == 2) .and. anyabs ) then
+ ! opens files for absorbing boundary data
+ call prepare_absorb_files(myrank,any_elastic,any_poroelastic,any_acoustic, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,SIMULATION_TYPE)
+ endif
+
+ if(anyabs .and. SIMULATION_TYPE == 2) then
+
+ ! reads in absorbing bounday data
+ if(any_elastic) then
+ call prepare_absorb_elastic(NSTEP,p_sv, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_elastic_left,b_absorb_elastic_right, &
+ b_absorb_elastic_bottom,b_absorb_elastic_top)
+
+ endif
+ if(any_poroelastic) then
+ call prepare_absorb_poroelastic(NSTEP, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_poro_s_left,b_absorb_poro_w_left, &
+ b_absorb_poro_s_right,b_absorb_poro_w_right, &
+ b_absorb_poro_s_bottom,b_absorb_poro_w_bottom, &
+ b_absorb_poro_s_top,b_absorb_poro_w_top)
+
+ endif
+ if(any_acoustic) then
+ call prepare_absorb_acoustic(NSTEP, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax, &
+ b_absorb_acoustic_left,b_absorb_acoustic_right, &
+ b_absorb_acoustic_bottom,b_absorb_acoustic_top)
+ endif
+
+ endif ! if(anyabs .and. SIMULATION_TYPE == 2)
+
+
+
+!
+!----- Read last frame for backward wavefield calculation
+!
+
+ if(SIMULATION_TYPE == 2) then
+
+ if(any_elastic) then
+ write(outputname,'(a,i6.6,a)') 'snapshot_rho_kappa_mu_',myrank
+ open(unit = 97, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_rhop_alpha_beta_',myrank
+ open(unit = 98, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ rho_kl(:,:,:) = 0._CUSTOM_REAL
+ mu_kl(:,:,:) = 0._CUSTOM_REAL
+ kappa_kl(:,:,:) = 0._CUSTOM_REAL
+
+ rhop_kl(:,:,:) = 0._CUSTOM_REAL
+ beta_kl(:,:,:) = 0._CUSTOM_REAL
+ alpha_kl(:,:,:) = 0._CUSTOM_REAL
+ rhorho_el_hessian_final2(:,:,:) = 0._CUSTOM_REAL
+ rhorho_el_hessian_temp2(:) = 0._CUSTOM_REAL
+ rhorho_el_hessian_final1(:,:,:) = 0._CUSTOM_REAL
+ rhorho_el_hessian_temp1(:) = 0._CUSTOM_REAL
+ endif
+
+ if(any_poroelastic) then
+
+ ! Primary kernels
+ write(outputname,'(a,i6.6,a)') 'snapshot_mu_B_C_',myrank
+ open(unit = 144, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_M_rho_rhof_',myrank
+ open(unit = 155, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_m_eta_',myrank
+ open(unit = 16, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ ! Wavespeed kernels
+ write(outputname,'(a,i6.6,a)') 'snapshot_cpI_cpII_cs_',myrank
+ open(unit = 20, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_rhobb_rhofbb_ratio_',myrank
+ open(unit = 21, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_phib_eta_',myrank
+ open(unit = 22, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ ! Density normalized kernels
+ write(outputname,'(a,i6.6,a)') 'snapshot_mub_Bb_Cb_',myrank
+ open(unit = 17, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_Mb_rhob_rhofb_',myrank
+ open(unit = 18, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_mb_etab_',myrank
+ open(unit = 19, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ rhot_kl(:,:,:) = 0._CUSTOM_REAL
+ rhof_kl(:,:,:) = 0._CUSTOM_REAL
+ eta_kl(:,:,:) = 0._CUSTOM_REAL
+ sm_kl(:,:,:) = 0._CUSTOM_REAL
+ mufr_kl(:,:,:) = 0._CUSTOM_REAL
+ B_kl(:,:,:) = 0._CUSTOM_REAL
+ C_kl(:,:,:) = 0._CUSTOM_REAL
+ M_kl(:,:,:) = 0._CUSTOM_REAL
+
+ rhob_kl(:,:,:) = 0._CUSTOM_REAL
+ rhofb_kl(:,:,:) = 0._CUSTOM_REAL
+ phi_kl(:,:,:) = 0._CUSTOM_REAL
+ mufrb_kl(:,:,:) = 0._CUSTOM_REAL
+ Bb_kl(:,:,:) = 0._CUSTOM_REAL
+ Cb_kl(:,:,:) = 0._CUSTOM_REAL
+ Mb_kl(:,:,:) = 0._CUSTOM_REAL
+
+ rhobb_kl(:,:,:) = 0._CUSTOM_REAL
+ rhofbb_kl(:,:,:) = 0._CUSTOM_REAL
+ phib_kl(:,:,:) = 0._CUSTOM_REAL
+ cs_kl(:,:,:) = 0._CUSTOM_REAL
+ cpI_kl(:,:,:) = 0._CUSTOM_REAL
+ cpII_kl(:,:,:) = 0._CUSTOM_REAL
+ ratio_kl(:,:,:) = 0._CUSTOM_REAL
+ endif
+
+ if(any_acoustic) then
+ write(outputname,'(a,i6.6,a)') 'snapshot_rho_kappa_',myrank
+ open(unit = 95, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_rhop_c_',myrank
+ open(unit = 96, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ rho_ac_kl(:,:,:) = 0._CUSTOM_REAL
+ kappa_ac_kl(:,:,:) = 0._CUSTOM_REAL
+
+ rhop_ac_kl(:,:,:) = 0._CUSTOM_REAL
+ alpha_ac_kl(:,:,:) = 0._CUSTOM_REAL
+ rhorho_ac_hessian_final2(:,:,:) = 0._CUSTOM_REAL
+ rhorho_ac_hessian_final1(:,:,:) = 0._CUSTOM_REAL
+ endif
+
+ endif ! if(SIMULATION_TYPE == 2)
+
+!
+!---- read initial fields from external file if needed
+!
+
+! if we are looking a plane wave beyond critical angle we use other method
+ over_critical_angle = .false.
+
+ if(initialfield) then
+
+ ! Calculation of the initial field for a plane wave
+ if( any_elastic ) then
+ call prepare_initialfield(myrank,any_acoustic,any_poroelastic,over_critical_angle, &
+ NSOURCES,source_type,angleforce,x_source,z_source,f0, &
+ npoin,numat,poroelastcoef,density,coord, &
+ angleforce_refl,c_inc,c_refl,cploc,csloc,time_offset, &
+ A_plane, B_plane, C_plane, &
+ accel_elastic,veloc_elastic,displ_elastic)
+ endif
+
+ if( over_critical_angle ) then
+
+ allocate(left_bound(nelemabs*NGLLX))
+ allocate(right_bound(nelemabs*NGLLX))
+ allocate(bot_bound(nelemabs*NGLLZ))
+
+ call prepare_initialfield_paco(myrank,nelemabs,left_bound,right_bound,bot_bound, &
+ numabs,codeabs,ibool,nspec, &
+ source_type,NSOURCES,c_inc,c_refl, &
+ count_bottom,count_left,count_right)
+
+ allocate(v0x_left(count_left,NSTEP))
+ allocate(v0z_left(count_left,NSTEP))
+ allocate(t0x_left(count_left,NSTEP))
+ allocate(t0z_left(count_left,NSTEP))
+
+ allocate(v0x_right(count_right,NSTEP))
+ allocate(v0z_right(count_right,NSTEP))
+ allocate(t0x_right(count_right,NSTEP))
+ allocate(t0z_right(count_right,NSTEP))
+
+ allocate(v0x_bot(count_bottom,NSTEP))
+ allocate(v0z_bot(count_bottom,NSTEP))
+ allocate(t0x_bot(count_bottom,NSTEP))
+ allocate(t0z_bot(count_bottom,NSTEP))
+
+ allocate(displ_paco(NDIM,npoin))
+ allocate(veloc_paco(NDIM,npoin))
+ allocate(accel_paco(NDIM,npoin))
+
+ ! call Paco's routine to compute in frequency and convert to time by Fourier transform
+ call paco_beyond_critical(coord,npoin,deltat,NSTEP,angleforce(1),&
+ f0(1),cploc,csloc,TURN_ATTENUATION_ON,Qp_attenuation,source_type(1),v0x_left,v0z_left,&
+ v0x_right,v0z_right,v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,&
+ t0x_bot,t0z_bot,left_bound(1:count_left),right_bound(1:count_right),bot_bound(1:count_bottom)&
+ ,count_left,count_right,count_bottom,displ_paco,veloc_paco,accel_paco)
+
+ displ_elastic(1,:) = displ_paco(1,:)
+ displ_elastic(3,:) = displ_paco(2,:)
+ veloc_elastic(1,:) = veloc_paco(1,:)
+ veloc_elastic(3,:) = veloc_paco(2,:)
+ accel_elastic(1,:) = accel_paco(1,:)
+ accel_elastic(3,:) = accel_paco(2,:)
+
+ deallocate(left_bound)
+ deallocate(right_bound)
+ deallocate(bot_bound)
+
+ deallocate(displ_paco)
+ deallocate(veloc_paco)
+ deallocate(accel_paco)
+
+ if (myrank == 0) then
+ write(IOUT,*) '***********'
+ write(IOUT,*) 'done calculating the initial wave field'
+ write(IOUT,*) '***********'
+ endif
+
+ endif ! beyond critical angle
+
+ write(IOUT,*) 'Max norm of initial elastic displacement = ', &
+ maxval(sqrt(displ_elastic(1,:)**2 + displ_elastic(3,:)**2))
+
+ endif ! initialfield
+
+ deltatsquare = deltat * deltat
+ deltatcube = deltatsquare * deltat
+ deltatfourth = deltatsquare * deltatsquare
+
+ twelvedeltat = 12.d0 * deltat
+ fourdeltatsquare = 4.d0 * deltatsquare
+
+! compute the source time function and store it in a text file
+ if(.not. initialfield) then
+
+ allocate(source_time_function(NSOURCES,NSTEP))
+ source_time_function(:,:) = 0._CUSTOM_REAL
+
+ ! computes source time function array
+ call prepare_source_time_function(myrank,NSTEP,NSOURCES,source_time_function, &
+ time_function_type,f0,tshift_src,factor,aval, &
+ t0,nb_proc_source,deltat)
+ else
+ ! uses an initialfield
+ ! dummy allocation
+ allocate(source_time_function(1,1))
+ endif
+
+! determine if coupled fluid-solid simulation
+ coupled_acoustic_elastic = any_acoustic .and. any_elastic
+ coupled_acoustic_poro = any_acoustic .and. any_poroelastic
+
+! fluid/solid (elastic) edge detection
+! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
+! the common nodes forming the edge are computed here
+ if(coupled_acoustic_elastic) then
+
+ if (myrank == 0) then
+ print *
+ print *,'Mixed acoustic/elastic simulation'
+ print *
+ print *,'Beginning of fluid/solid edge detection'
+ endif
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+ do inum = 1, num_fluid_solid_edges
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+
+! one element must be acoustic and the other must be elastic
+ if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. &
+ .not. poroelastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_acoustic = 1,NEDGES
+ do iedge_elastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
+ fluid_solid_acoustic_iedge(inum) = iedge_acoustic
+ fluid_solid_elastic_iedge(inum) = iedge_elastic
+! print *,'edge ',iedge_acoustic,' of acoustic element ',ispec_acoustic, &
+! ' is in contact with edge ',iedge_elastic,' of elastic element ',ispec_elastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+! make sure fluid/solid (elastic) matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
+
+ if(myrank == 0) print *,'Checking fluid/solid edge topology...'
+
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
+
+! get the corresponding edge of the elastic element
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+ iedge_elastic = fluid_solid_elastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the elastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob2 = ibool(i,j,ispec_acoustic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ call exit_MPI( 'error in fluid/solid coupling buffer')
+
+ enddo
+
+ enddo
+
+ if (myrank == 0) then
+ print *,'End of fluid/solid edge detection'
+ print *
+ endif
+
+ endif
+
+! fluid/solid (poroelastic) edge detection
+! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
+! the common nodes forming the edge are computed here
+ if(coupled_acoustic_poro) then
+ if ( myrank == 0 ) then
+ print *
+ print *,'Mixed acoustic/poroelastic simulation'
+ print *
+ print *,'Beginning of fluid/solid (poroelastic) edge detection'
+ endif
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+ do inum = 1, num_fluid_poro_edges
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+
+! one element must be acoustic and the other must be poroelastic
+ if(ispec_acoustic /= ispec_poroelastic .and. .not. poroelastic(ispec_acoustic) .and. &
+ .not. elastic(ispec_acoustic) .and. poroelastic(ispec_poroelastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_acoustic = 1,NEDGES
+ do iedge_poroelastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic)) then
+ fluid_poro_acoustic_iedge(inum) = iedge_acoustic
+ fluid_poro_poroelastic_iedge(inum) = iedge_poroelastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+
+! make sure fluid/solid (poroelastic) matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
+
+ if ( myrank == 0 ) then
+ print *,'Checking fluid/solid (poroelastic) edge topology...'
+ endif
+
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob2 = ibool(i,j,ispec_acoustic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ call exit_MPI( 'error in fluid/solid (poroelastic) coupling buffer')
+
+ enddo
+
+ enddo
+
+ if ( myrank == 0 ) then
+ print *,'End of fluid/solid (poroelastic) edge detection'
+ print *
+ endif
+
+ endif
+
+! exclude common points between acoustic absorbing edges and acoustic/elastic matching interfaces
+ if(coupled_acoustic_elastic .and. anyabs) then
+
+ if (myrank == 0) &
+ print *,'excluding common points between acoustic absorbing edges and acoustic/elastic matching interfaces, if any'
+
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
+
+! if acoustic absorbing element and acoustic/elastic coupled element is the same
+ if(ispec_acoustic == ispec) then
+
+ if(iedge_acoustic == IBOTTOM) then
+ jbegin_left(ispecabs) = 2
+ jbegin_right(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == ITOP) then
+ jend_left(ispecabs) = NGLLZ - 1
+ jend_right(ispecabs) = NGLLZ - 1
+ endif
+
+ if(iedge_acoustic == ILEFT) then
+ ibegin_bottom(ispecabs) = 2
+ ibegin_top(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == IRIGHT) then
+ iend_bottom(ispecabs) = NGLLX - 1
+ iend_top(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+! exclude common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces
+ if(coupled_acoustic_poro .and. anyabs) then
+
+ if (myrank == 0) &
+ print *,'excluding common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces, if any'
+
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! if acoustic absorbing element and acoustic/poroelastic coupled element is the same
+ if(ispec_acoustic == ispec) then
+
+ if(iedge_acoustic == IBOTTOM) then
+ jbegin_left(ispecabs) = 2
+ jbegin_right(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == ITOP) then
+ jend_left(ispecabs) = NGLLZ - 1
+ jend_right(ispecabs) = NGLLZ - 1
+ endif
+
+ if(iedge_acoustic == ILEFT) then
+ ibegin_bottom(ispecabs) = 2
+ ibegin_top(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == IRIGHT) then
+ iend_bottom(ispecabs) = NGLLX - 1
+ iend_top(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+
+! determine if coupled elastic-poroelastic simulation
+ coupled_elastic_poro = any_elastic .and. any_poroelastic
+
+! solid/porous edge detection
+! the two elements forming an edge are already known (computed in meshfem2D),
+! the common nodes forming the edge are computed here
+ if(coupled_elastic_poro) then
+
+ if(TURN_ATTENUATION_ON .or. TURN_VISCATTENUATION_ON) &
+ stop 'Attenuation not supported for mixed elastic/poroelastic simulations'
+
+ if ( myrank == 0 ) then
+ print *
+ print *,'Mixed elastic/poroelastic simulation'
+ print *
+ print *,'Beginning of solid/porous edge detection'
+ endif
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+
+ do inum = 1, num_solid_poro_edges
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+
+! one element must be elastic and the other must be poroelastic
+ if(ispec_elastic /= ispec_poroelastic .and. elastic(ispec_elastic) .and. &
+ poroelastic(ispec_poroelastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_poroelastic = 1,NEDGES
+ do iedge_elastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic) == &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
+ solid_poro_elastic_iedge(inum) = iedge_elastic
+ solid_poro_poroelastic_iedge(inum) = iedge_poroelastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+! make sure solid/porous matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
+
+ if ( myrank == 0 ) then
+ print *,'Checking solid/porous edge topology...'
+ endif
+
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! get point values for the elastic side
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob2 = ibool(i,j,ispec_poroelastic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ call exit_MPI( 'error in solid/porous coupling buffer')
+
+ enddo
+
+ enddo
+
+ if ( myrank == 0 ) then
+ print *,'End of solid/porous edge detection'
+ print *
+ endif
+
+ endif
+
+! initiation
+ if(any_poroelastic .and. anyabs) then
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+ jbegin_left_poro(ispecabs) = 1
+ jbegin_right_poro(ispecabs) = 1
+
+ jend_left_poro(ispecabs) = NGLLZ
+ jend_right_poro(ispecabs) = NGLLZ
+
+ ibegin_bottom_poro(ispecabs) = 1
+ ibegin_top_poro(ispecabs) = 1
+
+ iend_bottom_poro(ispecabs) = NGLLX
+ iend_top_poro(ispecabs) = NGLLX
+ enddo
+ endif
+
+! exclude common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces
+ if(coupled_elastic_poro .and. anyabs) then
+
+ if (myrank == 0) &
+ print *,'excluding common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces, if any'
+
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! if poroelastic absorbing element and elastic/poroelastic coupled element is the same
+ if(ispec_poroelastic == ispec) then
+
+ if(iedge_poroelastic == IBOTTOM) then
+ jbegin_left_poro(ispecabs) = 2
+ jbegin_right_poro(ispecabs) = 2
+ endif
+
+ if(iedge_poroelastic == ITOP) then
+ jend_left_poro(ispecabs) = NGLLZ - 1
+ jend_right_poro(ispecabs) = NGLLZ - 1
+ endif
+
+ if(iedge_poroelastic == ILEFT) then
+ ibegin_bottom_poro(ispecabs) = 2
+ ibegin_top_poro(ispecabs) = 2
+ endif
+
+ if(iedge_poroelastic == IRIGHT) then
+ iend_bottom_poro(ispecabs) = NGLLX - 1
+ iend_top_poro(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+#ifdef USE_MPI
+ if(OUTPUT_ENERGY) stop 'energy calculation currently serial only, should add an MPI_REDUCE in parallel'
+#endif
+! open the file in which we will store the energy curve
+ if(OUTPUT_ENERGY) open(unit=IOUT_ENERGY,file='energy.gnu',status='unknown')
+
+!
+!---- s t a r t t i m e i t e r a t i o n s
+!
+ if (myrank == 0) write(IOUT,400)
+
+ ! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+ ! time_values(1): year
+ ! time_values(2): month of the year
+ ! time_values(3): day of the month
+ ! time_values(5): hour of the day
+ ! time_values(6): minutes of the hour
+ ! time_values(7): seconds of the minute
+ ! time_values(8): milliseconds of the second
+ ! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+ month_start = time_values(2)
+ year_start = time_values(1)
+
+ ! prepares image background
+ if(output_color_image) then
+ call prepare_color_image_vp(npoin,image_color_vp_display,iglob_image_color, &
+ NX_IMAGE_color,NZ_IMAGE_color,nb_pixel_loc, &
+ num_pixel_loc,nspec,poroelastic,ibool,kmato, &
+ numat,density,poroelastcoef,porosity,tortuosity, &
+ nproc,myrank,assign_external_model,vpext)
+
+ endif
+
+! dummy allocation of plane wave arrays if they are unused (but still need to exist because
+! they are used as arguments to subroutines)
+ if(.not. over_critical_angle) then
+ allocate(v0x_left(1,NSTEP))
+ allocate(v0z_left(1,NSTEP))
+ allocate(t0x_left(1,NSTEP))
+ allocate(t0z_left(1,NSTEP))
+
+ allocate(v0x_right(1,NSTEP))
+ allocate(v0z_right(1,NSTEP))
+ allocate(t0x_right(1,NSTEP))
+ allocate(t0z_right(1,NSTEP))
+
+ allocate(v0x_bot(1,NSTEP))
+ allocate(v0z_bot(1,NSTEP))
+ allocate(t0x_bot(1,NSTEP))
+ allocate(t0z_bot(1,NSTEP))
+ endif
+
+! initialize variables for writing seismograms
+ seismo_offset = 0
+ seismo_current = 0
+
+! Precompute Runge Kutta coefficients if viscous attenuation
+ if(TURN_VISCATTENUATION_ON) then
+ theta_e = (sqrt(Q0**2+1.d0) +1.d0)/(2.d0*pi*freq0*Q0)
+ theta_s = (sqrt(Q0**2+1.d0) -1.d0)/(2.d0*pi*freq0*Q0)
+
+ thetainv = - 1.d0 / theta_s
+ alphaval = 1.d0 + deltat*thetainv + deltat**2*thetainv**2 / 2.d0 + &
+ deltat**3*thetainv**3 / 6.d0 + deltat**4*thetainv**4 / 24.d0
+ betaval = deltat / 2.d0 + deltat**2*thetainv / 3.d0 + deltat**3*thetainv**2 / 8.d0 + deltat**4*thetainv**3 / 24.d0
+ gammaval = deltat / 2.d0 + deltat**2*thetainv / 6.d0 + deltat**3*thetainv**2 / 24.d0
+ print*,'************************************************************'
+ print*,'****** Visco attenuation coefficients (poroelastic) ********'
+ print*,'theta_e = ', theta_e
+ print*,'theta_s = ', theta_s
+ print*,'alpha = ', alphaval
+ print*,'beta = ', betaval
+ print*,'gamma = ', gammaval
+ print*,'************************************************************'
+
+! initialize memory variables for attenuation
+ viscox(:,:,:) = 0.d0
+ viscoz(:,:,:) = 0.d0
+ rx_viscous(:,:,:) = 0.d0
+ rz_viscous(:,:,:) = 0.d0
+
+ endif
+
+! allocate arrays for postscript output
+#ifdef USE_MPI
+ if(modelvect) then
+ d1_coorg_recv_ps_velocity_model=2
+ call mpi_allreduce(nspec,d2_coorg_recv_ps_velocity_model,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+ d2_coorg_recv_ps_velocity_model=d2_coorg_recv_ps_velocity_model*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4
+ d1_RGB_recv_ps_velocity_model=1
+ call mpi_allreduce(nspec,d2_RGB_recv_ps_velocity_model,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+ d2_RGB_recv_ps_velocity_model=d2_RGB_recv_ps_velocity_model*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4
+ else
+ d1_coorg_recv_ps_velocity_model=1
+ d2_coorg_recv_ps_velocity_model=1
+ d1_RGB_recv_ps_velocity_model=1
+ d2_RGB_recv_ps_velocity_model=1
+ endif
+
+ d1_coorg_send_ps_element_mesh=2
+ if ( ngnod == 4 ) then
+ if ( numbers == 1 ) then
+ d2_coorg_send_ps_element_mesh=nspec*5
+ if ( colors == 1 ) then
+ d1_color_send_ps_element_mesh=2*nspec
+ else
+ d1_color_send_ps_element_mesh=1*nspec
+ endif
+ else
+ d2_coorg_send_ps_element_mesh=nspec*6
+ if ( colors == 1 ) then
+ d1_color_send_ps_element_mesh=1*nspec
+ endif
+ endif
+ else
+ if ( numbers == 1 ) then
+ d2_coorg_send_ps_element_mesh=nspec*((pointsdisp-1)*3+max(0,pointsdisp-2)+1+1)
+ if ( colors == 1 ) then
+ d1_color_send_ps_element_mesh=2*nspec
+ else
+ d1_color_send_ps_element_mesh=1*nspec
+ endif
+ else
+ d2_coorg_send_ps_element_mesh=nspec*((pointsdisp-1)*3+max(0,pointsdisp-2)+1)
+ if ( colors == 1 ) then
+ d1_color_send_ps_element_mesh=1*nspec
+ endif
+ endif
+ endif
+
+call mpi_allreduce(d1_coorg_send_ps_element_mesh,d1_coorg_recv_ps_element_mesh,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+call mpi_allreduce(d2_coorg_send_ps_element_mesh,d2_coorg_recv_ps_element_mesh,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+call mpi_allreduce(d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+
+ d1_coorg_send_ps_abs=4
+ d2_coorg_send_ps_abs=4*nelemabs
+call mpi_allreduce(d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+call mpi_allreduce(d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+
+ d1_coorg_send_ps_free_surface=4
+ d2_coorg_send_ps_free_surface=4*nelem_acoustic_surface
+call mpi_allreduce(d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+call mpi_allreduce(d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+
+ d1_coorg_send_ps_vector_field=8
+ if(interpol) then
+ if(plot_lowerleft_corner_only) then
+ d2_coorg_send_ps_vector_field=nspec*1*1
+ else
+ d2_coorg_send_ps_vector_field=nspec*pointsdisp*pointsdisp
+ endif
+ else
+ d2_coorg_send_ps_vector_field=npoin
+ endif
+call mpi_allreduce(d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+call mpi_allreduce(d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+
+
+#else
+ d1_coorg_recv_ps_velocity_model=1
+ d2_coorg_recv_ps_velocity_model=1
+ d1_RGB_recv_ps_velocity_model=1
+ d2_RGB_recv_ps_velocity_model=1
+
+ d1_coorg_send_ps_element_mesh=1
+ d2_coorg_send_ps_element_mesh=1
+ d1_coorg_recv_ps_element_mesh=1
+ d2_coorg_recv_ps_element_mesh=1
+ d1_color_send_ps_element_mesh=1
+ d1_color_recv_ps_element_mesh=1
+
+ d1_coorg_send_ps_abs=1
+ d2_coorg_send_ps_abs=1
+ d1_coorg_recv_ps_abs=1
+ d2_coorg_recv_ps_abs=1
+ d1_coorg_send_ps_free_surface=1
+ d2_coorg_send_ps_free_surface=1
+ d1_coorg_recv_ps_free_surface=1
+ d2_coorg_recv_ps_free_surface=1
+
+ d1_coorg_send_ps_vector_field=1
+ d2_coorg_send_ps_vector_field=1
+ d1_coorg_recv_ps_vector_field=1
+ d2_coorg_recv_ps_vector_field=1
+
+#endif
+ d1_coorg_send_ps_velocity_model=2
+ d2_coorg_send_ps_velocity_model=nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4
+ d1_RGB_send_ps_velocity_model=1
+ d2_RGB_send_ps_velocity_model=nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)
+
+ allocate(coorg_send_ps_velocity_model(d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model))
+ allocate(RGB_send_ps_velocity_model(d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model))
+
+ allocate(coorg_recv_ps_velocity_model(d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model))
+ allocate(RGB_recv_ps_velocity_model(d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model))
+
+ allocate(coorg_send_ps_element_mesh(d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh))
+ allocate(coorg_recv_ps_element_mesh(d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh))
+ allocate(color_send_ps_element_mesh(d1_color_send_ps_element_mesh))
+ allocate(color_recv_ps_element_mesh(d1_color_recv_ps_element_mesh))
+
+ allocate(coorg_send_ps_abs(d1_coorg_send_ps_abs,d2_coorg_send_ps_abs))
+ allocate(coorg_recv_ps_abs(d1_coorg_recv_ps_abs,d2_coorg_recv_ps_abs))
+
+ allocate(coorg_send_ps_free_surface(d1_coorg_send_ps_free_surface,d2_coorg_send_ps_free_surface))
+ allocate(coorg_recv_ps_free_surface(d1_coorg_recv_ps_free_surface,d2_coorg_recv_ps_free_surface))
+
+ allocate(coorg_send_ps_vector_field(d1_coorg_send_ps_vector_field,d2_coorg_send_ps_vector_field))
+ allocate(coorg_recv_ps_vector_field(d1_coorg_recv_ps_vector_field,d2_coorg_recv_ps_vector_field))
+
+! *********************************************************
+! ************* MAIN LOOP OVER THE TIME STEPS *************
+! *********************************************************
+
+#ifdef USE_MPI
+! add a barrier if we generate traces of the run for analysis with "ParaVer"
+ if(GENERATE_PARAVER_TRACES) call MPI_BARRIER(MPI_COMM_WORLD,ier)
+#endif
+
+ do it = 1,NSTEP
+
+! update position in seismograms
+ seismo_current = seismo_current + 1
+
+! compute current time
+ time = (it-1)*deltat
+
+! update displacement using finite-difference time scheme (Newmark)
+ if(any_elastic) then
+ displ_elastic = displ_elastic &
+ + deltat*veloc_elastic &
+ + deltatsquareover2*accel_elastic
+ veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+ accel_elastic = ZERO
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation
+ b_displ_elastic = b_displ_elastic &
+ + b_deltat*b_veloc_elastic &
+ + b_deltatsquareover2*b_accel_elastic
+ b_veloc_elastic = b_veloc_elastic + b_deltatover2*b_accel_elastic
+ b_accel_elastic = ZERO
+ endif
+ endif
+
+ if(any_poroelastic) then
+ !for the solid
+ displs_poroelastic = displs_poroelastic &
+ + deltat*velocs_poroelastic &
+ + deltatsquareover2*accels_poroelastic
+ velocs_poroelastic = velocs_poroelastic + deltatover2*accels_poroelastic
+ accels_poroelastic = ZERO
+ !for the fluid
+ displw_poroelastic = displw_poroelastic &
+ + deltat*velocw_poroelastic &
+ + deltatsquareover2*accelw_poroelastic
+ velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
+ accelw_poroelastic = ZERO
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation
+ !for the solid
+ b_displs_poroelastic = b_displs_poroelastic &
+ + b_deltat*b_velocs_poroelastic &
+ + b_deltatsquareover2*b_accels_poroelastic
+ b_velocs_poroelastic = b_velocs_poroelastic + b_deltatover2*b_accels_poroelastic
+ b_accels_poroelastic = ZERO
+ !for the fluid
+ b_displw_poroelastic = b_displw_poroelastic &
+ + b_deltat*b_velocw_poroelastic &
+ + b_deltatsquareover2*b_accelw_poroelastic
+ b_velocw_poroelastic = b_velocw_poroelastic + b_deltatover2*b_accelw_poroelastic
+ b_accelw_poroelastic = ZERO
+ endif
+ endif
+
+!--------------------------------------------------------------------------------------------
+! implement viscous attenuation for poroelastic media
+!
+ if(TURN_VISCATTENUATION_ON .and. any_poroelastic) then
+! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+! loop over spectral elements
+
+ do ispec = 1,nspec
+
+ etal_f = poroelastcoef(2,2,kmato(ispec))
+ permlxx = permeability(1,kmato(ispec))
+ permlxz = permeability(2,kmato(ispec))
+ permlzz = permeability(3,kmato(ispec))
+
+ ! calcul of the inverse of k
+
+ detk = permlxx*permlzz - permlxz*permlxz
+
+ if(detk /= ZERO) then
+ invpermlxx = permlzz/detk
+ invpermlxz = -permlxz/detk
+ invpermlzz = permlxx/detk
+ else
+ stop 'Permeability matrix is not invertible'
+ endif
+
+ ! relaxed viscous coef
+ bl_relaxed(1) = etal_f*invpermlxx
+ bl_relaxed(2) = etal_f*invpermlxz
+ bl_relaxed(3) = etal_f*invpermlzz
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ viscox_loc(i,j) = velocw_poroelastic(1,iglob)*bl_relaxed(1) + &
+ velocw_poroelastic(2,iglob)*bl_relaxed(2)
+ viscoz_loc(i,j) = velocw_poroelastic(1,iglob)*bl_relaxed(2) + &
+ velocw_poroelastic(2,iglob)*bl_relaxed(3)
+
+ ! evolution rx_viscous
+ Sn = - (1.d0 - theta_e/theta_s)/theta_s*viscox(i,j,ispec)
+ Snp1 = - (1.d0 - theta_e/theta_s)/theta_s*viscox_loc(i,j)
+ rx_viscous(i,j,ispec) = alphaval * rx_viscous(i,j,ispec) &
+ + betaval * Sn + gammaval * Snp1
+
+ ! evolution rz_viscous
+ Sn = - (1.d0 - theta_e/theta_s)/theta_s*viscoz(i,j,ispec)
+ Snp1 = - (1.d0 - theta_e/theta_s)/theta_s*viscoz_loc(i,j)
+ rz_viscous(i,j,ispec) = alphaval * rz_viscous(i,j,ispec) &
+ + betaval * Sn + gammaval * Snp1
+
+
+ enddo
+ enddo
+
+ ! save visco for Runge-Kutta scheme
+ viscox(:,:,ispec) = viscox_loc(:,:)
+ viscoz(:,:,ispec) = viscoz_loc(:,:)
+
+ enddo ! end of spectral element loop
+ endif ! end of viscous attenuation for porous media
+
+!-----------------------------------------
+ if(any_acoustic) then
+
+ ! Newmark time scheme
+ potential_acoustic = potential_acoustic &
+ + deltat*potential_dot_acoustic &
+ + deltatsquareover2*potential_dot_dot_acoustic
+ potential_dot_acoustic = potential_dot_acoustic &
+ + deltatover2*potential_dot_dot_acoustic
+ potential_dot_dot_acoustic = ZERO
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation
+ b_potential_acoustic = b_potential_acoustic &
+ + b_deltat*b_potential_dot_acoustic &
+ + b_deltatsquareover2*b_potential_dot_dot_acoustic
+ b_potential_dot_acoustic = b_potential_dot_acoustic &
+ + b_deltatover2*b_potential_dot_dot_acoustic
+ b_potential_dot_dot_acoustic = ZERO
+ endif
+
+ ! free surface for an acoustic medium
+ if ( nelem_acoustic_surface > 0 ) then
+ call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+
+ if(SIMULATION_TYPE == 2) then ! Adjoint calculation
+ call enforce_acoustic_free_surface(b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
+ b_potential_acoustic,acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+ endif
+ endif
+
+! *********************************************************
+! ************* compute forces for the acoustic elements
+! *********************************************************
+
+! call compute_forces_acoustic(npoin,nspec,nelemabs,numat,it,NSTEP, &
+! anyabs,assign_external_model,ibool,kmato,numabs, &
+! elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
+! potential_acoustic,b_potential_dot_dot_acoustic,b_potential_acoustic, &
+! density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
+! vpext,rhoext,hprime_xx,hprimewgll_xx, &
+! hprime_zz,hprimewgll_zz,wxgll,wzgll, &
+! ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
+! jbegin_left,jend_left,jbegin_right,jend_right, &
+! SIMULATION_TYPE,SAVE_FORWARD,b_absorb_acoustic_left,&
+! b_absorb_acoustic_right,b_absorb_acoustic_bottom,&
+! b_absorb_acoustic_top,nspec_xmin,nspec_xmax,&
+! nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top)
+
+
+ call compute_forces_acoustic_2(npoin,nspec,nelemabs,numat,it,NSTEP, &
+ anyabs,assign_external_model,ibool,kmato,numabs, &
+ elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic, &
+ density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,rhoext,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll, &
+ ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
+ jbegin_left,jend_left,jbegin_right,jend_right, &
+ SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
+ b_absorb_acoustic_left,b_absorb_acoustic_right, &
+ b_absorb_acoustic_bottom,b_absorb_acoustic_top)
+ if( SIMULATION_TYPE == 2 ) then
+ call compute_forces_acoustic_2(npoin,nspec,nelemabs,numat,it,NSTEP, &
+ anyabs,assign_external_model,ibool,kmato,numabs, &
+ elastic,poroelastic,codeabs,b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
+ b_potential_acoustic, &
+ density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,rhoext,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll, &
+ ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
+ jbegin_left,jend_left,jbegin_right,jend_right, &
+ SIMULATION_TYPE,SAVE_FORWARD,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top, &
+ b_absorb_acoustic_left,b_absorb_acoustic_right, &
+ b_absorb_acoustic_bottom,b_absorb_acoustic_top)
+ endif
+
+
+ ! stores absorbing boundary contributions into files
+ if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
+ !--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do i=1,NGLLZ
+ write(65) b_absorb_acoustic_left(i,ispec,it)
+ enddo
+ enddo
+ endif
+ !--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do i=1,NGLLZ
+ write(66) b_absorb_acoustic_right(i,ispec,it)
+ enddo
+ enddo
+ endif
+ !--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do i=1,NGLLX
+ write(67) b_absorb_acoustic_bottom(i,ispec,it)
+ enddo
+ enddo
+ endif
+ !--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do i=1,NGLLX
+ write(68) b_absorb_acoustic_top(i,ispec,it)
+ enddo
+ enddo
+ endif
+ endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
+
+ endif ! end of test if any acoustic element
+
+! *********************************************************
+! ************* add coupling with the elastic side
+! *********************************************************
+
+ if(coupled_acoustic_elastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
+
+! get the corresponding edge of the elastic element
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+ iedge_elastic = fluid_solid_elastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the elastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+ displ_x = displ_elastic(1,iglob)
+ displ_z = displ_elastic(3,iglob)
+
+ if(SIMULATION_TYPE == 2) then
+ b_displ_x = b_displ_elastic(1,iglob)
+ b_displ_z = b_displ_elastic(3,iglob)
+ endif
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == ITOP)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_acoustic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+! compute dot product
+ displ_n = displ_x*nx + displ_z*nz
+
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
+
+ if(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) +&
+ weight*(b_displ_x*nx + b_displ_z*nz)
+ endif !if(SIMULATION_TYPE == 2) then
+
+ enddo
+
+ enddo
+
+ endif
+
+! *********************************************************
+! ************* add coupling with the poroelastic side
+! *********************************************************
+
+ if(coupled_acoustic_poro) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+ displ_x = displs_poroelastic(1,iglob)
+ displ_z = displs_poroelastic(2,iglob)
+
+ phil = porosity(kmato(ispec_poroelastic))
+ displw_x = displw_poroelastic(1,iglob)
+ displw_z = displw_poroelastic(2,iglob)
+
+ if(SIMULATION_TYPE == 2) then
+ b_displ_x = b_displs_poroelastic(1,iglob)
+ b_displ_z = b_displs_poroelastic(2,iglob)
+
+ b_displw_x = b_displw_poroelastic(1,iglob)
+ b_displw_z = b_displw_poroelastic(2,iglob)
+ endif
+
+! get point values for the acoustic side
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == ITOP)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_acoustic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+! compute dot product [u_s + w]*n
+ displ_n = (displ_x + displw_x)*nx + (displ_z + displw_z)*nz
+
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
+
+ if(SIMULATION_TYPE == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
+ + weight*((b_displ_x + b_displw_x)*nx + (b_displ_z + b_displw_z)*nz)
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+
+! ************************************************************************************
+! ************************************ add force source
+! ************************************************************************************
+
+ if(any_acoustic) then
+
+! --- add the source
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCES
+ ! if this processor carries the source and the source element is acoustic
+ if (is_proc_source(i_source) == 1 .and. &
+ .not. elastic(ispec_selected_source(i_source)) .and. &
+ .not. poroelastic(ispec_selected_source(i_source))) then
+
+! collocated force
+! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+! to add minus the source to Chi_dot_dot to get plus the source in pressure
+ if(source_type(i_source) == 1) then
+
+ if(SIMULATION_TYPE == 1) then
+ ! forward wavefield
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - source_time_function(i_source,it)*hlagrange
+ enddo
+ enddo
+ else
+ ! backward wavefield
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
+ - source_time_function(i_source,NSTEP-it+1)*hlagrange
+ enddo
+ enddo
+ endif
+
+ ! moment tensor
+ else if(source_type(i_source) == 2) then
+ call exit_MPI('cannot have moment tensor source in acoustic element')
+
+ endif
+ endif ! if this processor carries the source and the source element is acoustic
+ enddo ! do i_source=1,NSOURCES
+
+ if(SIMULATION_TYPE == 2) then ! adjoint wavefield
+ irec_local = 0
+ do irec = 1,nrec
+ ! add the source (only if this proc carries the source)
+ if (myrank == which_proc_receiver(irec)) then
+
+ irec_local = irec_local + 1
+ if (.not. elastic(ispec_selected_rec(irec)) .and. &
+ .not. poroelastic(ispec_selected_rec(irec))) then
+ ! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
+ enddo
+ enddo
+ endif ! if element acoustic
+
+ endif ! if this processor carries the adjoint source
+ enddo ! irec = 1,nrec
+ endif ! SIMULATION_TYPE == 2 adjoint wavefield
+
+ endif ! if not using an initial field
+
+ endif !if(any_acoustic)
+
+
+! assembling potential_dot_dot for acoustic elements
+#ifdef USE_MPI
+ if ( nproc > 1 .and. any_acoustic .and. ninterface_acoustic > 0) then
+ call assemble_MPI_vector_ac(potential_dot_dot_acoustic,npoin, &
+ ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
+ max_interface_size, max_ibool_interfaces_size_ac,&
+ ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
+ tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
+ buffer_recv_faces_vector_ac, my_neighbours)
+
+ if ( SIMULATION_TYPE == 2) then
+ call assemble_MPI_vector_ac(b_potential_dot_dot_acoustic,npoin, &
+ ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
+ max_interface_size, max_ibool_interfaces_size_ac,&
+ ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
+ tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
+ buffer_recv_faces_vector_ac, my_neighbours)
+
+ endif
+
+ endif
+
+! if ( nproc > 1 .and. any_acoustic .and. ninterface_acoustic > 0 .and. SIMULATION_TYPE == 2) then
+! call assemble_MPI_vector_ac(b_potential_dot_dot_acoustic,npoin, &
+! ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
+! max_interface_size, max_ibool_interfaces_size_ac,&
+! ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
+! tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
+! buffer_recv_faces_vector_ac, my_neighbours)
+! endif
+#endif
+
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
+
+ if(any_acoustic) then
+
+ potential_dot_dot_acoustic = potential_dot_dot_acoustic * rmass_inverse_acoustic
+ potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
+
+ if(SIMULATION_TYPE ==2)then
+ b_potential_dot_dot_acoustic = b_potential_dot_dot_acoustic * rmass_inverse_acoustic
+ b_potential_dot_acoustic = b_potential_dot_acoustic + b_deltatover2*b_potential_dot_dot_acoustic
+ endif
+
+
+! free surface for an acoustic medium
+ if ( nelem_acoustic_surface > 0 ) then
+ call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+
+ if(SIMULATION_TYPE == 2) then
+ call enforce_acoustic_free_surface(b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
+ b_potential_acoustic,acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+ endif
+
+ endif
+
+ endif !if(any_acoustic)
+
+
+! *********************************************************
+! ************* main solver for the elastic elements
+! *********************************************************
+
+ if(any_elastic) then
+ call compute_forces_viscoelastic(p_sv,npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver, &
+ source_type,it,NSTEP,anyabs,assign_external_model, &
+ initialfield,TURN_ATTENUATION_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
+ accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic, &
+ density,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy, &
+ source_time_function,sourcearray,adj_sourcearrays, &
+ e1,e11,e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1, &
+ phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
+ deltat,coord,add_Bielak_conditions, x0_source, z0_source, &
+ A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset, f0(1),&
+ v0x_left(1,it),v0z_left(1,it),v0x_right(1,it),v0z_right(1,it),v0x_bot(1,it),v0z_bot(1,it), &
+ t0x_left(1,it),t0z_left(1,it),t0x_right(1,it),t0z_right(1,it),t0x_bot(1,it),t0z_bot(1,it), &
+ count_left,count_right,count_bottom,over_critical_angle, &
+ NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD, &
+ b_absorb_elastic_left,b_absorb_elastic_right,b_absorb_elastic_bottom,b_absorb_elastic_top, &
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,mu_k,kappa_k)
+
+ if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLZ
+ write(35) b_absorb_elastic_left(1,i,ispec,it)
+ enddo
+ do i=1,NGLLZ
+ write(35) b_absorb_elastic_left(3,i,ispec,it)
+ enddo
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ write(35) b_absorb_elastic_left(2,i,ispec,it)
+ enddo
+ endif
+
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLZ
+ write(36) b_absorb_elastic_right(1,i,ispec,it)
+ enddo
+ do i=1,NGLLZ
+ write(36) b_absorb_elastic_right(3,i,ispec,it)
+ enddo
+ else!SH (membrane) waves
+ do i=1,NGLLZ
+ write(36) b_absorb_elastic_right(2,i,ispec,it)
+ enddo
+ endif
+
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLX
+ write(37) b_absorb_elastic_bottom(1,i,ispec,it)
+ enddo
+ do i=1,NGLLX
+ write(37) b_absorb_elastic_bottom(3,i,ispec,it)
+ enddo
+ else!SH (membrane) waves
+ do i=1,NGLLX
+ write(37) b_absorb_elastic_bottom(2,i,ispec,it)
+ enddo
+ endif
+
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+
+ if(p_sv)then!P-SV waves
+ do i=1,NGLLX
+ write(38) b_absorb_elastic_top(1,i,ispec,it)
+ enddo
+ do i=1,NGLLX
+ write(38) b_absorb_elastic_top(3,i,ispec,it)
+ enddo
+ else!SH (membrane) waves
+ do i=1,NGLLX
+ write(38) b_absorb_elastic_top(2,i,ispec,it)
+ enddo
+ endif
+
+ enddo
+ endif
+
+ endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
+
+ endif !if(any_elastic)
+
+! *********************************************************
+! ************* add coupling with the acoustic side
+! *********************************************************
+
+ if(coupled_acoustic_elastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
+
+! get the corresponding edge of the elastic element
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+ iedge_elastic = fluid_solid_elastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the acoustic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_acoustic)
+ j = jvalue_inverse(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! compute pressure on the fluid/solid edge
+ pressure = - potential_dot_dot_acoustic(iglob)
+ if(SIMULATION_TYPE == 2) then
+ b_pressure = - b_potential_dot_dot_acoustic(iglob)
+ endif
+! get point values for the elastic side
+ ii2 = ivalue(ipoin1D,iedge_elastic)
+ jj2 = jvalue(ipoin1D,iedge_elastic)
+ iglob = ibool(ii2,jj2,ispec_elastic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == ITOP)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_acoustic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) + weight*nx*pressure
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) + weight*nz*pressure
+
+ if(SIMULATION_TYPE == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + weight*nx*b_pressure
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) + weight*nz*b_pressure
+ endif !if(SIMULATION_TYPE == 2) then
+
+ enddo
+
+ enddo
+
+ endif
+
+! ****************************************************************************
+! ************* add coupling with the poroelastic side
+! ****************************************************************************
+ if(coupled_elastic_poro) then
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get poroelastic domain paramters
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec_poroelastic))
+ kappal_s = poroelastcoef(3,1,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec_poroelastic))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec_poroelastic))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
+ kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ mul_G = mul_fr
+ lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+
+ b_dwx_dxi = ZERO
+ b_dwz_dxi = ZERO
+
+ b_dwx_dgamma = ZERO
+ b_dwz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec_poroelastic)
+ xizl = xiz(i,j,ispec_poroelastic)
+ gammaxl = gammax(i,j,ispec_poroelastic)
+ gammazl = gammaz(i,j,ispec_poroelastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+
+ b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
+ b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
+
+ b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
+ b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
+ endif
+! compute stress tensor (include attenuation or anisotropy if needed)
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_G*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ if(SIMULATION_TYPE == 2) then
+ b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ endif
+! get point values for the elastic domain, which matches our side in the inverse direction
+ ii2 = ivalue(ipoin1D,iedge_elastic)
+ jj2 = jvalue(ipoin1D,iedge_elastic)
+ iglob = ibool(ii2,jj2,ispec_elastic)
+
+! get elastic properties
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec_elastic))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec_elastic))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec_elastic))
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
+ duz_dxi = duz_dxi + displ_elastic(3,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
+ duz_dgamma = duz_dgamma + displ_elastic(3,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
+ b_duz_dxi = b_duz_dxi + b_displ_elastic(3,ibool(k,jj2,ispec_elastic))*hprime_xx(ii2,k)
+ b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
+ b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(ii2,k,ispec_elastic))*hprime_zz(jj2,k)
+ endif
+ enddo
+
+ xixl = xix(ii2,jj2,ispec_elastic)
+ xizl = xiz(ii2,jj2,ispec_elastic)
+ gammaxl = gammax(ii2,jj2,ispec_elastic)
+ gammazl = gammaz(ii2,jj2,ispec_elastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+ endif
+! compute stress tensor
+! full anisotropy
+ if(kmato(ispec_elastic) == 2) then
+! implement anisotropy in 2D
+ if(assign_external_model) then
+ c11 = c11ext(ii2,jj2,ispec_elastic)
+ c13 = c13ext(ii2,jj2,ispec_elastic)
+ c15 = c15ext(ii2,jj2,ispec_elastic)
+ c33 = c33ext(ii2,jj2,ispec_elastic)
+ c35 = c35ext(ii2,jj2,ispec_elastic)
+ c55 = c55ext(ii2,jj2,ispec_elastic)
+ else
+ c11 = anisotropy(1,kmato(ispec_elastic))
+ c13 = anisotropy(2,kmato(ispec_elastic))
+ c15 = anisotropy(3,kmato(ispec_elastic))
+ c33 = anisotropy(4,kmato(ispec_elastic))
+ c35 = anisotropy(5,kmato(ispec_elastic))
+ c55 = anisotropy(6,kmato(ispec_elastic))
+ end if
+
+ sigma_xx = sigma_xx + c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
+ sigma_zz = sigma_zz + c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
+ sigma_xz = sigma_xz + c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
+ else
+! no attenuation
+ sigma_xx = sigma_xx + lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
+ sigma_xz = sigma_xz + mul_relaxed*(duz_dxl + dux_dzl)
+ sigma_zz = sigma_zz + lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+ endif
+
+ if(SIMULATION_TYPE == 2) then
+ b_sigma_xx = b_sigma_xx + lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
+ b_sigma_xz = b_sigma_xz + mul_relaxed*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = b_sigma_zz + lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
+ endif
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_poroelastic == ITOP)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_poroelastic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - weight* &
+ (sigma_xx*nx + sigma_xz*nz)/2.d0
+
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) - weight* &
+ (sigma_xz*nx + sigma_zz*nz)/2.d0
+
+ if(SIMULATION_TYPE == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - weight* &
+ (b_sigma_xx*nx + b_sigma_xz*nz)/2.d0
+
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) - weight* &
+ (b_sigma_xz*nx + b_sigma_zz*nz)/2.d0
+ endif !if(SIMULATION_TYPE == 2) then
+
+ enddo
+
+ enddo
+
+ endif
+
+
+! ************************************************************************************
+! ************************************ add force source
+! ************************************************************************************
+
+ if(any_elastic) then
+
+! --- add the source if it is a collocated force
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCES
+! if this processor carries the source and the source element is elastic
+ if (is_proc_source(i_source) == 1 .and. elastic(ispec_selected_source(i_source))) then
+
+! collocated force
+ if(source_type(i_source) == 1) then
+ if(SIMULATION_TYPE == 1) then ! forward wavefield
+
+ if(p_sv) then ! P-SV calculation
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) &
+ - sin(angleforce(i_source))*source_time_function(i_source,it)*hlagrange
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) &
+ + cos(angleforce(i_source))*source_time_function(i_source,it)*hlagrange
+ enddo
+ enddo
+ else ! SH (membrane) calculation
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) &
+ + source_time_function(i_source,it)*hlagrange
+ enddo
+ enddo
+ endif
+
+ else ! backward wavefield
+
+ if(p_sv) then ! P-SV calculation
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) &
+ - sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1) &
+ *hlagrange
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) &
+ + cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1) &
+ *hlagrange
+ enddo
+ enddo
+ else ! SH (membrane) calculation
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) &
+ + source_time_function(i_source,NSTEP-it+1)*hlagrange
+ enddo
+ enddo
+
+ endif
+
+ endif !endif SIMULATION_TYPE == 1
+ endif
+
+ endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCES
+
+ endif ! if not using an initial field
+ endif !if(any_elastic)
+
+! assembling accel_elastic for elastic elements
+#ifdef USE_MPI
+ if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0) then
+ call assemble_MPI_vector_el(accel_elastic,npoin, &
+ ninterface, ninterface_elastic,inum_interfaces_elastic, &
+ max_interface_size, max_ibool_interfaces_size_el,&
+ ibool_interfaces_elastic, nibool_interfaces_elastic, &
+ tab_requests_send_recv_elastic,buffer_send_faces_vector_el, &
+ buffer_recv_faces_vector_el, my_neighbours)
+ endif
+
+ if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0 .and. SIMULATION_TYPE == 2) then
+ call assemble_MPI_vector_el(b_accel_elastic,npoin, &
+ ninterface, ninterface_elastic,inum_interfaces_elastic, &
+ max_interface_size, max_ibool_interfaces_size_el,&
+ ibool_interfaces_elastic, nibool_interfaces_elastic, &
+ tab_requests_send_recv_elastic,buffer_send_faces_vector_el, &
+ buffer_recv_faces_vector_el, my_neighbours)
+ endif
+#endif
+
+
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
+
+ if(any_elastic) then
+ accel_elastic(1,:) = accel_elastic(1,:) * rmass_inverse_elastic
+ accel_elastic(2,:) = accel_elastic(2,:) * rmass_inverse_elastic
+ accel_elastic(3,:) = accel_elastic(3,:) * rmass_inverse_elastic
+
+ veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+
+ if(SIMULATION_TYPE == 2) then
+ b_accel_elastic(1,:) = b_accel_elastic(1,:) * rmass_inverse_elastic(:)
+ b_accel_elastic(2,:) = b_accel_elastic(2,:) * rmass_inverse_elastic(:)
+ b_accel_elastic(3,:) = b_accel_elastic(3,:) * rmass_inverse_elastic(:)
+
+ b_veloc_elastic = b_veloc_elastic + b_deltatover2*b_accel_elastic
+ endif
+
+ endif !if(any_elastic)
+
+
+! ******************************************************************************************************************
+! ************* main solver for the poroelastic elements: first the solid (u_s) than the fluid (w)
+! ******************************************************************************************************************
+
+ if(any_poroelastic) then
+
+ if(SIMULATION_TYPE == 2) then
+! if inviscid fluid, comment the reading and uncomment the zeroing
+! read(23,rec=NSTEP-it+1) b_viscodampx
+! read(24,rec=NSTEP-it+1) b_viscodampz
+ b_viscodampx(:) = ZERO
+ b_viscodampz(:) = ZERO
+ endif
+
+ call compute_forces_poro_solid(npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
+ accels_poroelastic,velocs_poroelastic,velocw_poroelastic,displs_poroelastic,displw_poroelastic,&
+ b_accels_poroelastic,b_displs_poroelastic,b_displw_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,source_time_function,sourcearray,adj_sourcearrays,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu2,N_SLS, &
+ rx_viscous,rz_viscous,theta_e,theta_s,&
+ b_viscodampx,b_viscodampz,&
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
+ jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ mufr_k,B_k,NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD,&
+ b_absorb_poro_s_left,b_absorb_poro_s_right,b_absorb_poro_s_bottom,b_absorb_poro_s_top,&
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,f0(1),freq0,Q0)
+
+
+
+ call compute_forces_poro_fluid(npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
+ accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
+ b_accelw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,source_time_function,sourcearray,adj_sourcearrays,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu2,N_SLS, &
+ rx_viscous,rz_viscous,theta_e,theta_s,&
+ b_viscodampx,b_viscodampz,&
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
+ jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ C_k,M_k,NSOURCES,nrec,SIMULATION_TYPE,SAVE_FORWARD,&
+ b_absorb_poro_w_left,b_absorb_poro_w_right,b_absorb_poro_w_bottom,b_absorb_poro_w_top,&
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_left,ib_right,ib_bottom,ib_top,f0(1),freq0,Q0)
+
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
+! if inviscid fluid, comment
+! write(23,rec=it) b_viscodampx
+! write(24,rec=it) b_viscodampz
+ endif
+
+ if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ write(45) b_absorb_poro_s_left(id,i,ispec,it)
+ write(25) b_absorb_poro_w_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ write(46) b_absorb_poro_s_right(id,i,ispec,it)
+ write(26) b_absorb_poro_w_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ write(47) b_absorb_poro_s_bottom(id,i,ispec,it)
+ write(29) b_absorb_poro_w_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ write(48) b_absorb_poro_s_top(id,i,ispec,it)
+ write(28) b_absorb_poro_w_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ endif ! if(anyabs .and. SAVE_FORWARD .and. SIMULATION_TYPE == 1)
+
+ endif !if(any_poroelastic) then
+
+! *********************************************************
+! ************* add coupling with the acoustic side
+! *********************************************************
+
+ if(coupled_acoustic_poro) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the acoustic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_acoustic)
+ j = jvalue_inverse(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! get poroelastic parameters
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+ rhol_s = density(1,kmato(ispec_poroelastic))
+ rhol_bar = (1._CUSTOM_REAL-phil)*rhol_s + phil*rhol_f
+
+! compute pressure on the fluid/porous medium edge
+ pressure = - potential_dot_dot_acoustic(iglob)
+ if(SIMULATION_TYPE == 2) then
+ b_pressure = - b_potential_dot_dot_acoustic(iglob)
+ endif
+
+! get point values for the poroelastic side
+ ii2 = ivalue(ipoin1D,iedge_poroelastic)
+ jj2 = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(ii2,jj2,ispec_poroelastic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == ITOP)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_acoustic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+! contribution to the solid phase
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + weight*nx*pressure*(1._CUSTOM_REAL-phil/tortl)
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + weight*nz*pressure*(1._CUSTOM_REAL-phil/tortl)
+
+! contribution to the fluid phase
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) + weight*nx*pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + weight*nz*pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+
+ if(SIMULATION_TYPE == 2) then
+! contribution to the solid phase
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-phil/tortl)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-phil/tortl)
+
+! contribution to the fluid phase
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+ endif !if(SIMULATION_TYPE == 2) then
+
+ enddo ! do ipoin1D = 1,NGLLX
+
+ enddo ! do inum = 1,num_fluid_poro_edges
+
+ endif ! if(coupled_acoustic_poro)
+
+! ****************************************************************************
+! ************* add coupling with the elastic side
+! ****************************************************************************
+
+ if(coupled_elastic_poro) then
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the elastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! get elastic properties
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec_elastic))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec_elastic))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec_elastic))
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(3,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displ_elastic(3,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displ_elastic(3,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displ_elastic(3,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec_elastic)
+ xizl = xiz(i,j,ispec_elastic)
+ gammaxl = gammax(i,j,ispec_elastic)
+ gammazl = gammaz(i,j,ispec_elastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+ endif
+! compute stress tensor
+! full anisotropy
+ if(kmato(ispec_elastic) == 2) then
+! implement anisotropy in 2D
+ if(assign_external_model) then
+ c11 = c11ext(i,j,ispec_elastic)
+ c13 = c13ext(i,j,ispec_elastic)
+ c15 = c15ext(i,j,ispec_elastic)
+ c33 = c33ext(i,j,ispec_elastic)
+ c35 = c35ext(i,j,ispec_elastic)
+ c55 = c55ext(i,j,ispec_elastic)
+ else
+ c11 = anisotropy(1,kmato(ispec_elastic))
+ c13 = anisotropy(2,kmato(ispec_elastic))
+ c15 = anisotropy(3,kmato(ispec_elastic))
+ c33 = anisotropy(4,kmato(ispec_elastic))
+ c35 = anisotropy(5,kmato(ispec_elastic))
+ c55 = anisotropy(6,kmato(ispec_elastic))
+ end if
+ sigma_xx = c11*dux_dxl + c15*(duz_dxl + dux_dzl) + c13*duz_dzl
+ sigma_zz = c13*dux_dxl + c35*(duz_dxl + dux_dzl) + c33*duz_dzl
+ sigma_xz = c15*dux_dxl + c55*(duz_dxl + dux_dzl) + c35*duz_dzl
+ else
+! no attenuation
+ sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
+ sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+ endif
+
+ if(SIMULATION_TYPE == 2) then
+ b_sigma_xx = lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
+ b_sigma_xz = mul_relaxed*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
+ endif ! if(SIMULATION_TYPE == 2)
+
+! get point values for the poroelastic side
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get poroelastic domain paramters
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec_poroelastic))
+ kappal_s = poroelastcoef(3,1,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec_poroelastic))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec_poroelastic))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
+ kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ mul_G = mul_fr
+ lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+
+ b_dwx_dxi = ZERO
+ b_dwz_dxi = ZERO
+
+ b_dwx_dgamma = ZERO
+ b_dwz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec_poroelastic)
+ xizl = xiz(i,j,ispec_poroelastic)
+ gammaxl = gammax(i,j,ispec_poroelastic)
+ gammazl = gammaz(i,j,ispec_poroelastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ if(SIMULATION_TYPE == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+
+ b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
+ b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
+
+ b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
+ b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
+ endif
+! compute stress tensor
+
+! no attenuation
+ sigma_xx = sigma_xx + lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = sigma_xz + mul_G*(duz_dxl + dux_dzl)
+ sigma_zz = sigma_zz + lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+ if(SIMULATION_TYPE == 2) then
+ b_sigma_xx = b_sigma_xx + lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigma_xz = b_sigma_xz + mul_G*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = b_sigma_zz + lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigmap = C_biot*(b_dux_dxl + b_duz_dzl) + M_biot*(b_dwx_dxl + b_dwz_dzl)
+ endif
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_poroelastic == ITOP)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_poroelastic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+! contribution to the solid phase
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + &
+ weight*((sigma_xx*nx + sigma_xz*nz)/2.d0 -phil/tortl*sigmap*nx)
+
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + &
+ weight*((sigma_xz*nx + sigma_zz*nz)/2.d0 -phil/tortl*sigmap*nz)
+
+! contribution to the fluid phase
+! w = 0
+
+ if(SIMULATION_TYPE == 2) then
+! contribution to the solid phase
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + &
+ weight*((b_sigma_xx*nx + b_sigma_xz*nz)/2.d0 -phil/tortl*b_sigmap*nx)
+
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + &
+ weight*((b_sigma_xz*nx + b_sigma_zz*nz)/2.d0 -phil/tortl*b_sigmap*nz)
+
+! contribution to the fluid phase
+! w = 0
+ endif !if(SIMULATION_TYPE == 2) then
+
+ enddo
+
+ enddo
+
+ endif ! if(coupled_elastic_poro)
+
+
+! ************************************************************************************
+! ******************************** add force source
+! ************************************************************************************
+
+ if(any_poroelastic) then
+
+
+! --- add the source if it is a collocated force
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCES
+! if this processor carries the source and the source element is elastic
+ if (is_proc_source(i_source) == 1 .and. poroelastic(ispec_selected_source(i_source))) then
+
+ phil = porosity(kmato(ispec_selected_source(i_source)))
+ tortl = tortuosity(kmato(ispec_selected_source(i_source)))
+ rhol_s = density(1,kmato(ispec_selected_source(i_source)))
+ rhol_f = density(2,kmato(ispec_selected_source(i_source)))
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+
+! collocated force
+ if(source_type(i_source) == 1) then
+ if(SIMULATION_TYPE == 1) then ! forward wavefield
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+! s
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) - hlagrange * &
+ (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,it)
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + hlagrange * &
+ (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,it)
+! w
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - hlagrange * &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,it)
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + hlagrange * &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,it)
+ enddo
+ enddo
+ else ! backward wavefield
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ hlagrange = hxis_store(i_source,i) * hgammas_store(i_source,j)
+! b_s
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) - hlagrange * &
+ (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + hlagrange * &
+ (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+!b_w
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - hlagrange * &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + hlagrange * &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ enddo
+ enddo
+ endif !endif SIMULATION_TYPE == 1
+ endif
+
+ endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCES
+
+ endif ! if not using an initial field
+ endif !if(any_poroelastic)
+
+! assembling accels_proelastic & accelw_poroelastic for poroelastic elements
+#ifdef USE_MPI
+ if (nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0) then
+ call assemble_MPI_vector_po(accels_poroelastic,accelw_poroelastic,npoin, &
+ ninterface, ninterface_poroelastic,inum_interfaces_poroelastic, &
+ max_interface_size, max_ibool_interfaces_size_po,&
+ ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
+ tab_requests_send_recv_poro,buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
+ my_neighbours)
+ endif
+
+ if (nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0 .and. SIMULATION_TYPE == 2) then
+ call assemble_MPI_vector_po(b_accels_poroelastic,b_accelw_poroelastic,npoin, &
+ ninterface, ninterface_poroelastic,inum_interfaces_poroelastic, &
+ max_interface_size, max_ibool_interfaces_size_po,&
+ ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
+ tab_requests_send_recv_poro,buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
+ my_neighbours)
+ endif
+#endif
+
+
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
+
+ if(any_poroelastic) then
+ accels_poroelastic(1,:) = accels_poroelastic(1,:) * rmass_s_inverse_poroelastic(:)
+ accels_poroelastic(2,:) = accels_poroelastic(2,:) * rmass_s_inverse_poroelastic(:)
+ velocs_poroelastic = velocs_poroelastic + deltatover2*accels_poroelastic
+
+ accelw_poroelastic(1,:) = accelw_poroelastic(1,:) * rmass_w_inverse_poroelastic(:)
+ accelw_poroelastic(2,:) = accelw_poroelastic(2,:) * rmass_w_inverse_poroelastic(:)
+ velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
+
+ if(SIMULATION_TYPE == 2) then
+ b_accels_poroelastic(1,:) = b_accels_poroelastic(1,:) * rmass_s_inverse_poroelastic(:)
+ b_accels_poroelastic(2,:) = b_accels_poroelastic(2,:) * rmass_s_inverse_poroelastic(:)
+ b_velocs_poroelastic = b_velocs_poroelastic + b_deltatover2*b_accels_poroelastic
+
+ b_accelw_poroelastic(1,:) = b_accelw_poroelastic(1,:) * rmass_w_inverse_poroelastic(:)
+ b_accelw_poroelastic(2,:) = b_accelw_poroelastic(2,:) * rmass_w_inverse_poroelastic(:)
+ b_velocw_poroelastic = b_velocw_poroelastic + b_deltatover2*b_accelw_poroelastic
+ endif
+
+ endif !if(any_poroelastic)
+
+!*******************************************************************************
+! assembling the displacements on the elastic-poro boundaries
+!*******************************************************************************
+ if(coupled_elastic_poro) then
+ icount(:)=ZERO
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+ do ipoin1D = 1,NGLLX
+! recovering original velocities and accelerations on boundaries (elastic side)
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+ icount(iglob) = icount(iglob) + 1
+
+ if(icount(iglob) ==1)then
+ veloc_elastic(1,iglob) = veloc_elastic(1,iglob) - deltatover2*accel_elastic(1,iglob)
+ veloc_elastic(3,iglob) = veloc_elastic(3,iglob) - deltatover2*accel_elastic(3,iglob)
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) / rmass_inverse_elastic(iglob)
+ accel_elastic(3,iglob) = accel_elastic(3,iglob) / rmass_inverse_elastic(iglob)
+! recovering original velocities and accelerations on boundaries (poro side)
+ velocs_poroelastic(1,iglob) = velocs_poroelastic(1,iglob) - deltatover2*accels_poroelastic(1,iglob)
+ velocs_poroelastic(2,iglob) = velocs_poroelastic(2,iglob) - deltatover2*accels_poroelastic(2,iglob)
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) / rmass_s_inverse_poroelastic(iglob)
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) / rmass_s_inverse_poroelastic(iglob)
+! assembling accelerations
+ accel_elastic(1,iglob) = ( accel_elastic(1,iglob) + accels_poroelastic(1,iglob) ) / &
+ ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
+ accel_elastic(3,iglob) = ( accel_elastic(3,iglob) + accels_poroelastic(2,iglob) ) / &
+ ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
+ accels_poroelastic(1,iglob) = accel_elastic(1,iglob)
+ accels_poroelastic(2,iglob) = accel_elastic(3,iglob)
+! updating velocities
+ velocs_poroelastic(1,iglob) = velocs_poroelastic(1,iglob) + deltatover2*accels_poroelastic(1,iglob)
+ velocs_poroelastic(2,iglob) = velocs_poroelastic(2,iglob) + deltatover2*accels_poroelastic(2,iglob)
+ veloc_elastic(1,iglob) = veloc_elastic(1,iglob) + deltatover2*accel_elastic(1,iglob)
+ veloc_elastic(3,iglob) = veloc_elastic(3,iglob) + deltatover2*accel_elastic(3,iglob)
+! zeros w
+ accelw_poroelastic(1,iglob) = ZERO
+ accelw_poroelastic(2,iglob) = ZERO
+ velocw_poroelastic(1,iglob) = ZERO
+ velocw_poroelastic(2,iglob) = ZERO
+
+ if(SIMULATION_TYPE == 2) then
+ b_veloc_elastic(1,iglob) = b_veloc_elastic(1,iglob) - b_deltatover2*b_accel_elastic(1,iglob)
+ b_veloc_elastic(3,iglob) = b_veloc_elastic(3,iglob) - b_deltatover2*b_accel_elastic(3,iglob)
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) / rmass_inverse_elastic(iglob)
+ b_accel_elastic(3,iglob) = b_accel_elastic(3,iglob) / rmass_inverse_elastic(iglob)
+! recovering original velocities and accelerations on boundaries (poro side)
+ b_velocs_poroelastic(1,iglob) = b_velocs_poroelastic(1,iglob) - b_deltatover2*b_accels_poroelastic(1,iglob)
+ b_velocs_poroelastic(2,iglob) = b_velocs_poroelastic(2,iglob) - b_deltatover2*b_accels_poroelastic(2,iglob)
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) / rmass_s_inverse_poroelastic(iglob)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) / rmass_s_inverse_poroelastic(iglob)
+! assembling accelerations
+ b_accel_elastic(1,iglob) = ( b_accel_elastic(1,iglob) + b_accels_poroelastic(1,iglob) ) / &
+ ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
+ b_accel_elastic(3,iglob) = ( b_accel_elastic(3,iglob) + b_accels_poroelastic(2,iglob) ) / &
+ ( 1.0/rmass_inverse_elastic(iglob) +1.0/rmass_s_inverse_poroelastic(iglob) )
+ b_accels_poroelastic(1,iglob) = b_accel_elastic(1,iglob)
+ b_accels_poroelastic(2,iglob) = b_accel_elastic(3,iglob)
+! updating velocities
+ b_velocs_poroelastic(1,iglob) = b_velocs_poroelastic(1,iglob) + b_deltatover2*b_accels_poroelastic(1,iglob)
+ b_velocs_poroelastic(2,iglob) = b_velocs_poroelastic(2,iglob) + b_deltatover2*b_accels_poroelastic(2,iglob)
+ b_veloc_elastic(1,iglob) = b_veloc_elastic(1,iglob) + b_deltatover2*b_accel_elastic(1,iglob)
+ b_veloc_elastic(3,iglob) = b_veloc_elastic(3,iglob) + b_deltatover2*b_accel_elastic(3,iglob)
+! zeros w
+ b_accelw_poroelastic(1,iglob) = ZERO
+ b_accelw_poroelastic(2,iglob) = ZERO
+ b_velocw_poroelastic(1,iglob) = ZERO
+ b_velocw_poroelastic(2,iglob) = ZERO
+ endif !if(SIMULATION_TYPE == 2)
+
+ endif !if(icount(iglob) ==1)
+
+ enddo
+
+ enddo
+ endif
+
+! ********************************************************************************************
+! reading lastframe for adjoint/kernels calculation
+! ********************************************************************************************
+ if(it == 1 .and. SIMULATION_TYPE == 2) then
+
+! acoustic medium
+ if(any_acoustic) then
+ write(outputname,'(a,i6.6,a)') 'lastframe_acoustic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ do j=1,npoin
+ read(55) b_potential_acoustic(j),&
+ b_potential_dot_acoustic(j),&
+ b_potential_dot_dot_acoustic(j)
+ enddo
+ close(55)
+
+! free surface for an acoustic medium
+ if ( nelem_acoustic_surface > 0 ) then
+ call enforce_acoustic_free_surface(b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
+ b_potential_acoustic,acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+ endif
+ endif
+
+! elastic medium
+ if(any_elastic) then
+ write(outputname,'(a,i6.6,a)') 'lastframe_elastic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ if(p_sv)then !P-SV waves
+ do j=1,npoin
+ read(55) (b_displ_elastic(i,j), i=1,NDIM), &
+ (b_veloc_elastic(i,j), i=1,NDIM), &
+ (b_accel_elastic(i,j), i=1,NDIM)
+ enddo
+ b_displ_elastic(3,:) = b_displ_elastic(2,:)
+ b_displ_elastic(2,:) = 0._CUSTOM_REAL
+ b_veloc_elastic(3,:) = b_veloc_elastic(2,:)
+ b_veloc_elastic(2,:) = 0._CUSTOM_REAL
+ b_accel_elastic(3,:) = b_accel_elastic(2,:)
+ b_accel_elastic(2,:) = 0._CUSTOM_REAL
+ else !SH (membrane) waves
+ do j=1,npoin
+ read(55) b_displ_elastic(2,j), &
+ b_veloc_elastic(2,j), &
+ b_accel_elastic(2,j)
+ enddo
+ b_displ_elastic(1,:) = 0._CUSTOM_REAL
+ b_displ_elastic(3,:) = 0._CUSTOM_REAL
+ b_veloc_elastic(1,:) = 0._CUSTOM_REAL
+ b_veloc_elastic(3,:) = 0._CUSTOM_REAL
+ b_accel_elastic(1,:) = 0._CUSTOM_REAL
+ b_accel_elastic(3,:) = 0._CUSTOM_REAL
+ endif
+ close(55)
+ endif
+
+! poroelastic medium
+ if(any_poroelastic) then
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_w',myrank,'.bin'
+ open(unit=56,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ do j=1,npoin
+ read(55) (b_displs_poroelastic(i,j), i=1,NDIM), &
+ (b_velocs_poroelastic(i,j), i=1,NDIM), &
+ (b_accels_poroelastic(i,j), i=1,NDIM)
+ read(56) (b_displw_poroelastic(i,j), i=1,NDIM), &
+ (b_velocw_poroelastic(i,j), i=1,NDIM), &
+ (b_accelw_poroelastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+ close(56)
+ endif
+
+ endif ! if(it == 1 .and. SIMULATION_TYPE == 2)
+
+! ********************************************************************************************
+! kernels calculation
+! ********************************************************************************************
+ if(any_elastic .and. SIMULATION_TYPE == 2) then ! kernels calculation
+ do iglob = 1,npoin
+ rho_k(iglob) = accel_elastic(1,iglob)*b_displ_elastic(1,iglob) +&
+ accel_elastic(2,iglob)*b_displ_elastic(2,iglob) +&
+ accel_elastic(3,iglob)*b_displ_elastic(3,iglob)
+ rhorho_el_hessian_temp1(iglob) = accel_elastic(1,iglob)*accel_elastic(1,iglob) +&
+ accel_elastic(2,iglob)*accel_elastic(2,iglob) +&
+ accel_elastic(3,iglob)*accel_elastic(3,iglob)
+ rhorho_el_hessian_temp2(iglob) = accel_elastic(1,iglob)*b_accel_elastic(1,iglob) +&
+ accel_elastic(2,iglob)*b_accel_elastic(2,iglob) +&
+ accel_elastic(3,iglob)*b_accel_elastic(3,iglob)
+ enddo
+ endif
+
+ if(any_poroelastic .and. SIMULATION_TYPE ==2) then
+ do iglob =1,npoin
+ rhot_k(iglob) = accels_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
+ accels_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob)
+ rhof_k(iglob) = accelw_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
+ accelw_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob) + &
+ accels_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ accels_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ sm_k(iglob) = accelw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ accelw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ eta_k(iglob) = velocw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ velocw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ enddo
+ endif
+
+!---- compute kinetic and potential energy
+ if(OUTPUT_ENERGY) &
+ call compute_energy(displ_elastic,veloc_elastic, &
+ displs_poroelastic,velocs_poroelastic, &
+ displw_poroelastic,velocw_poroelastic, &
+ xix,xiz,gammax,gammaz,jacobian,ibool,elastic,poroelastic,hprime_xx,hprime_zz, &
+ nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ assign_external_model,it,deltat,t0,kmato,poroelastcoef,density, &
+ porosity,tortuosity, &
+ vpext,vsext,rhoext,c11ext,c13ext,c15ext,c33ext,c35ext,c55ext, &
+ anisotropic,anisotropy,wxgll,wzgll,numat, &
+ pressure_element,vector_field_element,e1,e11, &
+ potential_dot_acoustic,potential_dot_dot_acoustic, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS,p_sv)
+
+!---- display time step and max of norm of displacement
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
+ call check_stability(myrank,time,it,NSTEP, &
+ npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ any_elastic_glob,any_elastic,displ_elastic, &
+ any_poroelastic_glob,any_poroelastic, &
+ displs_poroelastic,displw_poroelastic, &
+ any_acoustic_glob,any_acoustic,potential_acoustic, &
+ year_start,month_start,time_start)
+ endif
+
+! loop on all the receivers to compute and store the seismograms
+ do irecloc = 1,nrecloc
+
+ irec = recloc(irecloc)
+
+ ispec = ispec_selected_rec(irec)
+
+! compute pressure in this element if needed
+ if(seismotype == 4) then
+
+ call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
+ npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,ispec,e1,e11, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
+
+ else if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+
+! for acoustic medium, compute vector field from gradient of potential for seismograms
+ if(seismotype == 1) then
+ call compute_vector_one_element(vector_field_element,potential_acoustic, &
+ displ_elastic,displs_poroelastic,&
+ elastic,poroelastic,xix,xiz,gammax,gammaz, &
+ ibool,hprime_xx,hprime_zz, &
+ nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ ispec,numat,kmato,density,rhoext,assign_external_model)
+ else if(seismotype == 2) then
+ call compute_vector_one_element(vector_field_element,potential_dot_acoustic, &
+ veloc_elastic,velocs_poroelastic, &
+ elastic,poroelastic,xix,xiz,gammax,gammaz, &
+ ibool,hprime_xx,hprime_zz, &
+ nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ ispec,numat,kmato,density,rhoext,assign_external_model)
+ else if(seismotype == 3) then
+ call compute_vector_one_element(vector_field_element,potential_dot_dot_acoustic, &
+ accel_elastic,accels_poroelastic, &
+ elastic,poroelastic,xix,xiz,gammax,gammaz, &
+ ibool,hprime_xx,hprime_zz, &
+ nspec,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ ispec,numat,kmato,density,rhoext,assign_external_model)
+ endif
+
+ else if(seismotype == 5) then
+ call compute_curl_one_element(curl_element,displ_elastic, &
+ displs_poroelastic,elastic,poroelastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
+ nspec,npoin_elastic,npoin_poroelastic,ispec)
+ endif
+
+! perform the general interpolation using Lagrange polynomials
+ valux = ZERO
+ valuy = ZERO
+ valuz = ZERO
+ valcurl = ZERO
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ hlagrange = hxir_store(irec,i)*hgammar_store(irec,j)
+
+ dcurld=ZERO
+
+ if(seismotype == 4) then
+
+ dxd = pressure_element(i,j)
+ dzd = ZERO
+
+ else if(.not. elastic(ispec) .and. .not. poroelastic(ispec) .and. seismotype /= 6) then
+
+ dxd = vector_field_element(1,i,j)
+ dzd = vector_field_element(3,i,j)
+
+ else if(seismotype == 6) then
+
+ dxd = potential_acoustic(iglob)
+ dzd = ZERO
+
+ else if(seismotype == 1) then
+
+ if(poroelastic(ispec)) then
+ dxd = displs_poroelastic(1,iglob)
+ dzd = displs_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
+ dxd = displ_elastic(1,iglob)
+ dyd = displ_elastic(2,iglob)
+ dzd = displ_elastic(3,iglob)
+ endif
+
+ else if(seismotype == 2) then
+
+ if(poroelastic(ispec)) then
+ dxd = velocs_poroelastic(1,iglob)
+ dzd = velocs_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
+ dxd = veloc_elastic(1,iglob)
+ dyd = veloc_elastic(2,iglob)
+ dzd = veloc_elastic(3,iglob)
+ endif
+
+ else if(seismotype == 3) then
+
+ if(poroelastic(ispec)) then
+ dxd = accels_poroelastic(1,iglob)
+ dzd = accels_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
+ dxd = accel_elastic(1,iglob)
+ dyd = accel_elastic(2,iglob)
+ dzd = accel_elastic(3,iglob)
+ endif
+
+ else if(seismotype == 5) then
+
+ if(poroelastic(ispec)) then
+ dxd = displs_poroelastic(1,iglob)
+ dzd = displs_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
+ dxd = displ_elastic(1,iglob)
+ dzd = displ_elastic(2,iglob)
+ endif
+ dcurld = curl_element(i,j)
+
+ endif
+
+! compute interpolated field
+ valux = valux + dxd*hlagrange
+ if(elastic(ispec)) valuy = valuy + dyd*hlagrange
+ valuz = valuz + dzd*hlagrange
+ valcurl = valcurl + dcurld*hlagrange
+
+ enddo
+ enddo
+
+! rotate seismogram components if needed, except if recording pressure, which is a scalar
+ if(seismotype /= 4 .and. seismotype /= 6) then
+ if(p_sv) then
+ sisux(seismo_current,irecloc) = cosrot_irec(irecloc)*valux + sinrot_irec(irecloc)*valuz
+ sisuz(seismo_current,irecloc) = - sinrot_irec(irecloc)*valux + cosrot_irec(irecloc)*valuz
+ else
+ sisux(seismo_current,irecloc) = valuy
+ sisuz(seismo_current,irecloc) = ZERO
+ endif
+ else
+ sisux(seismo_current,irecloc) = valux
+ sisuz(seismo_current,irecloc) = ZERO
+ endif
+ siscurl(seismo_current,irecloc) = valcurl
+
+ enddo
+
+
+!----- writing the kernels
+!
+! kernels output
+ if(SIMULATION_TYPE == 2) then
+
+ if(any_acoustic) then
+
+ do ispec = 1, nspec
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ kappal_ac_global(iglob) = poroelastcoef(3,1,kmato(ispec))
+ rhol_ac_global(iglob) = density(1,kmato(ispec))
+
+! calcul the displacement by computing the gradient of potential / rho
+! and calcul the acceleration by computing the gradient of potential_dot_dot / rho
+ tempx1l = ZERO
+ tempx2l = ZERO
+ b_tempx1l = ZERO
+ b_tempx2l = ZERO
+ do k = 1,NGLLX
+! derivative along x
+ tempx1l = tempx1l + potential_dot_dot_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+ b_tempx1l = b_tempx1l + b_potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+ bb_tempx1l = bb_tempx1l + b_potential_dot_dot_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+! derivative along z
+ tempx2l = tempx2l + potential_dot_dot_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+ b_tempx2l = b_tempx2l + b_potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+ bb_tempx2l = bb_tempx2l + b_potential_dot_dot_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ if(assign_external_model) rhol_ac_global(iglob) = rhoext(i,j,ispec)
+
+! derivatives of potential
+ accel_ac(1,iglob) = (tempx1l*xixl + tempx2l*gammaxl) / rhol_ac_global(iglob)
+ accel_ac(2,iglob) = (tempx1l*xizl + tempx2l*gammazl) / rhol_ac_global(iglob)
+ b_displ_ac(1,iglob) = (b_tempx1l*xixl + b_tempx2l*gammaxl) / rhol_ac_global(iglob)
+ b_displ_ac(2,iglob) = (b_tempx1l*xizl + b_tempx2l*gammazl) / rhol_ac_global(iglob)
+ b_accel_ac(1,iglob) = (bb_tempx1l*xixl + bb_tempx2l*gammaxl) / rhol_ac_global(iglob)
+ b_accel_ac(2,iglob) = (bb_tempx1l*xizl + bb_tempx2l*gammazl) / rhol_ac_global(iglob)
+
+ enddo !i = 1, NGLLX
+ enddo !j = 1, NGLLZ
+ endif
+ enddo
+
+ do ispec = 1,nspec
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ rho_ac_kl(i,j,ispec) = rho_ac_kl(i,j,ispec) - rhol_ac_global(iglob) * &
+ dot_product(accel_ac(:,iglob),b_displ_ac(:,iglob)) * deltat
+ kappa_ac_kl(i,j,ispec) = kappa_ac_kl(i,j,ispec) - kappal_ac_global(iglob) * &
+ potential_dot_dot_acoustic(iglob)/kappal_ac_global(iglob) * &
+ b_potential_dot_dot_acoustic(iglob)/kappal_ac_global(iglob)&
+ * deltat
+!
+ rhop_ac_kl(i,j,ispec) = rho_ac_kl(i,j,ispec) + kappa_ac_kl(i,j,ispec)
+ alpha_ac_kl(i,j,ispec) = TWO * kappa_ac_kl(i,j,ispec)
+ rhorho_ac_hessian_final1(i,j,ispec) = rhorho_ac_hessian_final1(i,j,ispec) + &
+ dot_product(accel_ac(:,iglob),accel_ac(:,iglob)) * deltat
+ rhorho_ac_hessian_final2(i,j,ispec) = rhorho_ac_hessian_final2(i,j,ispec) + &
+ dot_product(accel_ac(:,iglob),b_accel_ac(:,iglob)) * deltat
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif !if(any_acoustic)
+
+ if(any_elastic) then
+
+ do ispec = 1, nspec
+ if(elastic(ispec)) then
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ mul_global(iglob) = poroelastcoef(2,1,kmato(ispec))
+ kappal_global(iglob) = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_global(iglob)/3._CUSTOM_REAL
+ rhol_global(iglob) = density(1,kmato(ispec))
+
+ rho_kl(i,j,ispec) = rho_kl(i,j,ispec) - rhol_global(iglob) * rho_k(iglob) * deltat
+ mu_kl(i,j,ispec) = mu_kl(i,j,ispec) - TWO * mul_global(iglob) * mu_k(iglob) * deltat
+ kappa_kl(i,j,ispec) = kappa_kl(i,j,ispec) - kappal_global(iglob) * kappa_k(iglob) * deltat
+!
+ rhop_kl(i,j,ispec) = rho_kl(i,j,ispec) + kappa_kl(i,j,ispec) + mu_kl(i,j,ispec)
+ beta_kl(i,j,ispec) = TWO * (mu_kl(i,j,ispec) - 4._CUSTOM_REAL * mul_global(iglob) &
+ / (3._CUSTOM_REAL * kappal_global(iglob)) * kappa_kl(i,j,ispec))
+ alpha_kl(i,j,ispec) = TWO * (1._CUSTOM_REAL + 4._CUSTOM_REAL * mul_global(iglob)/&
+ (3._CUSTOM_REAL * kappal_global(iglob))) * kappa_kl(i,j,ispec)
+ rhorho_el_hessian_final1(i,j,ispec) = rhorho_el_hessian_final1(i,j,ispec) + rhorho_el_hessian_temp1(iglob) * deltat
+ rhorho_el_hessian_final2(i,j,ispec) = rhorho_el_hessian_final2(i,j,ispec) + rhorho_el_hessian_temp2(iglob) * deltat
+
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif !if(any_elastic)
+
+ if(any_poroelastic) then
+
+ do ispec = 1, nspec
+ if(poroelastic(ispec)) then
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ phil_global(iglob) = porosity(kmato(ispec))
+ tortl_global(iglob) = tortuosity(kmato(ispec))
+ rhol_s_global(iglob) = density(1,kmato(ispec))
+ rhol_f_global(iglob) = density(2,kmato(ispec))
+ rhol_bar_global(iglob) = (1._CUSTOM_REAL - phil_global(iglob))*rhol_s_global(iglob) &
+ + phil_global(iglob)*rhol_f_global(iglob)
+ etal_f_global(iglob) = poroelastcoef(2,2,kmato(ispec))
+ permlxx_global(iglob) = permeability(1,kmato(ispec))
+ permlxz_global(iglob) = permeability(2,kmato(ispec))
+ permlzz_global(iglob) = permeability(3,kmato(ispec))
+ mulfr_global(iglob) = poroelastcoef(2,3,kmato(ispec))
+
+ rhot_kl(i,j,ispec) = rhot_kl(i,j,ispec) - deltat * rhol_bar_global(iglob) * rhot_k(iglob)
+ rhof_kl(i,j,ispec) = rhof_kl(i,j,ispec) - deltat * rhol_f_global(iglob) * rhof_k(iglob)
+ sm_kl(i,j,ispec) = sm_kl(i,j,ispec) - deltat * rhol_f_global(iglob)*tortl_global(iglob)/phil_global(iglob) * sm_k(iglob)
+!at the moment works with constant permeability
+ eta_kl(i,j,ispec) = eta_kl(i,j,ispec) - deltat * etal_f_global(iglob)/permlxx_global(iglob) * eta_k(iglob)
+ B_kl(i,j,ispec) = B_kl(i,j,ispec) - deltat * B_k(iglob)
+ C_kl(i,j,ispec) = C_kl(i,j,ispec) - deltat * C_k(iglob)
+ M_kl(i,j,ispec) = M_kl(i,j,ispec) - deltat * M_k(iglob)
+ mufr_kl(i,j,ispec) = mufr_kl(i,j,ispec) - TWO * deltat * mufr_k(iglob)
+! density kernels
+ rholb = rhol_bar_global(iglob) - phil_global(iglob)*rhol_f_global(iglob)/tortl_global(iglob)
+ rhob_kl(i,j,ispec) = rhot_kl(i,j,ispec) + B_kl(i,j,ispec) + mufr_kl(i,j,ispec)
+ rhofb_kl(i,j,ispec) = rhof_kl(i,j,ispec) + C_kl(i,j,ispec) + M_kl(i,j,ispec) + sm_kl(i,j,ispec)
+ Bb_kl(i,j,ispec) = B_kl(i,j,ispec)
+ Cb_kl(i,j,ispec) = C_kl(i,j,ispec)
+ Mb_kl(i,j,ispec) = M_kl(i,j,ispec)
+ mufrb_kl(i,j,ispec) = mufr_kl(i,j,ispec)
+ phi_kl(i,j,ispec) = - sm_kl(i,j,ispec) - M_kl(i,j,ispec)
+! wave speed kernels
+ dd1 = (1._CUSTOM_REAL+rholb/rhol_f_global(iglob))*ratio**2 + 2._CUSTOM_REAL*ratio +&
+ tortl_global(iglob)/phil_global(iglob)
+ rhobb_kl(i,j,ispec) = rhob_kl(i,j,ispec) - &
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIIsquare + (cpIsquare - cpIIsquare)*( (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1+&
+ (rhol_bar_global(iglob)**2*ratio**2/rhol_f_global(iglob)**2*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+1)*(phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*&
+ (1+rhol_f_global(iglob)/rhol_bar_global(iglob))-1) )/dd1**2 )- FOUR_THIRDS*cssquare )*&
+ Bb_kl(i,j,ispec) - &
+ rhol_bar_global(iglob)*ratio**2/M_biot * (cpIsquare - cpIIsquare)* &
+ (phil_global(iglob)/tortl_global(iglob)*ratio + 1._CUSTOM_REAL)**2/dd1**2*Mb_kl(i,j,ispec) + &
+ rhol_bar_global(iglob)*ratio/C_biot * (cpIsquare - cpIIsquare)* (&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ phil_global(iglob)*ratio/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
+ (1+rhol_bar_global(iglob)*ratio/rhol_f_global(iglob))/dd1**2)*Cb_kl(i,j,ispec)+ &
+ phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
+ rhofbb_kl(i,j,ispec) = rhofb_kl(i,j,ispec) + &
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIIsquare + (cpIsquare - cpIIsquare)*( (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1+&
+ (rhol_bar_global(iglob)**2*ratio**2/rhol_f_global(iglob)**2*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+1)*(phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*&
+ (1+rhol_f_global(iglob)/rhol_bar_global(iglob))-1) )/dd1**2 )- FOUR_THIRDS*cssquare )*&
+ Bb_kl(i,j,ispec) + &
+ rhol_bar_global(iglob)*ratio**2/M_biot * (cpIsquare - cpIIsquare)* &
+ (phil_global(iglob)/tortl_global(iglob)*ratio + 1._CUSTOM_REAL)**2/dd1**2*Mb_kl(i,j,ispec) - &
+ rhol_bar_global(iglob)*ratio/C_biot * (cpIsquare - cpIIsquare)* (&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ phil_global(iglob)*ratio/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
+ (1+rhol_bar_global(iglob)*ratio/rhol_f_global(iglob))/dd1**2)*Cb_kl(i,j,ispec)- &
+ phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
+ phib_kl(i,j,ispec) = phi_kl(i,j,ispec) - &
+ phil_global(iglob)*rhol_bar_global(iglob)/(tortl_global(iglob)*B_biot) * ( cpIsquare - rhol_f_global(iglob)/&
+ rhol_bar_global(iglob)*cpIIsquare- &
+ (cpIsquare-cpIIsquare)*( (TWO*ratio**2*phil_global(iglob)/tortl_global(iglob) + (1._CUSTOM_REAL+&
+ rhol_f_global(iglob)/rhol_bar_global(iglob))*(TWO*ratio*phil_global(iglob)/tortl_global(iglob)+&
+ 1._CUSTOM_REAL))/dd1 + (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)*&
+ ratio/tortl_global(iglob)+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/&
+ rhol_bar_global(iglob))-1._CUSTOM_REAL)*((1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-&
+ TWO*phil_global(iglob)/tortl_global(iglob))*ratio**2+TWO*ratio)/dd1**2 ) - &
+ FOUR_THIRDS*rhol_f_global(iglob)*cssquare/rhol_bar_global(iglob) )*Bb_kl(i,j,ispec) + &
+ rhol_f_global(iglob)/M_biot * (cpIsquare-cpIIsquare)*(&
+ TWO*ratio*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2*((1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)-TWO*phil_global(iglob)/tortl_global(iglob))*ratio**2+TWO*ratio)/dd1**2&
+ )*Mb_kl(i,j,ispec) + &
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*C_biot)*(cpIsquare-cpIIsquare)*ratio* (&
+ (1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob)*ratio)/dd1 - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)*ratio)*((1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-TWO*&
+ phil_global(iglob)/tortl_global(iglob))*ratio+TWO)/dd1**2&
+ )*Cb_kl(i,j,ispec) -&
+ phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(i,j,ispec)
+ cpI_kl(i,j,ispec) = 2._CUSTOM_REAL*cpIsquare/B_biot*rhol_bar_global(iglob)*( &
+ 1._CUSTOM_REAL-phil_global(iglob)/tortl_global(iglob) + &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-&
+ 1._CUSTOM_REAL)/dd1 &
+ )* Bb_kl(i,j,ispec) +&
+ 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) *&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2/dd1*Mb_kl(i,j,ispec)+&
+ 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)/C_biot * &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)*ratio)/dd1*Cb_kl(i,j,ispec)
+ cpII_kl(i,j,ispec) = 2._CUSTOM_REAL*cpIIsquare*rhol_bar_global(iglob)/B_biot * (&
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*rhol_bar_global(iglob)) - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-&
+ 1._CUSTOM_REAL)/dd1 ) * Bb_kl(i,j,ispec) +&
+ 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) * (&
+ 1._CUSTOM_REAL - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2/dd1 )*Mb_kl(i,j,ispec) + &
+ 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)/C_biot * (&
+ 1._CUSTOM_REAL - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+&
+ rhol_bar_global(iglob)/rhol_f_global(iglob)*ratio)/dd1 )*Cb_kl(i,j,ispec)
+ cs_kl(i,j,ispec) = - 8._CUSTOM_REAL/3._CUSTOM_REAL*cssquare*rhol_bar_global(iglob)/B_biot*(1._CUSTOM_REAL-&
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*rhol_bar_global(iglob)))*Bb_kl(i,j,ispec) + &
+ 2._CUSTOM_REAL*(rhol_bar_global(iglob)-rhol_f_global(iglob)*phil_global(iglob)/tortl_global(iglob))/&
+ mulfr_global(iglob)*cssquare*mufrb_kl(i,j,ispec)
+ ratio_kl(i,j,ispec) = ratio*rhol_bar_global(iglob)*phil_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIsquare-cpIIsquare) * ( &
+ phil_global(iglob)/tortl_global(iglob)*(2._CUSTOM_REAL*ratio+1._CUSTOM_REAL+rhol_f_global(iglob)/ &
+ rhol_bar_global(iglob))/dd1 - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*(&
+ 1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-1._CUSTOM_REAL)*(2._CUSTOM_REAL*ratio*(&
+ 1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob)) +&
+ 2._CUSTOM_REAL)/dd1**2 )*Bb_kl(i,j,ispec) + &
+ ratio*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot)*(cpIsquare-cpIIsquare) * &
+ 2._CUSTOM_REAL*phil_global(iglob)/tortl_global(iglob) * (&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2*((1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob))*ratio+1._CUSTOM_REAL)/dd1**2 )*Mb_kl(i,j,ispec) +&
+ ratio*rhol_f_global(iglob)/C_biot*(cpIsquare-cpIIsquare) * (&
+ (2._CUSTOM_REAL*phil_global(iglob)*rhol_bar_global(iglob)*ratio/(tortl_global(iglob)*rhol_f_global(iglob))+&
+ phil_global(iglob)/tortl_global(iglob)+rhol_bar_global(iglob)/rhol_f_global(iglob))/dd1 - &
+ 2._CUSTOM_REAL*phil_global(iglob)/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+&
+ 1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)*ratio)*((1._CUSTOM_REAL+&
+ rhol_bar_global(iglob)/rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob))*ratio+1._CUSTOM_REAL)/&
+ dd1**2 )*Cb_kl(i,j,ispec)
+
+ enddo
+ enddo
+ endif
+ enddo
+
+ endif ! if(any_poroelastic)
+
+ endif ! if(SIMULATION_TYPE == 2)
+
+!
+!---- display results at given time steps
+!
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
+
+!
+! kernels output files
+!
+
+ if(SIMULATION_TYPE == 2 .and. it == NSTEP) then
+
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Writing Kernels file'
+ endif
+
+ if(any_acoustic) then
+ do ispec = 1, nspec
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ xx = coord(1,iglob)
+ zz = coord(2,iglob)
+ write(95,'(5e11.3)')xx,zz,rho_ac_kl(i,j,ispec),kappa_ac_kl(i,j,ispec)
+ write(96,'(5e11.3)')rhorho_ac_hessian_final1(i,j,ispec), rhorho_ac_hessian_final2(i,j,ispec),&
+ rhop_ac_kl(i,j,ispec),alpha_ac_kl(i,j,ispec)
+ enddo
+ enddo
+ enddo
+ close(95)
+ close(96)
+ endif
+
+ if(any_elastic) then
+ do ispec = 1, nspec
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ xx = coord(1,iglob)
+ zz = coord(2,iglob)
+ write(97,'(5e11.3)')xx,zz,rho_kl(i,j,ispec),kappa_kl(i,j,ispec),mu_kl(i,j,ispec)
+ write(98,'(5e11.3)')xx,zz,rhop_kl(i,j,ispec),alpha_kl(i,j,ispec),beta_kl(i,j,ispec)
+ !write(98,'(5e11.3)')rhorho_el_hessian_final1(i,j,ispec), rhorho_el_hessian_final2(i,j,ispec),&
+ ! rhop_kl(i,j,ispec),alpha_kl(i,j,ispec),beta_kl(i,j,ispec)
+ enddo
+ enddo
+ enddo
+ close(97)
+ close(98)
+ endif
+
+ if(any_poroelastic) then
+ do ispec = 1, nspec
+ do j = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,j,ispec)
+ xx = coord(1,iglob)
+ zz = coord(2,iglob)
+ write(144,'(5e11.3)')xx,zz,mufr_kl(i,j,ispec),B_kl(i,j,ispec),C_kl(i,j,ispec)
+ write(155,'(5e11.3)')xx,zz,M_kl(i,j,ispec),rhot_kl(i,j,ispec),rhof_kl(i,j,ispec)
+ write(16,'(5e11.3)')xx,zz,sm_kl(i,j,ispec),eta_kl(i,j,ispec)
+ write(17,'(5e11.3)')xx,zz,mufrb_kl(i,j,ispec),Bb_kl(i,j,ispec),Cb_kl(i,j,ispec)
+ write(18,'(5e11.3)')xx,zz,Mb_kl(i,j,ispec),rhob_kl(i,j,ispec),rhofb_kl(i,j,ispec)
+ write(19,'(5e11.3)')xx,zz,phi_kl(i,j,ispec),eta_kl(i,j,ispec)
+ write(20,'(5e11.3)')xx,zz,cpI_kl(i,j,ispec),cpII_kl(i,j,ispec),cs_kl(i,j,ispec)
+ write(21,'(5e11.3)')xx,zz,rhobb_kl(i,j,ispec),rhofbb_kl(i,j,ispec),ratio_kl(i,j,ispec)
+ write(22,'(5e11.3)')xx,zz,phib_kl(i,j,ispec),eta_kl(i,j,ispec)
+ enddo
+ enddo
+ enddo
+ close(144)
+ close(155)
+ close(16)
+ close(17)
+ close(18)
+ close(19)
+ close(20)
+ close(21)
+ close(22)
+ endif
+
+ endif
+
+!
+!---- PostScript display
+!
+ if(output_postscript_snapshot) then
+
+ if (myrank == 0) write(IOUT,*) 'Writing PostScript file'
+
+ if(imagetype == 1 .and. p_sv) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing displacement vector as small arrows...'
+
+ call compute_vector_whole_medium(potential_acoustic,displ_elastic,displs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
+ nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
+ it,deltat,coorg,xinterp,zinterp,shape2D_display, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,&
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier,&
+ d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
+ d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
+ coorg_send_ps_velocity_model,RGB_send_ps_velocity_model, &
+ coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model, &
+ d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
+ d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
+ coorg_send_ps_element_mesh,color_send_ps_element_mesh, &
+ coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
+ d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
+ coorg_send_ps_abs,coorg_recv_ps_abs, &
+ d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface, &
+ d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
+ coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
+ d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field, &
+ d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
+ coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
+
+ else if(imagetype == 2 .and. p_sv) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing velocity vector as small arrows...'
+
+ call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
+ nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
+ it,deltat,coorg,xinterp,zinterp,shape2D_display, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,&
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier,&
+ d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
+ d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
+ coorg_send_ps_velocity_model,RGB_send_ps_velocity_model, &
+ coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model, &
+ d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
+ d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
+ coorg_send_ps_element_mesh,color_send_ps_element_mesh, &
+ coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
+ d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
+ coorg_send_ps_abs,coorg_recv_ps_abs, &
+ d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface, &
+ d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
+ coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
+ d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field, &
+ d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
+ coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
+
+ else if(imagetype == 3 .and. p_sv) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing acceleration vector as small arrows...'
+
+ call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,accels_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
+ nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ call plotpost(vector_field_display,coord,vpext,x_source,z_source,x_final_receiver,z_final_receiver, &
+ it,deltat,coorg,xinterp,zinterp,shape2D_display, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCES, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poro,coupled_elastic_poro, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier,&
+ d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
+ d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
+ d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model, &
+ d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
+ coorg_send_ps_velocity_model,RGB_send_ps_velocity_model, &
+ coorg_recv_ps_velocity_model,RGB_recv_ps_velocity_model, &
+ d1_coorg_send_ps_element_mesh,d2_coorg_send_ps_element_mesh, &
+ d1_coorg_recv_ps_element_mesh,d2_coorg_recv_ps_element_mesh, &
+ d1_color_send_ps_element_mesh,d1_color_recv_ps_element_mesh, &
+ coorg_send_ps_element_mesh,color_send_ps_element_mesh, &
+ coorg_recv_ps_element_mesh,color_recv_ps_element_mesh, &
+ d1_coorg_send_ps_abs,d1_coorg_recv_ps_abs,d2_coorg_send_ps_abs,d2_coorg_recv_ps_abs, &
+ coorg_send_ps_abs,coorg_recv_ps_abs, &
+ d1_coorg_send_ps_free_surface,d1_coorg_recv_ps_free_surface, &
+ d2_coorg_send_ps_free_surface,d2_coorg_recv_ps_free_surface, &
+ coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
+ d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field, &
+ d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
+ coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
+
+ else if(imagetype == 4 .or. .not. p_sv) then
+
+ if (myrank == 0) write(IOUT,*) 'cannot draw scalar pressure field or y-component field as a vector plot, skipping...'
+
+ else
+ call exit_MPI('wrong type for snapshots')
+ endif
+
+ if (myrank == 0 .and. imagetype /= 4 .and. p_sv) write(IOUT,*) 'PostScript file written'
+
+ endif
+
+!
+!---- display color image
+!
+ if(output_color_image) then
+
+ if (myrank == 0) write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color,' for time step ',it
+
+ if(imagetype == 1) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) component of displacement vector...'
+
+ call compute_vector_whole_medium(potential_acoustic,displ_elastic,displs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
+ nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ else if(imagetype == 2) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) component of velocity vector...'
+
+ call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
+ nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ else if(imagetype == 3) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing image of z (if P-SV) or y (if SH) component of acceleration vector...'
+
+ call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,accels_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz, &
+ nspec,npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic, &
+ numat,kmato,density,rhoext,assign_external_model)
+
+ else if(imagetype == 4 .and. p_sv) then
+
+ if (myrank == 0) write(IOUT,*) 'drawing image of pressure field...'
+
+ call compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec, &
+ npoin,npoin_acoustic,npoin_elastic,npoin_poroelastic,assign_external_model, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext, &
+ c11ext,c13ext,c15ext,c33ext,c35ext,c55ext,anisotropic,anisotropy,e1,e11, &
+ TURN_ATTENUATION_ON,Mu_nu1,Mu_nu2,N_SLS)
+
+ else if(imagetype == 4 .and. .not. p_sv) then
+ call exit_MPI('cannot draw pressure field for SH (membrane) waves')
+ else
+ call exit_MPI('wrong type for snapshots')
+ endif
+
+ image_color_data(:,:) = 0.d0
+
+ do k = 1, nb_pixel_loc
+ j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
+ i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
+ if(p_sv) then !P-SH waves, plot vertical component or pressure
+ image_color_data(i,j) = vector_field_display(3,iglob_image_color(i,j))
+ else !SH (membrane) waves, plot y-component
+ image_color_data(i,j) = vector_field_display(2,iglob_image_color(i,j))
+ endif
+ enddo
+
+! assembling array image_color_data on process zero for color output
+#ifdef USE_MPI
+ if (nproc > 1) then
+ if (myrank == 0) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV(data_pixel_recv(1),nb_pixel_per_proc(iproc+1), MPI_DOUBLE_PRECISION, &
+ iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ do k = 1, nb_pixel_per_proc(iproc+1)
+ j = ceiling(real(num_pixel_recv(k,iproc+1)) / real(NX_IMAGE_color))
+ i = num_pixel_recv(k,iproc+1) - (j-1)*NX_IMAGE_color
+ image_color_data(i,j) = data_pixel_recv(k)
+ enddo
+ enddo
+
+ else
+ do k = 1, nb_pixel_loc
+ j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
+ i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
+ if(p_sv) then !P-SH waves, plot vertical component or pressure
+ data_pixel_send(k) = vector_field_display(3,iglob_image_color(i,j))
+ else !SH (membrane) waves, plot y-component
+ data_pixel_send(k) = vector_field_display(2,iglob_image_color(i,j))
+ endif
+ enddo
+
+ call MPI_SEND(data_pixel_send(1),nb_pixel_loc,MPI_DOUBLE_PRECISION, 0, 43, MPI_COMM_WORLD, ier)
+
+ endif
+ endif
+
+#endif
+
+ if (myrank == 0) then
+ call create_color_image(image_color_data,iglob_image_color, &
+ NX_IMAGE_color,NZ_IMAGE_color,it,cutsnaps,image_color_vp_display)
+ write(IOUT,*) 'Color image created'
+ endif
+
+ endif
+
+!---- save temporary or final seismograms
+! suppress seismograms if we generate traces of the run for analysis with "ParaVer", because time consuming
+ if(.not. GENERATE_PARAVER_TRACES) &
+ call write_seismograms(sisux,sisuz,siscurl,station_name,network_name,NSTEP, &
+ nrecloc,which_proc_receiver,nrec,myrank,deltat,seismotype,st_xval,t0, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current,p_sv)
+
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+
+ endif
+
+#ifdef USE_MPI
+! add a barrier if we generate traces of the run for analysis with "ParaVer"
+ if(GENERATE_PARAVER_TRACES) call MPI_BARRIER(MPI_COMM_WORLD,ier)
+#endif
+
+ enddo ! end of the main time loop
+
+ if((SAVE_FORWARD .and. SIMULATION_TYPE==1) .or. SIMULATION_TYPE ==2) then
+ if(any_acoustic) then
+ close(65)
+ close(66)
+ close(67)
+ close(68)
+ endif
+ if(any_elastic) then
+ close(35)
+ close(36)
+ close(37)
+ close(38)
+ endif
+ if(any_poroelastic) then
+ close(25)
+ close(45)
+ close(26)
+ close(46)
+ close(29)
+ close(47)
+ close(28)
+ close(48)
+ endif
+ endif
+
+!
+!--- save last frame
+!
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_elastic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving elastic last frame...'
+ write(IOUT,*)
+ endif
+ write(outputname,'(a,i6.6,a)') 'lastframe_elastic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ if(p_sv)then !P-SV waves
+ do j=1,npoin
+ write(55) displ_elastic(1,j), displ_elastic(3,j), &
+ veloc_elastic(1,j), veloc_elastic(3,j), &
+ accel_elastic(1,j), accel_elastic(3,j)
+ enddo
+ else !SH (membrane) waves
+ do j=1,npoin
+ write(55) displ_elastic(2,j), &
+ veloc_elastic(2,j), &
+ accel_elastic(2,j)
+ enddo
+ endif
+ close(55)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_poroelastic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving poroelastic last frame...'
+ write(IOUT,*)
+ endif
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_w',myrank,'.bin'
+ open(unit=56,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ do j=1,npoin
+ write(55) (displs_poroelastic(i,j), i=1,NDIM), &
+ (velocs_poroelastic(i,j), i=1,NDIM), &
+ (accels_poroelastic(i,j), i=1,NDIM)
+ write(56) (displw_poroelastic(i,j), i=1,NDIM), &
+ (velocw_poroelastic(i,j), i=1,NDIM), &
+ (accelw_poroelastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+ close(56)
+ endif
+
+ if(SAVE_FORWARD .and. SIMULATION_TYPE ==1 .and. any_acoustic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving acoustic last frame...'
+ write(IOUT,*)
+ endif
+ write(outputname,'(a,i6.6,a)') 'lastframe_acoustic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ do j=1,npoin
+ write(55) potential_acoustic(j),&
+ potential_dot_acoustic(j),&
+ potential_dot_dot_acoustic(j)
+ enddo
+ close(55)
+ endif
+
+
+ deallocate(v0x_left)
+ deallocate(v0z_left)
+ deallocate(t0x_left)
+ deallocate(t0z_left)
+
+ deallocate(v0x_right)
+ deallocate(v0z_right)
+ deallocate(t0x_right)
+ deallocate(t0z_right)
+
+ deallocate(v0x_bot)
+ deallocate(v0z_bot)
+ deallocate(t0x_bot)
+ deallocate(t0z_bot)
+
+!---- close energy file and create a gnuplot script to display it
+ if(OUTPUT_ENERGY .and. myrank == 0) then
+ close(IOUT_ENERGY)
+ open(unit=IOUT_ENERGY,file='plotenergy',status='unknown')
+ write(IOUT_ENERGY,*) 'set term postscript landscape color solid "Helvetica" 22'
+ write(IOUT_ENERGY,*) 'set output "energy.ps"'
+ write(IOUT_ENERGY,*) 'set xlabel "Time (s)"'
+ write(IOUT_ENERGY,*) 'set ylabel "Energy (J)"'
+ write(IOUT_ENERGY,*) 'plot "energy.gnu" us 1:4 t ''Total Energy'' w l 1, "energy.gnu" us 1:3 t ''Potential Energy'' w l 2'
+ close(IOUT_ENERGY)
+ endif
+
+ if (.not. any_poroelastic) then
+open(unit=1001,file='DATA/model_velocity.dat_output',status='unknown')
+ if ( .NOT. assign_external_model) then
+allocate(rho_local(ngllx,ngllz,nspec)); rho_local=0.
+allocate(vp_local(ngllx,ngllz,nspec)); vp_local=0.
+allocate(vs_local(ngllx,ngllz,nspec)); vs_local=0.
+!! write(1001,*) npoin
+!! do iglob = 1,npoin
+!! write(1001,*) coord(1,iglob),coord(2,iglob),rho_global(iglob),vp_global(iglob),vs_global(iglob)
+!! end do
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ rho_local(i,j,ispec) = density(1,kmato(ispec))
+ vp_local(i,j,ispec) = sqrt(poroelastcoef(3,1,kmato(ispec))/density(1,kmato(ispec)))
+ vs_local(i,j,ispec) = sqrt(poroelastcoef(2,1,kmato(ispec))/density(1,kmato(ispec)))
+ write(1001,'(I10, 5F13.4)') iglob, coord(1,iglob),coord(2,iglob),&
+ rho_local(i,j,ispec),vp_local(i,j,ispec),vs_local(i,j,ispec)
+ end do
+ end do
+ end do
+ else
+!! write(1001,*) npoin
+!! do iglob = 1,npoin
+!! write(1001,*) coord(1,iglob),coord(2,iglob),rhoext_global(iglob),vpext_global(iglob),vsext_global(iglob)
+!! end do
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ write(1001,'(I10,5F13.4)') iglob, coord(1,iglob),coord(2,iglob),&
+ rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec)
+ end do
+ end do
+ end do
+ endif
+close(1001)
+ endif
+
+! print exit banner
+ if (myrank == 0) call datim(simulation_title)
+
+!
+!---- close output file
+!
+ if(IOUT /= ISTANDARD_OUTPUT) close(IOUT)
+
+!
+!---- end MPI
+!
+#ifdef USE_MPI
+ call MPI_FINALIZE(ier)
+#endif
+
+!
+!---- formats
+!
+
+ 400 format(/1x,41('=')/,' = T i m e e v o l u t i o n l o o p ='/1x,41('=')/)
+
+ end program specfem2D
+
Copied: seismo/2D/SPECFEM2D/trunk/src/spline_routines.f90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/spline_routines.f90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/spline_routines.f90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/spline_routines.f90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,174 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! compute spline coefficients
+
+ subroutine spline_construction(xpoint,ypoint,npoint,tangent_first_point,tangent_last_point,spline_coefficients)
+
+ implicit none
+
+! tangent to the spline imposed at the first and last points
+ double precision, intent(in) :: tangent_first_point,tangent_last_point
+
+! number of input points and coordinates of the input points
+ integer, intent(in) :: npoint
+ double precision, dimension(npoint), intent(in) :: xpoint,ypoint
+
+! spline coefficients output by the routine
+ double precision, dimension(npoint), intent(out) :: spline_coefficients
+
+ integer :: i
+
+ double precision, dimension(:), allocatable :: temporary_array
+
+ allocate(temporary_array(npoint))
+
+ spline_coefficients(1) = - 1.d0 / 2.d0
+
+ temporary_array(1) = (3.d0/(xpoint(2)-xpoint(1)))*((ypoint(2)-ypoint(1))/(xpoint(2)-xpoint(1))-tangent_first_point)
+
+ do i = 2,npoint-1
+
+ spline_coefficients(i) = ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))-1.d0) &
+ / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
+
+ temporary_array(i) = (6.d0*((ypoint(i+1)-ypoint(i))/(xpoint(i+1)-xpoint(i)) &
+ - (ypoint(i)-ypoint(i-1))/(xpoint(i)-xpoint(i-1)))/(xpoint(i+1)-xpoint(i-1)) &
+ - (xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*temporary_array(i-1)) &
+ / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
+
+ enddo
+
+ spline_coefficients(npoint) = ((3.d0/(xpoint(npoint)-xpoint(npoint-1))) &
+ * (tangent_last_point-(ypoint(npoint)-ypoint(npoint-1))/(xpoint(npoint)-xpoint(npoint-1))) &
+ - 1.d0/2.d0*temporary_array(npoint-1))/(1.d0/2.d0*spline_coefficients(npoint-1)+1.d0)
+
+ do i = npoint-1,1,-1
+ spline_coefficients(i) = spline_coefficients(i)*spline_coefficients(i+1) + temporary_array(i)
+ enddo
+
+ deallocate(temporary_array)
+
+ end subroutine spline_construction
+
+!
+! ------------------------------------------------------------------------------------------------
+!
+
+! evaluate a spline
+
+ subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate_spline,y_spline_obtained)
+
+ implicit none
+
+! number of input points and coordinates of the input points
+ integer, intent(in) :: npoint
+ double precision, dimension(npoint), intent(in) :: xpoint,ypoint
+
+! spline coefficients to use
+ double precision, dimension(npoint), intent(in) :: spline_coefficients
+
+! abscissa at which we need to evaluate the value of the spline
+ double precision, intent(in):: x_evaluate_spline
+
+! ordinate evaluated by the routine for the spline at this abscissa
+ double precision, intent(out):: y_spline_obtained
+
+ integer :: index_loop,index_lower,index_higher
+
+ double precision :: coef1,coef2
+
+! initialize to the whole interval
+ index_lower = 1
+ index_higher = npoint
+
+! determine the right interval to use, by dichotomy
+ do while (index_higher - index_lower > 1)
+! compute the middle of the interval
+ index_loop = (index_higher + index_lower) / 2
+ if(xpoint(index_loop) > x_evaluate_spline) then
+ index_higher = index_loop
+ else
+ index_lower = index_loop
+ endif
+ enddo
+
+! test that the interval obtained does not have a size of zero
+! (this could happen for instance in the case of duplicates in the input list of points)
+ if(xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation'
+
+ coef1 = (xpoint(index_higher) - x_evaluate_spline) / (xpoint(index_higher) - xpoint(index_lower))
+ coef2 = (x_evaluate_spline - xpoint(index_lower)) / (xpoint(index_higher) - xpoint(index_lower))
+
+ y_spline_obtained = coef1*ypoint(index_lower) + coef2*ypoint(index_higher) + &
+ ((coef1**3 - coef1)*spline_coefficients(index_lower) + &
+ (coef2**3 - coef2)*spline_coefficients(index_higher))*((xpoint(index_higher) - xpoint(index_lower))**2)/6.d0
+
+ end subroutine spline_evaluation
+
+!
+! ------------------------------------------------------------------------------------------------
+!
+
+!--- spline to describe the interfaces
+
+double precision function value_spline(x,xinterface,zinterface,coefs_interface,npoints_interface)
+
+ implicit none
+
+ integer npoints_interface
+ double precision x,xp
+ double precision, dimension(npoints_interface) :: xinterface,zinterface,coefs_interface
+
+ value_spline = 0.d0
+
+ xp = x
+
+ ! assign the value on the edge if point is outside the model
+ if(xp < xinterface(1)) xp = xinterface(1)
+ if(xp > xinterface(npoints_interface)) xp = xinterface(npoints_interface)
+
+ call spline_evaluation(xinterface,zinterface,coefs_interface,npoints_interface,xp,value_spline)
+
+end function value_spline
Copied: seismo/2D/SPECFEM2D/trunk/src/write_seismograms.F90 (from rev 17978, seismo/2D/SPECFEM2D/trunk/write_seismograms.F90)
===================================================================
--- seismo/2D/SPECFEM2D/trunk/src/write_seismograms.F90 (rev 0)
+++ seismo/2D/SPECFEM2D/trunk/src/write_seismograms.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -0,0 +1,396 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 6.1
+! ------------------------------
+!
+! Copyright Universite de Pau, CNRS and INRIA, France,
+! and Princeton University / California Institute of Technology, USA.
+! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
+! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
+! Roland Martin, roland DOT martin aT univ-pau DOT fr
+! Christina Morency, cmorency aT princeton DOT edu
+!
+! This software is a computer program whose purpose is to solve
+! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
+! using a spectral-element method (SEM).
+!
+! This software is governed by the CeCILL license under French law and
+! abiding by the rules of distribution of free software. You can use,
+! modify and/or redistribute the software under the terms of the CeCILL
+! license as circulated by CEA, CNRS and INRIA at the following URL
+! "http://www.cecill.info".
+!
+! As a counterpart to the access to the source code and rights to copy,
+! modify and redistribute granted by the license, users are provided only
+! with a limited warranty and the software's author, the holder of the
+! economic rights, and the successive licensors have only limited
+! liability.
+!
+! In this respect, the user's attention is drawn to the risks associated
+! with loading, using, modifying and/or developing or reproducing the
+! software by the user in light of its specific status of free software,
+! that may mean that it is complicated to manipulate, and that also
+! therefore means that it is reserved for developers and experienced
+! professionals having in-depth computer knowledge. Users are therefore
+! encouraged to load and test the software's suitability as regards their
+! requirements in conditions enabling the security of their systems and/or
+! data to be ensured and, more generally, to use and operate it in the
+! same conditions as regards security.
+!
+! The full text of the license is available in file "LICENSE".
+!
+!========================================================================
+
+! write seismograms to text files
+
+ subroutine write_seismograms(sisux,sisuz,siscurl,station_name,network_name, &
+ NSTEP,nrecloc,which_proc_receiver,nrec,myrank,deltat,seismotype,st_xval,t0, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current,p_sv &
+ )
+
+ implicit none
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+
+ integer :: nrec,NSTEP,seismotype
+ integer :: NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current
+ double precision :: t0,deltat
+
+ logical :: p_sv
+
+ integer, intent(in) :: nrecloc,myrank
+ integer, dimension(nrec),intent(in) :: which_proc_receiver
+
+ double precision, dimension(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc), intent(in) :: sisux,sisuz,siscurl
+
+ double precision st_xval(nrec)
+
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ integer irec,length_station_name,length_network_name,iorientation,isample,number_of_components
+
+ character(len=4) chn
+ character(len=1) component
+ character(len=150) sisname
+
+! to write seismograms in single precision SEP and double precision binary format
+ double precision, dimension(:,:), allocatable :: buffer_binary
+
+! scaling factor for Seismic Unix xsu dislay
+ double precision, parameter :: FACTORXSU = 1.d0
+
+
+ integer :: irecloc
+
+#ifdef USE_MPI
+ integer :: ierror
+ integer, dimension(MPI_STATUS_SIZE) :: status
+#endif
+
+!----
+
+! write seismograms in ASCII format
+
+! save displacement, velocity, acceleration or pressure
+ if(seismotype == 1) then
+ component = 'd'
+ else if(seismotype == 2) then
+ component = 'v'
+ else if(seismotype == 3) then
+ component = 'a'
+ else if(seismotype == 4 .or. seismotype == 6) then
+ component = 'p'
+ else if(seismotype == 5) then
+ component = 'c'
+ else
+ call exit_MPI('wrong component to save for seismograms')
+ endif
+
+
+! only one seismogram if pressures or SH (membrane) waves
+ if(seismotype == 4 .or. seismotype == 6 .or. .not. p_sv) then
+ number_of_components = 1
+ else if(seismotype == 5) then
+ number_of_components = NDIM+1
+ else
+ number_of_components = NDIM
+ endif
+
+ allocate(buffer_binary(NTSTEP_BETWEEN_OUTPUT_SEISMO,number_of_components))
+
+
+ if ( myrank == 0 .and. seismo_offset == 0 ) then
+
+! delete the old files
+ open(unit=11,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/Curl_file_single.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/Curl_file_double.bin',status='unknown')
+ close(11,status='delete')
+
+ endif
+
+ if ( myrank == 0 ) then
+
+! write the new files
+ if(seismotype == 4 .or. seismotype == 6) then
+ open(unit=12,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown',access='direct',recl=4)
+ elseif(.not.p_sv) then
+ open(unit=12,file='OUTPUT_FILES/Uy_file_single.bin',status='unknown',access='direct',recl=4)
+ else
+ open(unit=12,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown',access='direct',recl=4)
+ endif
+
+ if(seismotype == 4 .or. seismotype == 6) then
+ open(unit=13,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown',access='direct',recl=8)
+ elseif(.not.p_sv) then
+ open(unit=13,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown',access='direct',recl=8)
+ else
+ open(unit=13,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown',access='direct',recl=8)
+ endif
+
+! no Z component seismogram if pressure
+ if(seismotype /= 4 .and. seismotype /= 6 .and. p_sv) then
+ open(unit=14,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown',access='direct',recl=4)
+ open(unit=15,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown',access='direct',recl=8)
+
+ end if
+
+! curl output
+ if(seismotype == 5) then
+ open(unit=16,file='OUTPUT_FILES/Curl_file_single.bin',status='unknown',access='direct',recl=4)
+ open(unit=17,file='OUTPUT_FILES/Curl_file_double.bin',status='unknown',access='direct',recl=8)
+
+ end if
+
+ end if
+
+
+ irecloc = 0
+ do irec = 1,nrec
+
+ if ( myrank == 0 ) then
+
+ if ( which_proc_receiver(irec) == myrank ) then
+ irecloc = irecloc + 1
+ buffer_binary(:,1) = sisux(:,irecloc)
+ if ( number_of_components == 2 ) then
+ buffer_binary(:,2) = sisuz(:,irecloc)
+ else if ( number_of_components == 3 ) then
+ buffer_binary(:,2) = sisuz(:,irecloc)
+ buffer_binary(:,3) = siscurl(:,irecloc)
+ end if
+
+#ifdef USE_MPI
+ else
+ call MPI_RECV(buffer_binary(1,1),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
+ if ( number_of_components == 2 ) then
+ call MPI_RECV(buffer_binary(1,2),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
+ end if
+ if ( number_of_components == 3 ) then
+ call MPI_RECV(buffer_binary(1,2),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
+ call MPI_RECV(buffer_binary(1,3),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
+ which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
+ end if
+
+
+#endif
+ end if
+
+! write trace
+ do iorientation = 1,number_of_components
+
+ if(iorientation == 1) then
+ chn = 'BHX'
+ else if(iorientation == 2) then
+ chn = 'BHZ'
+ else if(iorientation == 3) then
+ chn = 'cur'
+ else
+ call exit_MPI('incorrect channel value')
+ endif
+
+ ! in case of pressure, use different abbreviation
+ if(seismotype == 4 .or. seismotype == 6) chn = 'PRE'
+ ! in case of SH (membrane) waves, use different abbreviation
+ if(.not.p_sv) chn = 'BHY'
+
+ ! create the name of the seismogram file for each slice
+ ! file name includes the name of the station, the network and the component
+ length_station_name = len_trim(station_name(irec))
+ length_network_name = len_trim(network_name(irec))
+
+ ! check that length conforms to standard
+ if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) then
+ call exit_MPI('wrong length of station name')
+ end if
+ if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) then
+ call exit_MPI('wrong length of network name')
+ end if
+
+ write(sisname,"('OUTPUT_FILES/',a,'.',a,'.',a3,'.sem',a1)") station_name(irec)(1:length_station_name),&
+ network_name(irec)(1:length_network_name),chn,component
+
+ ! save seismograms in text format with no subsampling.
+ ! Because we do not subsample the output, this can result in large files
+ ! if the simulation uses many time steps. However, subsampling the output
+ ! here would result in a loss of accuracy when one later convolves
+ ! the results with the source time function
+ if ( seismo_offset == 0 ) then
+ open(unit=11,file=sisname(1:len_trim(sisname)),status='unknown')
+ close(11,status='delete')
+ endif
+ open(unit=11,file=sisname(1:len_trim(sisname)),status='unknown',position='append')
+
+ ! make sure we never write more than the maximum number of time steps
+ ! subtract offset of the source to make sure travel time is correct
+ do isample = 1,seismo_current
+ if(iorientation == 1) then
+ write(11,*) sngl(dble(seismo_offset+isample-1)*deltat - t0),' ', &
+ sngl(buffer_binary(isample,iorientation))
+ else
+ write(11,*) sngl(dble(seismo_offset+isample-1)*deltat - t0),' ', &
+ sngl(buffer_binary(isample,iorientation))
+ endif
+ enddo
+
+ close(11)
+ end do
+
+! write binary seismogram
+ do isample = 1, seismo_current
+ write(12,rec=(irec-1)*NSTEP+seismo_offset+isample) sngl(buffer_binary(isample,1))
+ write(13,rec=(irec-1)*NSTEP+seismo_offset+isample) buffer_binary(isample,1)
+ if ( seismotype /= 4 .and. seismotype /= 6 .and. p_sv) then
+ write(14,rec=(irec-1)*NSTEP+seismo_offset+isample) sngl(buffer_binary(isample,2))
+ write(15,rec=(irec-1)*NSTEP+seismo_offset+isample) buffer_binary(isample,2)
+ end if
+ if ( seismotype == 5 ) then
+ write(16,rec=(irec-1)*NSTEP+seismo_offset+isample) sngl(buffer_binary(isample,3))
+ write(17,rec=(irec-1)*NSTEP+seismo_offset+isample) buffer_binary(isample,3)
+ end if
+ enddo
+#ifdef USE_MPI
+
+ else
+ if ( which_proc_receiver(irec) == myrank ) then
+ irecloc = irecloc + 1
+ call MPI_SEND(sisux(1,irecloc),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ierror)
+ if ( number_of_components >= 2 ) then
+ call MPI_SEND(sisuz(1,irecloc),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ierror)
+ end if
+ if ( number_of_components == 3 ) then
+ call MPI_SEND(siscurl(1,irecloc),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ierror)
+ end if
+ end if
+
+#endif
+
+ end if
+
+ enddo
+
+ close(12)
+ close(13)
+ if ( seismotype /= 4 .and. seismotype /= 6 .and. p_sv) then
+ close(14)
+ close(15)
+ end if
+ if ( seismotype == 5 ) then
+ close(16)
+ close(17)
+ end if
+
+!----
+
+ deallocate(buffer_binary)
+
+!----
+ if ( myrank == 0 ) then
+
+! ligne de recepteurs pour Xsu
+ open(unit=11,file='OUTPUT_FILES/receiver_line_Xsu_XWindow',status='unknown')
+
+! subtract t0 from seismograms to get correct zero time
+ write(11,110) FACTORXSU,NSTEP,deltat,-t0,nrec
+
+ do irec=1,nrec
+ ! this format statement might now work for larger meshes
+ !write(11,"(f12.5)") st_xval(irec)
+ write(11,*) st_xval(irec)
+ if(irec < nrec) write(11,*) ','
+ enddo
+
+ if(seismotype == 1) then
+ write(11,*) '@title="Ux at displacement@component"@<@Ux_file_single.bin'
+ else if(seismotype == 2) then
+ write(11,*) '@title="Ux at velocity@component"@<@Ux_file_single.bin'
+ else
+ write(11,*) '@title="Ux at acceleration@component"@<@Ux_file_single.bin'
+ endif
+
+ close(11)
+
+! script de visualisation
+ open(unit=11,file='OUTPUT_FILES/show_receiver_line_Xsu',status='unknown')
+ write(11,"('#!/bin/csh')")
+ write(11,*)
+ write(11,*) '/bin/rm -f tempfile receiver_line_Xsu_postscript'
+ write(11,*) '# concatener toutes les lignes'
+ write(11,*) 'tr -d ''\012'' <receiver_line_Xsu_XWindow >tempfile'
+ write(11,*) '# remettre fin de ligne'
+ write(11,*) 'echo " " >> tempfile'
+ write(11,*) '# supprimer espaces, changer arobas, dupliquer'
+ write(11,120)
+ write(11,*) '/bin/rm -f tempfile'
+ write(11,*) '# copier fichier pour sortie postscript'
+ write(11,130)
+ write(11,*) '/bin/rm -f tempfile'
+ write(11,*) 'echo ''rm -f uxpoly.ps uzpoly.ps'' > tempfile'
+ write(11,*) 'cat tempfile receiver_line_Xsu_postscript > tempfile2'
+ write(11,*) '/bin/mv -f tempfile2 receiver_line_Xsu_postscript'
+ write(11,*) '/bin/rm -f tempfile'
+ write(11,*) '# executer commande xsu'
+ write(11,*) 'sh receiver_line_Xsu_XWindow'
+ write(11,*) '/bin/rm -f tempfile tempfile2'
+ close(11)
+
+end if
+
+! formats
+ 110 format('xwigb at xcur=',f8.2,'@n1=',i6,'@d1=',f15.8,'@f1=',f15.8,'@label1="Time@(s)"@label2="x@(m)"@n2=',i6,'@x2=')
+
+ 120 format('sed -e ''1,$s/ //g'' -e ''1,$s/@/ /g'' -e ''1,1p'' -e ''$,$s/Ux/Uz/g'' <tempfile > receiver_line_Xsu_XWindow')
+
+ 130 format('sed -e ''1,$s/xwigb/pswigp/g'' ', &
+ '-e ''1,$s/Ux_file_single.bin/Ux_file_single.bin > uxpoly.ps/g'' ', &
+ '-e ''1,$s/Uz_file_single.bin/Uz_file_single.bin > uzpoly.ps/g'' receiver_line_Xsu_XWindow > receiver_line_Xsu_postscript')
+
+ end subroutine write_seismograms
+
Deleted: seismo/2D/SPECFEM2D/trunk/write_seismograms.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/write_seismograms.F90 2011-02-25 22:48:18 UTC (rev 17979)
+++ seismo/2D/SPECFEM2D/trunk/write_seismograms.F90 2011-02-25 22:50:58 UTC (rev 17980)
@@ -1,396 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 6.1
-! ------------------------------
-!
-! Copyright Universite de Pau, CNRS and INRIA, France,
-! and Princeton University / California Institute of Technology, USA.
-! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
-! Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
-! Roland Martin, roland DOT martin aT univ-pau DOT fr
-! Christina Morency, cmorency aT princeton DOT edu
-!
-! This software is a computer program whose purpose is to solve
-! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
-! using a spectral-element method (SEM).
-!
-! This software is governed by the CeCILL license under French law and
-! abiding by the rules of distribution of free software. You can use,
-! modify and/or redistribute the software under the terms of the CeCILL
-! license as circulated by CEA, CNRS and INRIA at the following URL
-! "http://www.cecill.info".
-!
-! As a counterpart to the access to the source code and rights to copy,
-! modify and redistribute granted by the license, users are provided only
-! with a limited warranty and the software's author, the holder of the
-! economic rights, and the successive licensors have only limited
-! liability.
-!
-! In this respect, the user's attention is drawn to the risks associated
-! with loading, using, modifying and/or developing or reproducing the
-! software by the user in light of its specific status of free software,
-! that may mean that it is complicated to manipulate, and that also
-! therefore means that it is reserved for developers and experienced
-! professionals having in-depth computer knowledge. Users are therefore
-! encouraged to load and test the software's suitability as regards their
-! requirements in conditions enabling the security of their systems and/or
-! data to be ensured and, more generally, to use and operate it in the
-! same conditions as regards security.
-!
-! The full text of the license is available in file "LICENSE".
-!
-!========================================================================
-
-! write seismograms to text files
-
- subroutine write_seismograms(sisux,sisuz,siscurl,station_name,network_name, &
- NSTEP,nrecloc,which_proc_receiver,nrec,myrank,deltat,seismotype,st_xval,t0, &
- NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current,p_sv &
- )
-
- implicit none
-
- include "constants.h"
-#ifdef USE_MPI
- include "mpif.h"
-#endif
-
- integer :: nrec,NSTEP,seismotype
- integer :: NTSTEP_BETWEEN_OUTPUT_SEISMO,seismo_offset,seismo_current
- double precision :: t0,deltat
-
- logical :: p_sv
-
- integer, intent(in) :: nrecloc,myrank
- integer, dimension(nrec),intent(in) :: which_proc_receiver
-
- double precision, dimension(NTSTEP_BETWEEN_OUTPUT_SEISMO,nrecloc), intent(in) :: sisux,sisuz,siscurl
-
- double precision st_xval(nrec)
-
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- integer irec,length_station_name,length_network_name,iorientation,isample,number_of_components
-
- character(len=4) chn
- character(len=1) component
- character(len=150) sisname
-
-! to write seismograms in single precision SEP and double precision binary format
- double precision, dimension(:,:), allocatable :: buffer_binary
-
-! scaling factor for Seismic Unix xsu dislay
- double precision, parameter :: FACTORXSU = 1.d0
-
-
- integer :: irecloc
-
-#ifdef USE_MPI
- integer :: ierror
- integer, dimension(MPI_STATUS_SIZE) :: status
-#endif
-
-!----
-
-! write seismograms in ASCII format
-
-! save displacement, velocity, acceleration or pressure
- if(seismotype == 1) then
- component = 'd'
- else if(seismotype == 2) then
- component = 'v'
- else if(seismotype == 3) then
- component = 'a'
- else if(seismotype == 4 .or. seismotype == 6) then
- component = 'p'
- else if(seismotype == 5) then
- component = 'c'
- else
- call exit_MPI('wrong component to save for seismograms')
- endif
-
-
-! only one seismogram if pressures or SH (membrane) waves
- if(seismotype == 4 .or. seismotype == 6 .or. .not. p_sv) then
- number_of_components = 1
- else if(seismotype == 5) then
- number_of_components = NDIM+1
- else
- number_of_components = NDIM
- endif
-
- allocate(buffer_binary(NTSTEP_BETWEEN_OUTPUT_SEISMO,number_of_components))
-
-
- if ( myrank == 0 .and. seismo_offset == 0 ) then
-
-! delete the old files
- open(unit=11,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/Curl_file_single.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/Curl_file_double.bin',status='unknown')
- close(11,status='delete')
-
- endif
-
- if ( myrank == 0 ) then
-
-! write the new files
- if(seismotype == 4 .or. seismotype == 6) then
- open(unit=12,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown',access='direct',recl=4)
- elseif(.not.p_sv) then
- open(unit=12,file='OUTPUT_FILES/Uy_file_single.bin',status='unknown',access='direct',recl=4)
- else
- open(unit=12,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown',access='direct',recl=4)
- endif
-
- if(seismotype == 4 .or. seismotype == 6) then
- open(unit=13,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown',access='direct',recl=8)
- elseif(.not.p_sv) then
- open(unit=13,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown',access='direct',recl=8)
- else
- open(unit=13,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown',access='direct',recl=8)
- endif
-
-! no Z component seismogram if pressure
- if(seismotype /= 4 .and. seismotype /= 6 .and. p_sv) then
- open(unit=14,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown',access='direct',recl=4)
- open(unit=15,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown',access='direct',recl=8)
-
- end if
-
-! curl output
- if(seismotype == 5) then
- open(unit=16,file='OUTPUT_FILES/Curl_file_single.bin',status='unknown',access='direct',recl=4)
- open(unit=17,file='OUTPUT_FILES/Curl_file_double.bin',status='unknown',access='direct',recl=8)
-
- end if
-
- end if
-
-
- irecloc = 0
- do irec = 1,nrec
-
- if ( myrank == 0 ) then
-
- if ( which_proc_receiver(irec) == myrank ) then
- irecloc = irecloc + 1
- buffer_binary(:,1) = sisux(:,irecloc)
- if ( number_of_components == 2 ) then
- buffer_binary(:,2) = sisuz(:,irecloc)
- else if ( number_of_components == 3 ) then
- buffer_binary(:,2) = sisuz(:,irecloc)
- buffer_binary(:,3) = siscurl(:,irecloc)
- end if
-
-#ifdef USE_MPI
- else
- call MPI_RECV(buffer_binary(1,1),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
- which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
- if ( number_of_components == 2 ) then
- call MPI_RECV(buffer_binary(1,2),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
- which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
- end if
- if ( number_of_components == 3 ) then
- call MPI_RECV(buffer_binary(1,2),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
- which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
- call MPI_RECV(buffer_binary(1,3),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,&
- which_proc_receiver(irec),irec,MPI_COMM_WORLD,status,ierror)
- end if
-
-
-#endif
- end if
-
-! write trace
- do iorientation = 1,number_of_components
-
- if(iorientation == 1) then
- chn = 'BHX'
- else if(iorientation == 2) then
- chn = 'BHZ'
- else if(iorientation == 3) then
- chn = 'cur'
- else
- call exit_MPI('incorrect channel value')
- endif
-
- ! in case of pressure, use different abbreviation
- if(seismotype == 4 .or. seismotype == 6) chn = 'PRE'
- ! in case of SH (membrane) waves, use different abbreviation
- if(.not.p_sv) chn = 'BHY'
-
- ! create the name of the seismogram file for each slice
- ! file name includes the name of the station, the network and the component
- length_station_name = len_trim(station_name(irec))
- length_network_name = len_trim(network_name(irec))
-
- ! check that length conforms to standard
- if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) then
- call exit_MPI('wrong length of station name')
- end if
- if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) then
- call exit_MPI('wrong length of network name')
- end if
-
- write(sisname,"('OUTPUT_FILES/',a,'.',a,'.',a3,'.sem',a1)") station_name(irec)(1:length_station_name),&
- network_name(irec)(1:length_network_name),chn,component
-
- ! save seismograms in text format with no subsampling.
- ! Because we do not subsample the output, this can result in large files
- ! if the simulation uses many time steps. However, subsampling the output
- ! here would result in a loss of accuracy when one later convolves
- ! the results with the source time function
- if ( seismo_offset == 0 ) then
- open(unit=11,file=sisname(1:len_trim(sisname)),status='unknown')
- close(11,status='delete')
- endif
- open(unit=11,file=sisname(1:len_trim(sisname)),status='unknown',position='append')
-
- ! make sure we never write more than the maximum number of time steps
- ! subtract offset of the source to make sure travel time is correct
- do isample = 1,seismo_current
- if(iorientation == 1) then
- write(11,*) sngl(dble(seismo_offset+isample-1)*deltat - t0),' ', &
- sngl(buffer_binary(isample,iorientation))
- else
- write(11,*) sngl(dble(seismo_offset+isample-1)*deltat - t0),' ', &
- sngl(buffer_binary(isample,iorientation))
- endif
- enddo
-
- close(11)
- end do
-
-! write binary seismogram
- do isample = 1, seismo_current
- write(12,rec=(irec-1)*NSTEP+seismo_offset+isample) sngl(buffer_binary(isample,1))
- write(13,rec=(irec-1)*NSTEP+seismo_offset+isample) buffer_binary(isample,1)
- if ( seismotype /= 4 .and. seismotype /= 6 .and. p_sv) then
- write(14,rec=(irec-1)*NSTEP+seismo_offset+isample) sngl(buffer_binary(isample,2))
- write(15,rec=(irec-1)*NSTEP+seismo_offset+isample) buffer_binary(isample,2)
- end if
- if ( seismotype == 5 ) then
- write(16,rec=(irec-1)*NSTEP+seismo_offset+isample) sngl(buffer_binary(isample,3))
- write(17,rec=(irec-1)*NSTEP+seismo_offset+isample) buffer_binary(isample,3)
- end if
- enddo
-#ifdef USE_MPI
-
- else
- if ( which_proc_receiver(irec) == myrank ) then
- irecloc = irecloc + 1
- call MPI_SEND(sisux(1,irecloc),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ierror)
- if ( number_of_components >= 2 ) then
- call MPI_SEND(sisuz(1,irecloc),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ierror)
- end if
- if ( number_of_components == 3 ) then
- call MPI_SEND(siscurl(1,irecloc),NTSTEP_BETWEEN_OUTPUT_SEISMO,MPI_DOUBLE_PRECISION,0,irec,MPI_COMM_WORLD,ierror)
- end if
- end if
-
-#endif
-
- end if
-
- enddo
-
- close(12)
- close(13)
- if ( seismotype /= 4 .and. seismotype /= 6 .and. p_sv) then
- close(14)
- close(15)
- end if
- if ( seismotype == 5 ) then
- close(16)
- close(17)
- end if
-
-!----
-
- deallocate(buffer_binary)
-
-!----
- if ( myrank == 0 ) then
-
-! ligne de recepteurs pour Xsu
- open(unit=11,file='OUTPUT_FILES/receiver_line_Xsu_XWindow',status='unknown')
-
-! subtract t0 from seismograms to get correct zero time
- write(11,110) FACTORXSU,NSTEP,deltat,-t0,nrec
-
- do irec=1,nrec
- ! this format statement might now work for larger meshes
- !write(11,"(f12.5)") st_xval(irec)
- write(11,*) st_xval(irec)
- if(irec < nrec) write(11,*) ','
- enddo
-
- if(seismotype == 1) then
- write(11,*) '@title="Ux at displacement@component"@<@Ux_file_single.bin'
- else if(seismotype == 2) then
- write(11,*) '@title="Ux at velocity@component"@<@Ux_file_single.bin'
- else
- write(11,*) '@title="Ux at acceleration@component"@<@Ux_file_single.bin'
- endif
-
- close(11)
-
-! script de visualisation
- open(unit=11,file='OUTPUT_FILES/show_receiver_line_Xsu',status='unknown')
- write(11,"('#!/bin/csh')")
- write(11,*)
- write(11,*) '/bin/rm -f tempfile receiver_line_Xsu_postscript'
- write(11,*) '# concatener toutes les lignes'
- write(11,*) 'tr -d ''\012'' <receiver_line_Xsu_XWindow >tempfile'
- write(11,*) '# remettre fin de ligne'
- write(11,*) 'echo " " >> tempfile'
- write(11,*) '# supprimer espaces, changer arobas, dupliquer'
- write(11,120)
- write(11,*) '/bin/rm -f tempfile'
- write(11,*) '# copier fichier pour sortie postscript'
- write(11,130)
- write(11,*) '/bin/rm -f tempfile'
- write(11,*) 'echo ''rm -f uxpoly.ps uzpoly.ps'' > tempfile'
- write(11,*) 'cat tempfile receiver_line_Xsu_postscript > tempfile2'
- write(11,*) '/bin/mv -f tempfile2 receiver_line_Xsu_postscript'
- write(11,*) '/bin/rm -f tempfile'
- write(11,*) '# executer commande xsu'
- write(11,*) 'sh receiver_line_Xsu_XWindow'
- write(11,*) '/bin/rm -f tempfile tempfile2'
- close(11)
-
-end if
-
-! formats
- 110 format('xwigb at xcur=',f8.2,'@n1=',i6,'@d1=',f15.8,'@f1=',f15.8,'@label1="Time@(s)"@label2="x@(m)"@n2=',i6,'@x2=')
-
- 120 format('sed -e ''1,$s/ //g'' -e ''1,$s/@/ /g'' -e ''1,1p'' -e ''$,$s/Ux/Uz/g'' <tempfile > receiver_line_Xsu_XWindow')
-
- 130 format('sed -e ''1,$s/xwigb/pswigp/g'' ', &
- '-e ''1,$s/Ux_file_single.bin/Ux_file_single.bin > uxpoly.ps/g'' ', &
- '-e ''1,$s/Uz_file_single.bin/Uz_file_single.bin > uzpoly.ps/g'' receiver_line_Xsu_XWindow > receiver_line_Xsu_postscript')
-
- end subroutine write_seismograms
-
More information about the CIG-COMMITS
mailing list